packages feed

numeric-prelude (empty) → 0.0.2

raw patch · 94 files changed

+14494/−0 lines, 94 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed

Dependencies added: HUnit, QuickCheck, array, base, containers, non-negative, parsec, random

Files

+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Makefile view
@@ -0,0 +1,75 @@++OBJECT_DIR    := build/$(shell uname -s)-$(shell uname -m)+INTERFACE_DIR := build/Interface++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)++GHC_OPTIONS = -Wall -odir$(OBJECT_DIR) -hidir$(INTERFACE_DIR)+++# names of literate modules after removing literary information+UNLIT_MODULES = $(patsubst %.lhs, %.hs, $(patsubst %.hs, , $(MODULES)))++# names of all modules without literary information+HS_MODULES = $(patsubst %.lhs, %.hs, $(MODULES))++STDINTERFACES = base/base.haddock parsec/parsec.haddock++HADDOCK_INCL = $(patsubst %, -i /usr/local/share/ghc-6.2/html/libraries/%, \+                    $(STDINTERFACES))++HC = ghc++HCI = ghci++++.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 +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`
+ Setup.lhs view
@@ -0,0 +1,5 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple (defaultMain)++> main :: IO ()+> main = defaultMain
+ docs/NOTES view
@@ -0,0 +1,383 @@+* Proper place of abs and signum+After reflection, perhaps  'abs' and 'signum' should be names for+canonically multiplying an element by a unit, and need not necessarily+refer to ordered fields.  There should also be another function+'signuminv'.  They should satisfy++  abs x * signum x == x+  signum x * signuminv x == one+  abs (k*x) == abs k * abs x++(For Real)++  abs x > 0++(For Integral)++  1 `mod` x = 0 ==> signum x = x+  ++The current situation causes minor problems in the definition of the+'PID' class, which uses abs and signum to canonicalize elements.++Currently 'signum' is used some places where 'signuminv' should be+used; e.g., in the definition of 'x % y'.++This factorization seems useful in somewhat surprising generality.+However, there are useful spaces where it's not defined; e.g.,+computable reals.  (abs x is computable, but signum x is not+continuous so not computable.)++* Names of floating point classes+The name 'Float' does seem to imply that the number can be represented+as an integer times an appropriate power of a base.++* GHC bugs+-fno-implicit-prelude is happy to use locally defined 'fromInteger',+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'.+Whereas the Haskell98 'Floating' should be better named 'Transcendental'.+'atan2' is candidate for 'Transcendental' rather than 'Floating'.+The value 'eps' is missing.+Since the functions 'floatRadix', 'floatDigits', 'floatRange'+only need the type of the argument, but not its value -+isn't it better to have a record containing the properties?+This record can be requested by a method+  properties :: a -> FloatingProperties+++* divMod+The order of the return values of 'divMod' is very sensible:+a) The function (`divMod` n) has type a -> (b,a)+   and thus fits to the State data type.+   This could simplify a division algorithm.+b) The order of type a is isomorphic to the order of (b,a)+   where (`divMod` n) is the isomorphism.++However for base conversions the order of the result would be better swapped.+See for instance Number.Positional.++It shall be noted, that 'div', 'mod', 'divMod' have a parameter order,+which is unfortunate for partial application.+Maybe we should turn 'div', 'mod', 'divMod' into helper functions+as needed for infix usage,+and declare different class methods of different names and swapped parameters,+say 'divide', 'modulo', 'divideModulo'.++* safeDiv+For resultant and discriminant computation,+as well as for the Newton-Girard formula+we need a division in a ring, where we know a priori,+that the division can be performed.+Is it sound to put fields like Rational, Double and so on,+into the IntegralDomain class in order to allow one implementation for all types?+Is it better to put all integral types into field class,+thus with a partial (/) function?+See also: PowerSeries+++* (**)+In contrast to (^) and (^^)+it should be restricted to positive bases,+because it is ugly to do an integer test+and it will fail for floating point numbers in some cases:++Prelude> (-1)**2.000000000000001+NaN+Prelude> (-1)**2.0000000000000001+1.0+Prelude> (-1)**1e18+1.0+Prelude> (-1)**1e19+NaN+Prelude> (-1)^(10^19)+1++People are encouraged to check if they can always assert+that the exponent is an integer.+If this is the case they should use explicitly an integer type.+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++It is very common to define instances of Numeric type classes+for wrapping operations of a foreign programming language.+Examples: CSound, SuperCollider, functionalMetaPost.+E.g. the Haskell expression '1+2'+is literally mapped to the CSound expression '1+2' instead of '3'.+This has causes several problems:+ - the so defined numeric type instances do not preserve any mathematical laws,+   e.g. Haskell's 'a+b' is mapped to CSound's "a+b",+   and 'b+a' is mapped to "b+a",+   so this (+) instance is obviously not commutative.+ - It is not possible to fully define Eq and Ord (only max and min) instances+   for such wrapper types.+   People started custom type classes which provide methods like+      (==*) :: CSndExp -> CSndExp -> CSndBool+      ifGT  :: CSndExp -> CSndExp -> CSndExp -> CSndExp -> CSndExp+ - You can only define expressions with a constant amount of operations.+   The computational effort must not depend on interim results.+   Algorithms like the Euclidean algorithm cannot be run on wrapper types.+Thus we should consider custom type classes as well for Additive and Ring.+Unfortunately, this seems to be necessary also for approximate arithmetic+(floating and fixed point numbers).+Even more, the type classes for numerical wrapper types+and those for approximate arithmetic cannot be merged.+Algorithms like the Euclidean algorithm _can_ be implemented for Float and Double.+Eq and Ord can also be implemented,+although usage of Eq is discouraged, and Ord is of restricted use.+(For similar values,+the rounding errors might be greater than the difference of the values.)++* Implicit configuration++Since there are no local type class instances available+we could provide special type classes which return their results in a Reader monad.+Say++(+#) :: MonadReader m => a -> a -> m a+++* PowerSeries++The transcendental power series functions can only be applied+if the coefficient type supports transcendent operations.+E.g. the logarithm of the series [1,2..]::[Rational]+could be computed without problems since (log 1 == 0).+But it fails, because Rational is no Transcendental type.+Actually, for all rational numbers different from 1,+the logarithm is not rational,+thus defining+   log x = if x==1 then 0 else error "logarithm undefined for that argument"+seems to be unnecessary in general,+but makes sense for further usage in power series.++* Sample arguments++'zero' and 'one' are undefined for some types.+This indicates that the problem of implicit contextes is still not solved.+For some types, phantom types are perfectly ok for describing the context,+e.g. for positional numbers and fixed point numbers.+But they are inconvenient for residue classes and matrices.+One way out would be to provide a sample parameter,+that is, turn the functions into+  zero :: a -> a+  one  :: a -> a+and construct zeros and ones that are compliant to the sample parameter.+However, this way we propose the "sample element" approach+as the general way to go.+But the problem applies really only to some types.+++* Affine spaces:+ http://comments.gmane.org/gmane.comp.lang.haskell.libraries/3407+  (Ashley Yakeley: RFC: Time Library 0.1)+ http://www.haskell.org/pipermail/libraries/2005-May/003865.html+  (Ashley Yakeley: Difference Argument Order)+ http://math.ucr.edu/home/baez/torsors.html+  (Is "torsor" closer to what we want to describe?)+++* Vector type constructors:++Currently we model vector spaces with a multi-parameter type class.+It has the advantage, that it can be used very flexible for existing types.+E.g. any nesting of tuples types is automatically a vector type+if the tuple type is a VectorSpace instance.+But it has several disadvantages:+ - Type inference works badly.+   If in a chain of vector operations,+   there is some undetermined type,+   the type checker will confront you type error messages+   containing type variables that you never wrote down somewhere.+ - It is not possible to make a complex number+   a scalar type with respect to some vector type,+   because Complex is a composed type.+ - You have to declare Module instances for all atomic types,+   which essentially copy the Ring instances.+   You may find it useful to implement certain functions+   both for Modules and for Scalars.+   E.g. the polynomial evaluation is sensible and useful+   for vector valued coefficients (e.g. Matrix series),+   but more often polynomials with scalar coefficients are needed.+     hornerScalar :: Ring a          => [a] -> a -> a+     hornerVector :: VectorSpace a v => [v] -> a -> v+   You might try to unify both versions by making+   (VectorSpace a a) a requirement of (Ring a).+   However as said above, Complex can't be made an instance of VectorSpace+   (more precisely VectorSpace (Complex a) (Complex a) is not possible.)+   I also hesitate to let the single parameter type class Ring+   depend on the multi-parameter type class VectorSpace.++There is a way out: A Vector type constructor class.++class Vector v where+   scale :: Additive.C a => a -> v a -> v a+++In contrast to multi-parameter VectorSpace,+we cannot force that 'v a' is also a method of Additive.++We cannot restrict the vector element types by a class constraint,+but the routines acting on Vector containers can have these restrictions.+That is, the List type constructor is generally a Vector constructor,+although the particular String type is not a vector.+Since the multi-parameter approach sometimes requires+two versions of a function, the type constructor approach is not worse.+     hornerScalar :: Ring a             => [a]   -> a -> a+     hornerVector :: (Ring a, Vector v) => [v a] -> a -> v a+++Advantages:+ - scale :: (Complex Double) -> [Complex Double] -> [Complex Double]+     is possible+ - type inference works well+Disadvantanges:+ - The same type cannot be both scalar and vector.+   In order to achieve this,+   one part has to be turned into a singleton vector.+   Is this really a disadvantage or just a kind of more type safety?+ - The methods from Additive ((+), zero)+   must be added to the Vector class.+   A vectorial function cannot assert by its signature+   that the particular vector type is Additive.+ - The vector methods must live with the constraints on the scalar type+   as given in the Vector class declaration.+   Say, e.g. a Vector implementation based on Data.Map+   may want to remove zero elements.+   This requires a test against zero, that is a Eq or ZeroTestable instance.+   You cannot add these constraints.++Interestingly, this is the approach, I started on, in the end of 2004-03.++++* Complex numbers++The module looks horrible because auxiliary type classes are introduced+in order to allow optimized version for floating point numbers.+Should we better split the module into an algebraic Complex type+and a floating point Complex type?+++* ToDo:++   - check licences+   - ZeroTestable.isZero -> Zero.query+   - Units.isUnit        -> Unit.query+   - TeX output class (configuration of operator precedences)++* ToDo: Classes++   - Hilbert space (scalar product)+   - Affine space++* ToDo: Types++   - 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))+   - Hypercomplex numbers: Octonions+   - matrices, vectors+      - conversion of complex and quaternions to real matrices+   - peano numbers, cardinals+   - continued fractions and approximations of fractions+   - Vector type constructor class,+     with Singleton, Pair, Triple, Quadruple, (->), [] as instances+++++Henning's notes:+  (mod a 0)   should be undefined,+     because the remainder should satisfy+     (y >=0  ==>  0 <= mod x y && mod x y < y)+  splitFraction replaces properFraction+     It does now round towards minus infinity,+     I can't remember that I needed the behavior of Prelude.properFraction,+     namely rounding towards zero, in the past, at all.+     I would even vote for removing 'quot' and 'rem'+     because people tend to use them in many cases where 'div' and 'mod'+     are the better choice.+  A remainder class type like the one modulo (2*pi)+     would solve ambiguities in inverse trigonometric functions,+     problem: complex trigonometric and exponential function.+     Alternatively 'log' could return a list of possible solutions.+  Powers are still problematic.+     There should be several types of powers,+     each of which should be unique or choose some natural result.+     Powers of two complex number are rarely needed+     and often lead to unexpected results, e.g. discontinuous functions.+     (E.g. the Cauchy wavelet.)+     Interesting types of powers and suggested power notation:+        anything ^ cardinal+        fractional ^- integer+        algebraic ^/ rational (list of powers)+        positive real (transcendent) ^? anything (via exponential series)+  In my opinion it's important to put not too much meanings in one symbol,+     e.g. (*) can already be redefined in quite exotic ways,+     but the equal type of the operands should be the minimum.+     So I find it good to have a different operator (*>)+     for the multiplication of scalar and vector,+     and very similar an add operation+     for durations and absolute times (say  Minutes 12 +> Time 12 04 53) or+     temperature differences and absolute temperatures (Kelvin 10 +> DegreeCelcius 43) or+     tone intervals and absolute pitches (say  3 +> Pitch C 1)+  Haskell should distinguish between numeric machine constants (say 2#)+     and polymorphic constants (say 2 = fromMachineInt 2#),+     this would avoid cycles+  Module is named Algebra.Module+     since there might be many people+     who want to define some type named Module.+  the prop_* routines in NumExtras could be rewritten as simplification rules for GHC,+     though they should be disabled by default,+     because the rules doesn't always apply+     due to overflows and rounding.+  How can one handle errors in a computation?+     say, vectors mismatch,+      there is an overflow,+      a sum of two physical values with different units fails+       (I have already implemented modules for dealing with units) etc.+     Making the operations undefined for these cases+     is ok if the programmer has control over the operands.+     But if the values are given by the user+     the programmer might want to obtain something+     from which he can build a user friendly error message,+     say, "the values 1m and 2s can't be added:+     expression 1m+2s, sub-expression of ..."+  Examples for implicit configuration+     residue classes: modulus+     matrix computation: matrix size+     positional numbers: base+     fixed point numbers: position of the dot+++++
+ docs/README view
@@ -0,0 +1,72 @@+You can use (real!) real numbers (ok, computables only),+fixed point numbers with arbitrary precision,+power series, physical units, residue classes immediately with GHCi.+Just download the NumericPrelude package from++  http://hackage.haskell.org/cgi-bin/hackage-scripts/package/numeric-prelude++or get the cutting edge version (caution: frequent API changes!)++  wget -r --no-parent http://darcs.haskell.org/numericprelude/++or even better with 'darcs' (see http://darcs.net/) if available++  darcs get http://darcs.haskell.org/numericprelude/++then start GHCi as follows.+++numericprelude$ make ghci+...+*Main> showReal (logBase 2 3 + pi + sqrt 2)+"6.14076871668404446871807105143701747152665568244453495460737698483964711254267460000070283458784688280+81425952192537Interrupted.++*Main> showFixedPoint (log 2 + sqrt 2 + pi)+"5.2489533965228335966815642289473775308423414091123091482723043397919425067180107530842856866661773283"+*Main> showFixedPoint (FixedPoint.lift0 (10^1000) Number.FixedPoint.piConst)+"3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116094330572703657595919530921861173819326117931051185480744623799627495673518857527248912279381830119491298336733624406566430860213949463952247371907021798609437027705392171762931767523846748184676694051320005681271452635608277857713427577896091736371787214684409012249534301465495853710507922796892589235420199561121290219608640344181598136297747713099605187072113499999983729780499510597317328160963185950244594553469083026425223082533446850352619311881710100031378387528865875332083814206171776691473035982534904287554687311595628638823537875937519577818577805321712268066130019278766111959092164201997"+*Main> showFixedPoint (sqrt $ log $ FixedPoint.fromIntegerBasis 10 1000 2)+"0.8325546111576977563531646448952010476305888522644407291668291172340794351973046371489980076416742886448482282410637851330108956418582929396049471528907228470171676350886723388423935936597108246765808570792700443622966196741818893190586581386252927024531072144299452636462660173046566333123423559517018232473131336553277397460554922101186525242623654599834751330464388563784517713133769314261857977824435543915784989600358362742619360874461618454558851154639567200399205141997756487547096515291667876389818410045279797332626020900120913715779072042123248766285273274106918375012034073383400019132961678929241754711455999383432933099386116049520197996591124299426029350053074823745166425774910775252128414873633138846561928632399126787643990250582692324765636262660441952182748966643014552842325814025874977948870859994990052332656663016056779182667586683292672622606377187398292031363768554806074838642380037406327808548247471555604075913559987467405262524094749104596792515303983594015683517043115422"++*Main> divMod (polynomial [1,3,3]) (polynomial [1,1::Rational])+(Polynomial.fromCoeffs [0 % 1,3 % 1],Polynomial.fromCoeffs [1 % 1])++*Main> 2*kilo*meter / mach :: SIDouble+6.024096385542169 s++*Main> sqrt (powerSeries [1,1::Double])+PowerSeries.fromCoeffs+[1.0,0.5,-0.125,6.25e-2,-3.90625e-2,2.734375e-2,-2.05078125e-2,1.611328125e-2,-1.3092041015625e-2,...++*Main> PowerSeries.sqrt (const 1) [1,1::Rational]+[1 % 1,1 % 2,-1 % 8,1 % 16,-5 % 128,7 % 256,-21 % 1024,33 % 2048,-429 % 32768,715 % 65536,-2431 % 262144,4199 % 524288,-29393 % 4194304,52003 % 8388608, ...++*Main> ResidueClass.concrete 7 (5*3/2) :: Integer+4+++*Main> polynomial [1,5,6] % polynomial [1,4,4::Rational]+Polynomial.fromCoeffs [1 % 2,3 % 2] % Polynomial.fromCoeffs [1 % 2,1 % 1]++-- (1 + 2 * sqrt 2) * (3 + 4 * sqrt 2) == (19 + 10 * sqrt 2)+*Main> ResidueClass.concrete (polynomial [-2,0,1::Rational]) (polyResidueClass [1,2] * polyResidueClass[3,4])+Polynomial.fromCoeffs [19 % 1,10 % 1]++++For given factorization of the denominator of a fraction,+you can compute the partial fraction decomposition and+you can do calculations in this representation.++*Main> let a = partialFraction [2,3,5] (1::Integer)+*Main> a+PartialFraction.fromFractionSum (-1) [(2,[1]),(3,[1]),(5,[1])]+*Main> a^2+PartialFraction.fromFractionSum (-1) [(2,[0,1]),(3,[0,1]),(5,[3,1])]+*Main> PartialFraction.toFraction (a^2) == 1/(2*3*5)^2+True++*Main> let x = polynomial [0,1::Rational]+*Main> partialFraction [x-4,x,x+4] ((x-2)*(x+2))+PartialFraction.fromFractionSum (Polynomial.fromCoeffs [0 % 1,0 % 1,0 % 1]) [(Polynomial.fromCoeffs [-4 %1,1 % 1],[Polynomial.fromCoeffs [3 % 8]]),(Polynomial.fromCoeffs [0 % 1,1 % 1],[Polynomial.fromCoeffs [1 % 4]]),(Polynomial.fromCoeffs [4 % 1,1 % 1],[Polynomial.fromCoeffs [3 % 8]])]
+ numeric-prelude.cabal view
@@ -0,0 +1,232 @@+Name:           numeric-prelude+Version:        0.0.2+License:        GPL+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/Mathematical_prelude_discussion+Package-URL:    http://darcs.haskell.org/numericprelude/+Category:       Math+Stability:      Experimental+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 cover 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.+  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 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     --> RealTranscental+  .+  * 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.T, and Lattice.+Tested-With:    GHC==6.4.1, GHC==6.8.2+Cabal-Version:  >=1.2+Build-Type:     Simple++Extra-Source-Files:+  Makefile+  docs/NOTES+  docs/README++Flag splitBase+  description: Choose the new smaller, split-up base package.++Library+  Build-Depends: parsec >= 1, HUnit >=1 && <2, QuickCheck >=1 && <2, non-negative >=0.0.1 && <0.1+  If flag(splitBase)+    Build-Depends: base >= 2, array, containers, random+  Else+    Build-Depends: base >= 1.0 && < 2++  GHC-Options:    -Wall+  Hs-source-dirs: src+  Exposed-modules:+    Algebra.Additive+    Algebra.Algebraic+    Algebra.Differential+    Algebra.DimensionTerm+    Algebra.DivisibleSpace+    Algebra.Field+    Algebra.Indexable+    Algebra.IntegralDomain+    Algebra.NonNegative+    Algebra.Lattice+    Algebra.Laws+    Algebra.Module+    Algebra.ModuleBasis+    Algebra.Monoid+    Algebra.NormedSpace.Euclidean+    Algebra.NormedSpace.Maximum+    Algebra.NormedSpace.Sum+    Algebra.OccasionallyScalar+    Algebra.PrincipalIdealDomain+    Algebra.Real+    Algebra.RealField+    Algebra.RealIntegral+    Algebra.RealTranscendental+    Algebra.RightModule+    Algebra.Ring+    Algebra.ToInteger+    Algebra.ToRational+    Algebra.Transcendental+    Algebra.Units+    Algebra.Vector+    Algebra.VectorSpace+    Algebra.ZeroTestable+    MathObj.Algebra+    MathObj.DiscreteMap+    MathObj.LaurentPolynomial+    MathObj.Matrix+    MathObj.PartialFraction+    MathObj.Permutation+    MathObj.Permutation.CycleList+    MathObj.Permutation.CycleList.Check+    MathObj.Permutation.Table+    MathObj.Polynomial+    MathObj.PowerSeries+    MathObj.PowerSeries.DifferentialEquation+    MathObj.PowerSeries.Example+    MathObj.PowerSeries.Mean+    MathObj.PowerSeries2+    MathObj.PowerSum+    MathObj.RootSet+    MyPrelude+    Number.Complex+    Number.DimensionTerm+    Number.DimensionTerm.SI+    Number.FixedPoint+    Number.FixedPoint.Check+    Number.NonNegative+    Number.PartiallyTranscendental+    Number.Peano+    Number.Positional+    Number.Positional.Check+    Number.Quaternion+    Number.Ratio+    Number.ResidueClass+    Number.ResidueClass.Check+    Number.ResidueClass.Maybe+    Number.ResidueClass.Func+    Number.ResidueClass.Reader+    Number.OccasionallyScalarExpression+    Number.SI.Unit+    Number.SI+    Number.Physical.Unit+    Number.Physical.UnitDatabase+    Number.Physical+    Number.Physical.Read+    Number.Physical.Show+    NumericPrelude+    NumericPrelude.Condition+    NumericPrelude.List+    NumericPrelude.Monad+    NumericPrelude.Text+    PreludeBase++Executable test+  Hs-Source-Dirs: src, test+  Main-Is: Test.hs++Executable testsuite+  Hs-Source-Dirs: src, test+  GHC-Options:    -Wall+  Other-modules:+    Test.NumericPrelude.Utility+    Test.NumericPrelude.List+    Test.MathObj.PartialFraction+    Test.MathObj.Polynomial+    Test.MathObj.PowerSeries+  Main-Is: Test/Run.hs
+ src/Algebra/Additive.hs view
@@ -0,0 +1,160 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Additive (+    {- * Class -}+    C,+    zero,+    (+), (-),+    negate, subtract,++    {- * Complex functions -}+    sum, sum1,++    {- * Instances for atomic types -}+    propAssociative,+    propCommutative,+    propIdentity,+    propInverse,+  ) where++import qualified Algebra.Laws as Laws++import qualified Data.Ratio as Ratio98+import qualified Prelude as P+import Prelude(fromInteger)+import PreludeBase+++infixl 6  +, -++{- |+Additive a encapsulates the notion of a commutative group, specified+by the following laws:++@+          a + b === b + a+    (a + b) + c === a + (b + c)+       zero + a === a+   a + negate a === 0+@++Typical examples include integers, dollars, and vectors.++Minimal definition: '+', 'zero', and ('negate' or '(-)')+-}++class C a where+    -- | zero element of the vector space+    zero     :: a+    -- | add and subtract elements+    (+), (-) :: a -> a -> a+    -- | inverse with respect to '+'+    negate   :: a -> a++    negate a = zero - a+    a - b    = a + negate b++{- |+'subtract' is @(-)@ with swapped operand order.+This is the operand order which will be needed in most cases+of partial application.+-}+subtract :: C a => a -> a -> a+subtract = flip (-)+++++{- |+Sum up all elements of a list.+An empty list yields zero.+-}+sum :: (C a) => [a] -> a+sum = foldl (+) zero++{- |+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.+-}+sum1 :: (C a) => [a] -> a+sum1 = foldl1 (+)+++++{-* Instances for atomic types -}++instance C P.Integer where+    (+)    = (P.+)+    zero   = P.fromInteger 0+    negate = P.negate++instance C P.Int where+    (+)    = (P.+)+    zero   = P.fromInteger 0+    negate = P.negate++instance C P.Float where+    (+)    = (P.+)+    zero   = P.fromInteger 0+    negate = P.negate++instance C P.Double where+    (+)    = (P.+)+    zero   = P.fromInteger 0+    negate = P.negate+++{-* Instances for composed types -}++instance (C v0, C v1) => C (v0, v1) where+   zero                   = (zero, zero)+   (+)    (x0,x1) (y0,y1) = ((+) x0 y0, (+) x1 y1)+   (-)    (x0,x1) (y0,y1) = ((-) x0 y0, (-) x1 y1)+   negate (x0,x1)         = (negate x0, negate x1)++instance (C v0, C v1, C v2) => C (v0, v1, v2) where+   zero                         = (zero, zero, zero)+   (+)    (x0,x1,x2) (y0,y1,y2) = ((+) x0 y0, (+) x1 y1, (+) x2 y2)+   (-)    (x0,x1,x2) (y0,y1,y2) = ((-) x0 y0, (-) x1 y1, (-) x2 y2)+   negate (x0,x1,x2)            = (negate x0, negate x1, negate x2)+++instance (C v) => C [v] where+   zero   = []+   negate = map negate+   (+) (x:xs) (y:ys) = (+) x y : (+) xs ys+   (+) xs     []     = xs+   (+) []     ys     = ys+   (-) (x:xs) (y:ys) = (-) x y : (-) xs ys+   (-) xs     []     = xs+   (-) []     ys     = negate ys+++instance (C v) => C (b -> v) where+   zero       _ = zero+   (+)    f g x = (+) (f x) (g x)+   (-)    f g x = (-) (f x) (g x)+   negate f   x = negate (f x)++{- * Properties -}++propAssociative :: (Eq a, C a) => a -> a -> a -> Bool+propCommutative :: (Eq a, C a) => a -> a -> Bool+propIdentity    :: (Eq a, C a) => a -> Bool+propInverse     :: (Eq a, C a) => a -> Bool++propCommutative  =  Laws.commutative (+)+propAssociative  =  Laws.associative (+)+propIdentity     =  Laws.identity (+) zero+propInverse      =  Laws.inverse (+) negate zero++++-- legacy++instance (P.Integral a) => C (Ratio98.Ratio a) where+   zero                =  0+   (+)                 =  (P.+)+   (-)                 =  (P.-)+   negate              =  P.negate
+ src/Algebra/Algebraic.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -fno-implicit-prelude #-}+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++import Number.Ratio (Rational, (%), numerator, denominator)+import Algebra.Field ((^-), recip, fromRational')+import Algebra.Ring ((*), (^), fromInteger)+import Algebra.Additive((+))++import PreludeBase+import qualified Prelude as P+++infixr 8  ^/++{- | Minimal implementation: 'root' or '(^\/)'. -}++class (Field.C a) => C a where+    sqrt :: a -> a+    sqrt = root 2+    -- sqrt x  =  x ** (1/2)++    root :: P.Integer -> a -> a+    root n x = x ^/ (1 % n)++    (^/) :: a -> Rational -> a+    x ^/ y = root (denominator y) (x ^- numerator y)++genericRoot :: (C a, ToInteger.C b) => b -> a -> a+genericRoot n = root (ToInteger.toInteger n)++power :: (C a, ToRational.C b) => b -> a -> a+power r = (^/ ToRational.toRational r)++instance C P.Float where+    sqrt     = P.sqrt+    root n x = x P.** recip (P.fromInteger n)+    x ^/ y   = x P.** fromRational' y++instance C P.Double where+    sqrt     = P.sqrt+    root n x = x P.** recip (P.fromInteger n)+    x ^/ y   = x P.** fromRational' y+++{- * Properties -}++-- propSqrtSqr :: (Eq a, C a, Units.C a) => a -> Bool+-- propSqrtSqr x = sqrt (x^2) == Units.stdAssociate x++propSqrSqrt :: (Eq a, C a) => a -> Bool+propSqrSqrt x = sqrt x ^ 2 == x++propPowerCascade      :: (Eq a, C a) => a -> Rational -> Rational -> Bool+propPowerProduct      :: (Eq a, C a) => a -> Rational -> Rational -> Bool+propPowerDistributive :: (Eq a, C a) => Rational -> a -> a -> Bool++propPowerCascade      x i j  =  Laws.rightCascade (*) (^/) x i j+propPowerProduct      x i j  =  Laws.homomorphism (x^/) (+) (*) i j+propPowerDistributive i x y  =  Laws.leftDistributive (^/) (*) i x y
+ src/Algebra/Differential.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Differential where++import qualified Algebra.Ring as Ring++-- import NumericPrelude+import qualified Prelude++{- |+'differentiate' is a general differentation operation+It must fulfill the Leibnitz condition++>   differentiate (x * y) == differentiate x * y + x * differentiate y++Unfortunately, this scheme cannot be easily extended to more than two variables,+e.g. "MathObj.PowerSeries2".+-}+class Ring.C a => C a where+   differentiate :: a -> a
+ src/Algebra/DimensionTerm.hs view
@@ -0,0 +1,204 @@+{- |+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,+which require multi-parameter type classes with functional dependencies.++Here we provide a poor man's approach:+The units are presented by type terms.+There is no canonical form and thus the type checker+can not automatically check for equal units.+However, if two unit terms represent the same unit,+then you can tell the type checker to rewrite one into the other.++You can add more dimensions by introducing more types of class 'C'.++This approach is not entirely safe+because you can write your own flawed rewrite rules.+It is however more safe than with no units at all.+-}++module Algebra.DimensionTerm where++import Prelude hiding (recip)+++{- Haddock does not like 'where' clauses before empty declarations -}+class Show a => C a -- where+++noValue :: C a => a+noValue =+   let x = error ("there is no value of type " ++ show x)+   in  x++{- * Type constructors -}++data Scalar  = Scalar+data Mul a b = Mul+data Recip a = Recip+type Sqr   a = Mul a a++appPrec :: Int+appPrec = 10++instance Show Scalar where+   show _ = "scalar"++instance (Show a, Show b) => Show (Mul a b) where+   showsPrec p x =+      let disect :: Mul a b -> (a,b)+          disect _ = undefined+          (y,z) = disect x+      in  showParen (p >= appPrec)+            (showString "mul " . showsPrec appPrec y .+             showString " " . showsPrec appPrec z)++instance (Show a) => Show (Recip a) where+   showsPrec p x =+      let disect :: Recip a -> a+          disect _ = undefined+      in  showParen (p >= appPrec)+            (showString "recip " . showsPrec appPrec (disect x))+++instance C Scalar -- where++instance (C a, C b) => C (Mul a b) -- where++instance (C a) => C (Recip a) -- where+++scalar :: Scalar+scalar = noValue++mul :: (C a, C b) => a -> b -> Mul a b+mul _ _ = noValue++recip :: (C a) => a -> Recip a+recip _ = noValue+++infixl 7 %*%+infixl 7 %/%++(%*%) :: (C a, C b) => a -> b -> Mul a b+(%*%) = mul++(%/%) :: (C a, C b) => a -> b -> Mul a (Recip b)+(%/%) x y = mul x (recip y)+++{- * Rewrites -}++applyLeftMul :: (C u0, C u1, C v) => (u0 -> u1) -> Mul u0 v -> Mul u1 v+applyLeftMul _ _ = noValue+applyRightMul :: (C u0, C u1, C v) => (u0 -> u1) -> Mul v u0 -> Mul v u1+applyRightMul _ _ = noValue+applyRecip :: (C u0, C u1) => (u0 -> u1) -> Recip u0 -> Recip u1+applyRecip _ _ = noValue++commute :: (C u0, C u1) => Mul u0 u1 -> Mul u1 u0+commute _ = noValue+associateLeft :: (C u0, C u1, C u2) => Mul u0 (Mul u1 u2) -> Mul (Mul u0 u1) u2+associateLeft _ = noValue+associateRight :: (C u0, C u1, C u2) => Mul (Mul u0 u1) u2 -> Mul u0 (Mul u1 u2)+associateRight _ = noValue+recipMul :: (C u0, C u1) => Recip (Mul u0 u1) -> Mul (Recip u0) (Recip u1)+recipMul _ = noValue+mulRecip :: (C u0, C u1) => Mul (Recip u0) (Recip u1) -> Recip (Mul u0 u1)+mulRecip _ = noValue++identityLeft :: C u => Mul Scalar u -> u+identityLeft _ = noValue+identityRight :: C u => Mul u Scalar -> u+identityRight _ = noValue+cancelLeft :: C u => Mul (Recip u) u -> Scalar+cancelLeft _ = noValue+cancelRight :: C u => Mul u (Recip u) -> Scalar+cancelRight _ = noValue+invertRecip :: C u => Recip (Recip u) -> u+invertRecip _ = noValue+recipScalar :: Recip Scalar -> Scalar+recipScalar _ = noValue+++{- * Example dimensions -}++{- ** Basis dimensions -}++data Length      = Length+data Time        = Time+data Mass        = Mass+data Charge      = Charge+data Angle       = Angle+data Temperature = Temperature+data Information = Information++length :: Length+length = noValue++time :: Time+time = noValue++mass :: Mass+mass = noValue++charge :: Charge+charge = noValue++angle :: Angle+angle = noValue++temperature :: Temperature+temperature = noValue++information :: Information+information = noValue+++instance Show Length      where show _ = "length"+instance Show Time        where show _ = "time"+instance Show Mass        where show _ = "mass"+instance Show Charge      where show _ = "charge"+instance Show Angle       where show _ = "angle"+instance Show Temperature where show _ = "temperature"+instance Show Information where show _ = "information"++instance C Length      -- where+instance C Time        -- where+instance C Mass        -- where+instance C Charge      -- where+instance C Angle       -- where+instance C Temperature -- where+instance C Information -- where++{- ** Derived dimensions -}++type Frequency = Recip Time++data Voltage = Voltage++type VoltageAnalytical =+        Mul (Mul (Sqr Length) Mass) (Recip (Mul (Sqr Time) Charge))++voltage :: Voltage+voltage = noValue++instance Show Voltage where show _ = "voltage"++instance C Voltage -- where++unpackVoltage :: Voltage -> VoltageAnalytical+unpackVoltage _ = noValue++packVoltage :: VoltageAnalytical -> Voltage+packVoltage _ = noValue
+ src/Algebra/DivisibleSpace.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+module Algebra.DivisibleSpace where+import qualified Prelude+import qualified Algebra.VectorSpace as VectorSpace++-- Is this right?+infix 7 </>++{-|+DivisibleSpace is used for free one-dimensional vector spaces.  It+satisfies++>  (a </> b) *> b = a++Examples include dollars and kilometers.+-}+class (VectorSpace.C a b) => C a b where+    (</>) :: b -> b -> a+
+ src/Algebra/Field.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Field (+    {- * Class -}+    C,++    (/),+    recip,+    fromRational',+    fromRational,+    (^-),++    {- * Properties -}+    propDivision,+    propReciprocal,+  ) where++import Number.Ratio (T((:%)), Rational, (%), numerator, denominator, )+import qualified Number.Ratio as Ratio+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 NumericPrelude.List(reduceRepeated)++import PreludeBase+import Prelude (Integer, Float, Double)+import qualified Prelude as P+import Test.QuickCheck ((==>), Property)+++infixr 8 ^-+infixl 7 /+++{- |+Field again corresponds to a commutative ring.+Division is partially defined and satisfies++>    not (isZero b)  ==>  (a * b) / b === a+>    not (isZero a)  ==>  a * recip a === one++when it is defined. +To safely call division,+the program must take type-specific action;+e.g., the following is appropriate in many cases:++> safeRecip :: (Integral a, Eq a, Field.C a) => a -> Maybe a+> safeRecip x =+>     let (q,r) = one `divMod` x+>     in  toMaybe (isZero r) q++Typical examples include rationals, the real numbers,+and rational functions (ratios of polynomial functions).+An instance should be typically declared+only if most elements are invertible.++Actually, we have also used this type class for non-fields+containing lots of units,+e.g. residue classes with respect to non-primes and power series.+So the restriction @not (isZero a)@ must be better @isUnit a@.++Minimal definition: 'recip' or ('/')+-}++class (Ring.C a) => C a where+    (/)           :: a -> a -> a+    recip         :: a -> a+    fromRational' :: Rational -> a+    (^-)          :: a -> Integer -> a++    recip a = one / a+    a / b = a * recip b+    fromRational' r = fromInteger (numerator r) / fromInteger (denominator r)+    a ^- n = if n < zero+               then recip (a^(-n))+               else a^n+ -- a ^ n | n < 0 = reduceRepeated (^) one (recip a) (negate (toInteger n))+ --       | True  = reduceRepeated (^) one a (toInteger n)++++-- | Needed to work around shortcomings in GHC.++fromRational :: (C a) => P.Rational -> a+fromRational x = fromRational' (Ratio98.numerator x :% Ratio98.denominator x)+++{- * 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.+-}++instance C Float where+    (/)    = (P./)+    recip  = (P.recip)++instance C Double where+    (/)    = (P./)+    recip  = (P.recip)++instance (PID.C a) => C (Ratio.T a) where+--    (/)                  =  Ratio.liftOrd (%)+    (x:%y) / (x':%y')    =  (x*y') % (y*x')+    recip (x:%y)         =  (y:%x)+    fromRational' (x:%y) =  fromInteger x % fromInteger y+++-- | the restriction on the divisor should be @isUnit a@ instead of @not (isZero a)@+propDivision   :: (Eq a, ZeroTestable.C a, C a) => a -> a -> Property+propReciprocal :: (Eq a, ZeroTestable.C a, C a) => a -> Property++propDivision   a b   =   not (isZero b)  ==>  (a * b) / b == a+propReciprocal a     =   not (isZero a)  ==>  a * recip a == one++++-- legacy++instance (P.Integral a) => C (Ratio98.Ratio a) where+   (/)                 =  (P./)
+ src/Algebra/Indexable.hs view
@@ -0,0 +1,76 @@+{- |+Copyright    :   (c) Henning Thielemann 2007+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :   portable++An alternative type class for Ord+which allows an ordering for dictionaries like "Data.Map" and "Data.Set"+independently from the ordering with respect to a magnitude.+-}++module Algebra.Indexable (+    C(compare),+    ordCompare,+    liftCompare,+    ToOrd,+    toOrd,+    fromOrd,+    ) where++import Prelude hiding (compare)++import qualified Prelude as P+++{- |+Definition of an alternative ordering of objects+independent from a notion of magnitude.+For an application see "MathObj.PartialFraction".+-}+class Eq a => C a where+   compare :: a -> a -> Ordering++{- |+If the type has already an 'Ord' instance+it is certainly the most easiest to define 'Algebra.Indexable.compare'+to be equal to @Ord@'s 'compare'.+-}+ordCompare :: Ord a => a -> a -> Ordering+ordCompare = P.compare++{- |+Lift 'compare' implementation from a wrapped object.+-}+liftCompare :: C b => (a -> b) -> a -> a -> Ordering+liftCompare f x y = compare (f x) (f y)+++instance (C a, C b) => C (a,b) where+   compare (x0,x1) (y0,y1) =+      let res = compare x0 y0+      in  case res of+             EQ -> compare x1 y1+             _  -> res++instance C a => C [a] where+   compare [] [] = EQ+   compare [] _  = LT+   compare _  [] = GT+   compare (x:xs) (y:ys) = compare (x,xs) (y,ys)++instance C Integer where+   compare = ordCompare+++{- |+Wrap an indexable object such that it can be used in "Data.Map" and "Data.Set".+-}+newtype ToOrd a = ToOrd {fromOrd :: a} deriving (Eq, Show)++toOrd :: a -> ToOrd a+toOrd = ToOrd+++instance C a => Ord (ToOrd a) where+   compare (ToOrd x) (ToOrd y) = compare x y
+ src/Algebra/IntegralDomain.hs view
@@ -0,0 +1,203 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.IntegralDomain (+    {- * Class -}+    C,+    div, mod, divMod,++    {- * Derived functions -}+    divModZero,+    divides,+    sameResidueClass,+    safeDiv,+    even,+    odd,++    {- * Algorithms -}+    decomposeVarPositional,+    decomposeVarPositionalInf,++    {- * Properties -}+    propInverse,+    propMultipleDiv,+    propMultipleMod,+    propProjectAddition,+    propProjectMultiplication,+    propUniqueRepresentative,+    propZeroRepresentative,+    propSameResidueClass,+  ) 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 NumericPrelude.Condition(implies)+import Data.List(mapAccumL)++import Test.QuickCheck ((==>), Property)++import PreludeBase+import Prelude (Integer, Int)+import qualified Prelude as P++++infixl 7 `div`, `mod`+++{-+Shall we require+                   @ a `mod` 0 === a @   (divModZero)+or+                   @ a `mod` 0 === undefined @+?+-}+++{- |+@IntegralDomain@ corresponds to a commutative ring,+where @a `mod` b@ picks a canonical element+of the equivalence class of @a@ in the ideal generated by @b@.+'div' and 'mod' satisfy the laws++>                         a * b === b * a+> (a `div` b) * b + (a `mod` b) === a+>               (a+k*b) `mod` b === a `mod` b+>                     0 `mod` b === 0++Typical examples of @IntegralDomain@ include integers and+polynomials over a field.+Note that for a field, there is a canonical instance+defined by the above rules; e.g.,++> instance IntegralDomain.C Rational where+>     divMod a b =+>        if isZero b+>          then (undefined,a)+>          else (a\/b,0)++It shall be noted, that 'div', 'mod', 'divMod' have a parameter order+which is unfortunate for partial application.+But it is adapted to mathematical conventions,+where the operators are used in infix notation.++Minimal definition: 'divMod' or ('div' and 'mod')+-}+class (Ring.C a) => C a where+    div, mod :: a -> a -> a+    divMod :: a -> a -> (a,a)++    div a b = fst (divMod a b)+    mod a b = snd (divMod a b)+    divMod a b = (div a b, mod a b)+++divides :: (C a, ZeroTestable.C a) => a -> a -> Bool+divides y x  =  isZero (mod x y)++sameResidueClass :: (C a, ZeroTestable.C a) => a -> a -> a -> Bool+sameResidueClass m x y = divides m (x-y)++++{- |+@decomposeVarPositional [b0,b1,b2,...] x@+decomposes @x@ into a positional representation with mixed bases+@x0 + b0*(x1 + b1*(x2 + b2*x3))@+E.g. @decomposeVarPositional (repeat 10) 123 == [3,2,1]@+-}+decomposeVarPositional :: (C a, ZeroTestable.C a) => [a] -> a -> [a]+decomposeVarPositional bs x =+   map fst $+   takeWhile (not . isZero . snd) $+   decomposeVarPositionalInfAux bs x++decomposeVarPositionalInf :: (C a) => [a] -> a -> [a]+decomposeVarPositionalInf bs =+   map fst . decomposeVarPositionalInfAux bs++decomposeVarPositionalInfAux :: (C a) => [a] -> a -> [(a,a)]+decomposeVarPositionalInfAux bs x =+   let (endN,digits) =+          mapAccumL+             (\n b -> let (q,r) = divMod n b in (q,(r,n)))+             x bs+   in  digits ++ [(endN,endN)]++++{- |+Returns the result of the division, if divisible.+Otherwise undefined.+-}+safeDiv :: (ZeroTestable.C a, C a) => a -> a -> a+safeDiv a b =+   let (q,r) = divMod a b+   in  if isZero r+         then q+         else error "safeDiv: indivisible term"++{- |+Allows division by zero.+If the divisor is zero, then the divident is returned as remainder.+-}+divModZero :: (C a, ZeroTestable.C a) => a -> a -> (a,a)+divModZero x y =+   if isZero y+     then (zero,x)+     else divMod x y++++even, odd :: (C a, ZeroTestable.C a) => a -> Bool+even n    =  divides 2 n+odd       =  not . even+++{- * Instances for atomic types -}++instance C Integer where+    divMod = P.divMod++instance C Int where+    divMod = P.divMod+++++-- Ring.propCommutative and ...+propInverse               :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property+propMultipleDiv           :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property+propMultipleMod           :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property+propProjectAddition       :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property+propProjectMultiplication :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property+propSameResidueClass      :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property+propUniqueRepresentative  :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property+propZeroRepresentative    :: (Eq a, C a, ZeroTestable.C a) => a -> Property+++propInverse     m a =+   not (isZero m) ==> (a `div` m) * m + (a `mod` m)  ==  a+propMultipleDiv m a =+   not (isZero m) ==>                 (a*m) `div` m  ==  a+propMultipleMod m a =+   not (isZero m) ==>                 (a*m) `mod` m  ==  0+propProjectAddition m a b =+   not (isZero m) ==>+      (a+b) `mod` m  ==  ((a`mod`m)+(b`mod`m)) `mod` m+propProjectMultiplication m a b =+   not (isZero m) ==>+      (a*b) `mod` m  ==  ((a`mod`m)*(b`mod`m)) `mod` m+propUniqueRepresentative m k a =+   not (isZero m) ==>+      (a+k*m) `mod` m  ==  a `mod` m+propZeroRepresentative m =+   not (isZero m) ==>+      zero `mod` m  ==  zero+propSameResidueClass m a b =+   not (isZero m) ==>+      a `mod` m == b `mod` m   `implies`   sameResidueClass m a b
+ src/Algebra/Lattice.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Lattice (+      C(up, dn)+    , max, min, abs+    , propUpCommutative, propDnCommutative+    , propUpAssociative, propDnAssociative+    , propUpDnDistributive, propDnUpDistributive+) where++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Additive as Additive+import qualified Number.Ratio     as Ratio++import qualified Algebra.Laws as Laws++import NumericPrelude hiding (abs)+import PreludeBase hiding (max, min)+import qualified Prelude as P++infixl 5 `up`, `dn`++class C a where+    up, dn :: a -> a -> a+++{- * Properties -}++propUpCommutative, propDnCommutative ::+ (Eq a, C a) => a -> a -> Bool+propUpCommutative  =  Laws.commutative up+propDnCommutative  =  Laws.commutative dn++propUpAssociative, propDnAssociative ::+ (Eq a, C a) => a -> a -> a -> Bool+propUpAssociative  =  Laws.associative up+propDnAssociative  =  Laws.associative dn++propUpDnDistributive, propDnUpDistributive ::+ (Eq a, C a) => a -> a -> a -> Bool+propUpDnDistributive  =  Laws.leftDistributive up dn+propDnUpDistributive  =  Laws.leftDistributive dn up+++++-- With  @up == gcd@  and  @dn == lcm@  we have also a lattice.+instance C Integer where+    up = P.max+    dn = P.min++instance (Ord a, PID.C a) => C (Ratio.T a) where+    up = P.max+    dn = P.min++instance C Bool where+    up = (P.||)+    dn = (P.&&)++instance (C a, C b) => C (a,b) where+    (x1,y1)`up`(x2,y2) = (x1`up`x2, y1`up`y2)+    (x1,y1)`dn`(x2,y2) = (x1`dn`x2, y1`dn`y2)+++max, min :: (C a) => a -> a -> a+max = up+min = dn++abs :: (C a, Additive.C a) => a -> a+abs x = x `up` negate x
+ src/Algebra/Laws.hs view
@@ -0,0 +1,57 @@+{- |+Define common properties that can be used e.g. for automated tests.+Cf. to "Test.QuickCheck.Utils".+-}+module Algebra.Laws where+++commutative :: Eq a => (b -> b -> a) -> b -> b -> Bool+commutative op x y  =  x `op` y == y `op` x++associative :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool+associative op x y z  =  (x `op` y) `op` z == x `op` (y `op` z)++leftIdentity :: Eq a => (b -> a -> a) -> b -> a -> Bool+leftIdentity op y x  =  y `op` x == x++rightIdentity :: Eq a => (a -> b -> a) -> b -> a -> Bool+rightIdentity op y x  =  x `op` y == x++identity :: Eq a => (a -> a -> a) -> a -> a -> Bool+identity op x y  =  leftIdentity op x y &&  rightIdentity op x y++leftZero :: Eq a => (a -> a -> a) -> a -> a -> Bool+leftZero  =  flip . rightIdentity++rightZero :: Eq a => (a -> a -> a) -> a -> a -> Bool+rightZero  =  flip . leftIdentity++zero :: Eq a => (a -> a -> a) -> a -> a -> Bool+zero op x y  =  leftZero op x y  &&  rightZero op x y++leftInverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool+leftInverse op inv y x  =  inv x `op` x == y++rightInverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool+rightInverse op inv y x  =  x `op` inv x == y++inverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool+inverse op inv y x  =  leftInverse op inv y x && rightInverse op inv y x++leftDistributive :: Eq a => (a -> b -> a) -> (a -> a -> a) -> b -> a -> a -> Bool+leftDistributive ( # ) op x y z  =  (y `op` z) # x == (y # x) `op` (z # x)++rightDistributive :: Eq a => (b -> a -> a) -> (a -> a -> a) -> b -> a -> a -> Bool+rightDistributive ( # ) op x y z  =  x # (y `op` z) == (x # y) `op` (x # z)++homomorphism :: Eq a =>+   (b -> a) -> (b -> b -> b) -> (a -> a -> a) -> b -> b -> Bool+homomorphism f op0 op1 x y  =  f (x `op0` y) == f x `op1` f y++rightCascade :: Eq a =>+   (b -> b -> b) -> (a -> b -> a) -> a -> b -> b -> Bool+rightCascade ( # ) op x i j  =  (x `op` i) `op` j == x `op` (i#j)++leftCascade :: Eq a =>+   (b -> b -> b) -> (b -> a -> a) -> a -> b -> b -> Bool+leftCascade ( # ) op x i j  =  j `op` (i `op` x) == (j#i) `op` x
+ src/Algebra/Module.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Dylan Thurston, Henning Thielemann 2004-2005++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Abstraction of modules+-}++module Algebra.Module where++import qualified Number.Ratio as Ratio++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive+import qualified Algebra.ToInteger as ToInteger++import qualified Algebra.Laws as Laws++import Algebra.Ring     ((*), fromInteger)+import Algebra.Additive ((+), zero)++import NumericPrelude.List (reduceRepeated)+import Data.List (map, zipWith, foldl)++import Prelude((.), Eq, Bool, Int, Integer, Float, Double)+-- import qualified Prelude as P+++-- Is this right?+infixr 7 *>++{- Functional dependency can't be used+   since the instance (Algebra.Module.C a a)+   would conflict with all others.+   class Algebra.Module.C b a | b -> a where -}++{-|+A Module over a ring satisfies:++>   a *> (b + c) === a *> b + a *> c+>   (a * b) *> c === a *> (b *> c)+>   (a + b) *> c === a *> c + b *> c+-}+class (Additive.C b, Ring.C a) => C a b where+    -- | scale a vector by a scalar+    (*>) :: a -> b -> b++{-* Instances for atomic types -}++instance C Float Float where+   (*>) = (*)++instance C Double Double where+   (*>) = (*)++instance C Int Int where+   (*>) = (*)++instance C Integer Integer where+   (*>) = (*)++instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where+   (*>) = (*)++instance (PID.C a) => C Integer (Ratio.T a) where+   x *> y = fromInteger x * y++++{-* Instances for composed types -}++instance (C a b0, C a b1) => C a (b0, b1) where+   s *> (x0,x1)   = (s *> x0, s *> x1)++instance (C a b0, C a b1, C a b2) => C a (b0, b1, b2) where+   s *> (x0,x1,x2) = (s *> x0, s *> x1, s *> x2)++instance (C a b) => C a [b] where+   (*>) = map . (*>)++instance (C a b) => C a (c -> b) where+   (*>) s f = (*>) s . f+++{-* Related functions -}++{-|+Compute the linear combination of a list of vectors.++ToDo:+Should it use 'NumericPrelude.List.zipWithMatch' ?+-}+linearComb :: C a b => [a] -> [b] -> b+linearComb c = foldl (+) zero . zipWith (*>) c++{-|+This function can be used to define any+'Additive.C' as a module over 'Integer'.++Better move to "Algebra.Additive"?+-}+integerMultiply :: (ToInteger.C a, Additive.C b) => a -> b -> b+integerMultiply a b =+   reduceRepeated (+) zero b (ToInteger.toInteger a)+++{- * Properties -}++propCascade :: (Eq b, C a b) => b -> a -> a -> Bool+propCascade  =  Laws.leftCascade (*) (*>)++propRightDistributive :: (Eq b, C a b) => a -> b -> b -> Bool+propRightDistributive  =  Laws.rightDistributive (*>) (+)++propLeftDistributive :: (Eq b, C a b) => b -> a -> a -> Bool+propLeftDistributive x  =  Laws.homomorphism (*>x) (+) (+)
+ src/Algebra/ModuleBasis.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Abstraction of bases of finite dimensional modules+-}++module Algebra.ModuleBasis where++import Number.Ratio (Rational)++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:++>   Module.linearComb (flatten v `asTypeOf` [a]) (basis a) == v+>   dimension a v == length (flatten v `asTypeOf` [a])+-}+class (Module.C a v) => C a v where+    {- | basis of the module with respect to the scalar type,+         the result must be independent of argument, 'Prelude.undefined' should suffice. -}+    basis :: a -> [v]+    -- | scale a vector by a scalar+    flatten :: v -> [a]+    {- | the size of the basis, should also work for undefined argument,+         the result must be independent of argument, 'Prelude.undefined' should suffice. -}+    dimension :: a -> v -> Int++{-* Instances for atomic types -}++instance C Float Float where+   basis _ = [one]+   flatten = (:[])+   dimension _ _ = 1++instance C Double Double where+   basis _ = [one]+   flatten = (:[])+   dimension _ _ = 1++instance C Int Int where+   basis _ = [one]+   flatten = (:[])+   dimension _ _ = 1++instance C Integer Integer where+   basis _ = [one]+   flatten = (:[])+   dimension _ _ = 1++instance C Rational Rational where+   basis _ = [one]+   flatten = (:[])+   dimension _ _ = 1++++{-* Instances for composed types -}++instance (C a v0, C a v1) => C a (v0, v1) where+   basis s = map (\v -> (v,zero)) (basis s) +++             map (\v -> (zero,v)) (basis s)+   flatten (x0,x1) = flatten x0 ++ flatten x1+   dimension s ~(x0,x1) = dimension s x0 + dimension s x1++instance (C a v0, C a v1, C a v2) => C a (v0, v1, v2) where+   basis s = map (\v -> (v,zero,zero)) (basis s) +++             map (\v -> (zero,v,zero)) (basis s) +++             map (\v -> (zero,zero,v)) (basis s)+   flatten (x0,x1,x2) = flatten x0 ++ flatten x1 ++ flatten x2+   dimension s ~(x0,x1,x2) = dimension s x0 + dimension s x1 + dimension s x2++++{- * Properties -}++propFlatten :: (Eq v, C a v) => a -> v -> Bool+propFlatten a v  =  Module.linearComb (flatten v `asTypeOf` [a]) (basis a) == v++propDimension :: (C a v) => a -> v -> Bool+propDimension a v  =  dimension a v == length (flatten v `asTypeOf` [a])
+ src/Algebra/Monoid.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Mikael Johansson 2006+Maintainer   :   mik@math.uni-jena.de+Stability    :   provisional+Portability  :++Abstract concept of a Monoid. Will be used in order to generate+type classes for generic algebras. An algebra is a vector space+that also is a monoid.+-}++module Algebra.Monoid where++{- | We expect a monoid to adher to associativity and the identity+behaving decently. Nothing more, really. -}++class C a where+  idt   :: a+  (<*>) :: a -> a -> a
+ src/Algebra/NonNegative.hs view
@@ -0,0 +1,37 @@+{- |+Copyright   :  (c) Henning Thielemann 2007++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.+This class cannot do any checks,+but it let you show to the user what arguments your function expects.+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++import qualified Algebra.Additive as Additive+++{- |+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.+-}+class (Ord a, Additive.C a) => C a where+   {- |+   @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.+   -}+   (-|) :: a -> a -> a+   x -| y  =  if x >= y then x Additive.- y else Additive.zero
+ src/Algebra/NormedSpace/Euclidean.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}++{- |+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 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.Module    as Module++{-|+A vector space equipped with an Euclidean or a Hilbert norm.++Minimal definition:+'normSqr'+-}+class (Real.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++class (Sqr a v) => C a v where+  {-| Euclidean norm of a vector. -}+  norm    :: v -> a+++defltNorm :: (Algebraic.C a, Sqr a v) => v -> a+defltNorm = Algebraic.sqrt . normSqr+++{-* Instances for atomic types -}++instance Sqr Float Float where+  normSqr = sqr++instance C Float Float where+  norm    = abs++instance Sqr Double Double where+  normSqr = sqr++instance C Double Double where+  norm    = abs++instance Sqr Int Int where+  normSqr = sqr++instance C Int Int where+  norm    = abs++instance Sqr Integer Integer where+  normSqr = sqr++instance C Integer Integer where+  norm    = abs+++{-* Instances for composed types -}++instance (Real.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+  normSqr (x0,x1) = normSqr x0 + normSqr x1++instance (Algebraic.C a, Sqr a v0, Sqr a v1) => C a (v0, v1) where+  norm    = defltNorm++instance (Sqr a v0, Sqr a v1, Sqr a v2) => Sqr a (v0, v1, v2) where+  normSqr (x0,x1,x2) = normSqr x0 + normSqr x1 + normSqr x2++instance (Algebraic.C a, Sqr a v0, Sqr a v1, Sqr a v2) => C a (v0, v1, v2) where+  norm    = defltNorm++instance (Sqr a v) => Sqr a [v] where+  normSqr = sum . map normSqr++instance (Algebraic.C a, Sqr a v) => C a [v] where+  norm    = defltNorm
+ src/Algebra/NormedSpace/Maximum.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}++{- |+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 qualified Number.Ratio as Ratio++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Real     as Real+import qualified Algebra.Module   as Module++class (Real.C a, Module.C a v) => C a v where+  norm :: v -> a++{-+instance (Ring.C a, Algebra.Module a a) => C a a where+  norm = abs+-}+instance C Float Float where+  norm = abs++instance C Double Double where+  norm = abs++instance C Int Int where+  norm = abs++instance C Integer Integer where+  norm = abs+++instance (Real.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+  norm (x0,x1) = max (norm x0) (norm x1)++instance (Ord a, C a v0, C a v1, C a v2) => C a (v0, v1, v2) where+  norm (x0,x1,x2) = (norm x0) `max` (norm x1) `max` (norm x2)++instance (Ord a, C a v) => C a [v] where+  norm = foldl max zero . map norm+--  norm = maximum . map norm
+ src/Algebra/NormedSpace/Sum.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}++{- |+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 qualified Number.Ratio as Ratio++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Real     as Real+import qualified Algebra.Additive as Additive+import qualified Algebra.Module   as Module++{-|+  The super class is only needed to state the laws+  @+     v == zero        ==   norm v == zero+     norm (scale x v) ==   abs x * norm v+     norm (u+v)       <=   norm u + norm v+  @+-}+class (Real.C a, Module.C a v) => C a v where+  norm :: v -> a++{-+instance (Ring.C a, Algebra.Module a a) => C a a where+  norm = abs+-}++instance C Float Float where+  norm = abs++instance C Double Double where+  norm = abs++instance C Int Int where+  norm = abs++instance C Integer Integer where+  norm = abs+++instance (Real.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+  norm (x0,x1) = norm x0 + norm x1++instance (Additive.C a, C a v0, C a v1, C a v2) => C a (v0, v1, v2) where+  norm (x0,x1,x2) = norm x0 + norm x1 + norm x2++instance (Additive.C a, C a v) => C a [v] where+  norm = sum . map norm
+ src/Algebra/OccasionallyScalar.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}++{- |++There are several types of numbers+where a subset of numbers can be considered as set of scalars.++ * A '(Complex.T Double)' value can be converted to 'Double' if the imaginary part is zero.++ * A value with physical units can be converted to a scalar if there is no unit. ++Of course this can be cascaded,+e.g. a complex number with physical units can be converted to a scalar+if there is both no imaginary part and no unit.++This is somewhat similar to the multi-type classes NormedMax.C and friends.++I hesitate to define an instance for lists+to avoid the mess known of MatLab.+But if you have an application where you think+you need this instance definitely+I'll think about that, again.++-}++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+++-- this is somehow similar to Normalized classes+class C a v where+   toScalar      :: v -> a+   toMaybeScalar :: v -> Maybe a+   fromScalar    :: a -> v++toScalarDefault :: (C a v) => v -> a+toScalarDefault v =+   fromMaybe (error ("The value is not scalar."))+             (toMaybeScalar v)++toScalarShow :: (C a v, Show v) => v -> a+toScalarShow v =+   fromMaybe (error (show v ++ " is not a scalar value."))+             (toMaybeScalar v)+++instance C Float Float where+   toScalar      = id+   toMaybeScalar = Just+   fromScalar    = id++instance C Double Double where+   toScalar      = id+   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)+      => C b a where+   toScalar        = toScalarDefault+   toMaybeScalar x = mapMaybe round (toMaybeScalar x)+-}
+ src/Algebra/PrincipalIdealDomain.hs view
@@ -0,0 +1,350 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.PrincipalIdealDomain (+    {- * Class -}+    C,+    extendedGCD,+    gcd,+    lcm,++    {- * Standard implementations for instances -}+    euclid,+    extendedEuclid,++    {- * Algorithms -}+    extendedGCDMulti,+    diophantine,+    diophantineMin,+    diophantineMulti,+    chineseRemainder,+    chineseRemainderMulti,++    {- * Properties -}+    propMaximalDivisor,+    propGCDDiophantine,+    propExtendedGCDMulti,+    propDiophantine,+    propDiophantineMin,+    propDiophantineMulti,+    propDiophantineMultiMin,+    propChineseRemainder,+    propDivisibleGCD,+    propDivisibleLCM,+    propGCDIdentity,+    propGCDCommutative,+    propGCDAssociative,+    propGCDHomogeneous,+    propGCD_LCM,+  ) where++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.Ring           (one, (*), scalarProduct)+import Algebra.Additive       (zero, (+), (-))+import Algebra.ZeroTestable   (isZero)++import NumericPrelude.Condition (toMaybe)++import Control.Monad (foldM, liftM)+import Data.List (mapAccumL, mapAccumR, unfoldr)++import PreludeBase+import Prelude (Integer, Int)+import qualified Prelude as P+import Test.QuickCheck ((==>), Property)++++{- |+A principal ideal domain is a ring in which every ideal+(the set of multiples of some generating set of elements)+is principal:+That is,+every element can be written as the multiple of some generating element.+@gcd a b@ gives a generator for the ideal generated by @a@ and @b@.+The algorithm above works whenever @mod x y@ is smaller+(in a suitable sense) than both @x@ and @y@;+otherwise the algorithm may run forever.++Laws:++>   divides x (lcm x y)+>   x `gcd` (y `gcd` z) == (x `gcd` y) `gcd` z+>   gcd x y * z == gcd (x*z) (y*z)+>   gcd x y * lcm x y == x * y++(etc: canonical)++Minimal definition:+ * nothing, if the standard Euclidean algorithm work+ * if 'extendedGCD' is implemented customly, 'gcd' and 'lcm' make use of it+-}+class (Units.C a, ZeroTestable.C a) => C a where+    {- |+    Compute the greatest common divisor and+    solve a respective Diophantine equation.++    >   (g,(a,b)) = extendedGCD x y ==>+    >        g==a*x+b*y   &&  g == gcd x y++    TODO: This method is not appropriate for the PID class,+          because there are rings like the one of the multivariate polynomials,+          where for all x and y greatest common divisors of x and y exist,+          but they cannot be represented as a linear combination of x and y.+    TODO: The definition of extendedGCD does not return the canonical associate.+    -}+    extendedGCD :: a -> a -> (a,(a,a))+    extendedGCD = extendedEuclid divMod++    {- |+    The Greatest Common Divisor is defined by:++    >   gcd x y == gcd y x+    >   divides z x && divides z y ==> divides z (gcd x y)   (specification)+    >   divides (gcd x y) x+    -}+    gcd         :: a -> a -> a+    gcd x y     = fst $ extendedGCD x y++    {- |+    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)++++{-+We could implement a helper function,+which exposes the temporary results.+This could be re-used for extendedEuclid.+-}+euclid :: (Units.C a, ZeroTestable.C a) =>+   (a -> a -> a) -> a -> a -> a+euclid genMod =+   let aux x y =+          if isZero y+            then stdAssociate x+            else aux y (x `genMod` y)+   in  aux++-- could be implemented in a tail-recursive manner+extendedEuclid :: (Units.C a, ZeroTestable.C a) =>+   (a -> a -> (a,a)) -> a -> a -> (a,(a,a))+extendedEuclid genDivMod =+   let aux x y =+          if isZero y+            then (stdAssociate x, (stdUnitInv x, zero))+            else+              let (d,m) = x `genDivMod` y   -- x == d*y + m+                  (g,(a,b)) = aux y m       -- g == a*y + b*m+              in  (g,(b,a-b*d))             -- g == a*y + b*(x-d*y)+   in aux+++{- |+Compute the greatest common divisor for multiple numbers+by repeated application of the two-operand-gcd.+-}+extendedGCDMulti :: C a => [a] -> (a,[a])+extendedGCDMulti xs =+   let (g,cs) = mapAccumL extendedGCD zero xs+   in  (g, snd $ mapAccumR (\acc (c0,c1) -> (acc*c0,acc*c1)) one cs)++{- |+A variant with small coefficients.+-}+++{- |+@Just (a,b) = diophantine z x y@+means+@a*x+b*y = z@.+It is required that @gcd(y,z) `divides` x@.+-}+diophantine :: C a => a -> a -> a -> Maybe (a,a)+diophantine z x y =+   fmap snd $ diophantineAux z x y++{- |+Like 'diophantine', but @a@ is minimal+with respect to the measure function of the Euclidean algorithm.+-}+diophantineMin :: C a => a -> a -> a -> Maybe (a,a)+diophantineMin z x y =+   fmap (uncurry (minimizeFirstOperand (x,y))) $+   diophantineAux z x y++minimizeFirstOperand :: C a => (a,a) -> a -> (a,a) -> (a,a)+minimizeFirstOperand (x,y) g (a,b) =+   if isZero g+     then (zero,zero)+     else+       let xl = safeDiv x g+           yl = safeDiv y g+           (d,aRed) = divModZero a yl+       in  (aRed, b + d*xl)++diophantineAux :: C a => a -> a -> a -> Maybe (a, (a,a))+diophantineAux z x y =+   let (g,(a,b)) = extendedGCD x y+       (q,r) = divModZero z g+   in  toMaybe (isZero r) (g, (q*a, q*b))+++{- |+-}+diophantineMulti :: C a => a -> [a] -> Maybe [a]+diophantineMulti z xs =+   let (g,as) = extendedGCDMulti xs+       (q,r)  = divModZero z g+   in  toMaybe (isZero r) (map (q*) as)++{- |+Not efficient because it requires duplicate computations of GCDs.+However GCDs of neighbouring list elements were not computed before.+It is also quite arbitrary,+because only neighbouring elements are used for balancing.+There are certainly more sophisticated solutions.+-}+diophantineMultiMin :: C a => a -> [a] -> Maybe [a]+diophantineMultiMin z xs =+   do as <- diophantineMulti z xs+      return $ unfoldr+         (\as' -> case as' of+           ((x0,a0):(x1,a1):aRest) ->+              let (b0,b1) = minimizeFirstOperand (x0,x1) (gcd x0 x1) (a0,a1)+              in  Just (b0, (x1,b1):aRest)+           (_,a):[] -> Just (a,[])+           [] -> Nothing) $+         zip xs as++{-+diophantineMultiMin :: C a => a -> [a] -> Maybe [a]+diophantineMultiMin z xs =+   do as <- diophantineMulti z xs+      return $+         case as of+           (c:cs'@(_:_)) ->+              let (cs,cLast) = splitLast cs'+                  (d,as') = mapAccumL (\a b -> swap $ minimizeFirstOperand (gcd a b) (a,b)) c cs+                  (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)+-}++{- |+Not efficient enough, because GCD\/LCM is computed twice.+-}+chineseRemainder :: C a => (a,a) -> (a,a) -> Maybe (a,a)+chineseRemainder (m0,a0) (m1,a1) =+   liftM (\(k,_) -> let m = lcm m0 m1 in (m, mod (a0-k*m0) m)) $+   diophantineMin (a0-a1) m0 m1+{-+a0-k*m0 == a1+l*m1+a0-a1 == k*m0+l*m1+-}++{- |+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@+are fulfilled.+-}+chineseRemainderMulti :: C a => [(a,a)] -> Maybe (a,a)+chineseRemainderMulti congs =+   case congs of+      [] -> Nothing+      (c:cs) -> foldM chineseRemainder c cs++++{- * Instances for atomic types -}+++{-+There exists a GCD variant,+that is specialised for integers and does not need a division.+However, since we have an optimized division,+the standard implementation is probably faster.++TODO: Can Integer make use of the GMP GCD routine?+-}++instance C Integer where+    -- possibly more efficient than the default method+    gcd = euclid mod++instance C Int where+    gcd = euclid mod+++propGCDIdentity     :: (Eq a, C a) => a -> Bool+propGCDAssociative :: (Eq a, C a) => a -> a -> a -> Bool+propGCDCommutative :: (Eq a, C a) => a -> a -> Bool+propGCDDiophantine :: (Eq a, C a) => a -> a -> Bool+propExtendedGCDMulti :: (Eq a, C a) => [a] -> Bool+propDiophantineGen :: (Eq a, C a) =>+   (a -> a -> a -> Maybe (a,a)) -> a -> a -> a -> a -> Bool+propDiophantine    :: (Eq a, C a) => a -> a -> a -> a -> Bool+propDiophantineMin :: (Eq a, C a) => a -> a -> a -> a -> Bool+propDiophantineMultiGen :: (Eq a, C a) =>+   (a -> [a] -> Maybe [a]) -> [(a,a)] -> Bool+propDiophantineMulti    :: (Eq a, C a) => [(a,a)] -> Bool+propDiophantineMultiMin :: (Eq a, C a) => [(a,a)] -> Bool+propDivisibleGCD   :: C a => a -> a -> Bool+propDivisibleLCM   :: C a => a -> a -> Bool+propGCD_LCM        :: (Eq a, C a) => a -> a -> Bool+propGCDHomogeneous :: (Eq a, C a) => a -> a -> a -> Bool+propMaximalDivisor :: C a => a -> a -> a -> Property+propChineseRemainder :: (Eq a, C a) => a -> a -> [a] -> Property++propMaximalDivisor x y z =+   divides z x && divides z y ==> divides z (gcd x y)+propGCDDiophantine x y =+   let (g,(a,b)) = extendedGCD x y+   in  g == gcd x y  &&  g == a*x+b*y+propExtendedGCDMulti xs =+   let (g,as) = extendedGCDMulti xs+   in  g == scalarProduct as xs  &&+       (isZero g || all (divides g) xs)+propDiophantineGen dio a b x y =+   let z = a*x+b*y+   in  maybe False (\(a',b') -> z == a'*x+b'*y) (dio z x y)+propDiophantine    = propDiophantineGen diophantine+propDiophantineMin = propDiophantineGen diophantineMin+propDiophantineMultiGen dio axs =+   let (as,xs) = unzip axs+       z = scalarProduct as xs+   in  maybe False (\as' -> z == scalarProduct as' xs) (dio z xs)+propDiophantineMulti    = propDiophantineMultiGen diophantineMulti+propDiophantineMultiMin = propDiophantineMultiGen diophantineMultiMin+propDivisibleGCD x y  =  divides (gcd x y) x+propDivisibleLCM x y  =  divides x (lcm x y)++propGCDIdentity     =  Laws.identity gcd zero . stdAssociate+propGCDCommutative  =  Laws.commutative gcd+propGCDAssociative  =  Laws.associative gcd+propGCDHomogeneous  =  Laws.leftDistributive (*) gcd . stdAssociate+propGCD_LCM x y     =  gcd x y * lcm x y == x * y+propChineseRemainder k x ms =+   not (null ms) && all (not . isZero) ms ==>+   -- cf. Useful.functionToGraph+   let congs = zip ms (map (mod x) ms)+   in  maybe False+          (\(mGlob,y) ->+             let yk = y+mGlob*k+             in  all (\(m,a) -> Integral.sameResidueClass m a yk) congs)+          (chineseRemainderMulti congs)
+ src/Algebra/Real.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 PreludeBase+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+instance C Int+instance C Float+instance C Double
+ src/Algebra/RealField.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.RealField where++import qualified Algebra.Field              as Field+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          ((/))+import Algebra.RealIntegral   (quotRem, )+import Algebra.IntegralDomain (divMod, even, )+import Algebra.Ring           ((*), fromInteger, )+import Algebra.Additive       ((+), (-), negate, )+import Algebra.ZeroTestable   (isZero, )+import Algebra.ToInteger      (fromIntegral, )++import qualified Number.Ratio as Ratio+import Number.Ratio (T((:%)), Rational)++import qualified GHC.Float as GHC+import Prelude(Int,Float,Double)+import qualified Prelude as P+import PreludeBase+++{- |+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?+-}++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++instance C Float where+    splitFraction = preludeSplitFraction+    fraction      = fractionTrunc (GHC.int2Float . GHC.float2Int)+                    -- preludeFraction+    floor         = fromInteger . P.floor+    ceiling       = fromInteger . P.ceiling+    round         = fromInteger . P.round+    truncate      = fromInteger . P.truncate++instance C Double where+    splitFraction = preludeSplitFraction+    fraction      = fractionTrunc (GHC.int2Double . GHC.double2Int)+    floor         = fromInteger . P.floor+    ceiling       = fromInteger . P.ceiling+    round         = fromInteger . P.round+    truncate      = fromInteger . P.truncate++preludeSplitFraction :: (P.RealFrac a, Ring.C a, ToInteger.C b) => a -> (b,a)+preludeSplitFraction x =+   let (n,f) = P.properFraction x+   --  if x>=0 || f==0+   in  if f>=0+         then (fromInteger n,   f)+         else (fromInteger n-1, f+1)++preludeFraction :: (P.RealFrac a, Ring.C a) => a -> a+preludeFraction x =+   let second :: (Int, a) -> a+       second = snd+   in  fixFraction (second (P.properFraction x))++fractionTrunc :: (Ring.C a, Ord a) => (a -> a) -> a -> a+fractionTrunc trunc x =+   fixFraction (x - trunc x)++fixFraction :: (Ring.C a, Ord a) => a -> a+fixFraction y =+   if y>=0 then y else y+1+++{- | 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+
+ src/Algebra/RealIntegral.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Generally before using 'quot' and 'rem', think twice.+In most cases 'divMod' and friends are the right choice,+because they fulfill more of the wanted properties.+On some systems 'quot' and 'rem' are more efficient+and if you only use positive numbers, you may be happy with them.+But we cannot warrant the efficiency advantage.++See also:+Daan Leijen: Division and Modulus for Computer Scientists+<http://www.cs.uu.nl/%7Edaan/download/papers/divmodnote-letter.pdf>,+<http://www.haskell.org/pipermail/haskell-cafe/2007-August/030394.html>+-}+module Algebra.RealIntegral (+   C(quot, rem, quotRem),+   ) where++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 Algebra.Real (signum, )+import Algebra.IntegralDomain (divMod, )+import Algebra.Ring (one, ) -- fromInteger+import Algebra.Additive (zero, (+), (-), )++import PreludeBase+import Prelude (Int, Integer, )+++infixl 7 `quot`, `rem`++{- |+Remember that 'divMod' does not specify exactly what @a `quot` b@ should be,+mainly because there is no sensible way to define it in general.+For an instance of @Algebra.RealIntegral.C a@,+it is expected that @a `quot` b@ will round towards 0 and+@a `Prelude.div` b@ will round towards minus infinity.++Minimal definition: nothing required+-}++class (Real.C a, Integral.C a) => C a where+    quot, rem        :: a -> a -> a+    quotRem          :: a -> a -> (a,a)++    quot a b = fst (quotRem a b)+    rem a b  = snd (quotRem a b)+    quotRem a b = let (d,m) = divMod a b in+                   if (signum d < zero) then+                         (d+one,m-b) else (d,m)+++instance C Integer+instance C Int
+ src/Algebra/RealTranscendental.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.RealTranscendental where++import qualified Algebra.Transcendental      as Trans+import qualified Algebra.RealField           as RealField++import Algebra.Transcendental (atan, pi)+import Algebra.Field          ((/))+import Algebra.Ring           (fromInteger)+import Algebra.Additive       ((+), negate)++import NumericPrelude.Condition (select)++import qualified Prelude as P+import PreludeBase++++{-|+This class collects all functions for _scalar_ floating point numbers.+E.g. computing 'atan2' for complex floating numbers makes certainly no sense.+-}+class (RealField.C a, Trans.C a) => C a where+    atan2 :: a -> a -> a++    atan2 y x = select 0   -- must be after the other double zero tests+      [(x>0,          atan (y/x)),+       (x==0 && y>0,  pi/2),+       (x<0  && y>0,  pi + atan (y/x)),+       (x<=0 && y<0, -atan2 (-y) x),+       (y==0 && x<0,  pi)] -- must be after the previous test on zero y++instance C P.Float where+    atan2 = P.atan2++instance C P.Double where+    atan2 = P.atan2
+ src/Algebra/RightModule.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+module Algebra.RightModule where++import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive++-- import NumericPrelude+import qualified Prelude+++-- Is this right?+infixl 7 <*++class (Ring.C a, Additive.C b) => C a b where+    (<*) :: b -> a -> b
+ src/Algebra/Ring.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Ring (+    {- * Class -}+    C,++    (*),+    one,+    fromInteger,+    (^), sqr,++    {- * Complex functions -}+    product, product1, scalarProduct,++    {- * Properties -}+    propAssociative,+    propLeftDistributive,+    propRightDistributive,+    propLeftIdentity,+    propRightIdentity,+    propPowerCascade,+    propPowerProduct,+    propPowerDistributive,+    propCommutative,+  ) where++import qualified Algebra.Additive as Additive+import qualified Algebra.Laws as Laws++import Algebra.Additive(zero, (+), negate, sum)++import NumericPrelude.List(reduceRepeated, zipWithMatch)++import Test.QuickCheck ((==>), Property)++import PreludeBase+import Prelude(Integer,Int,Float,Double)+import qualified Data.Ratio as Ratio98+import qualified Prelude as P+-- import Test.QuickCheck+++infixl 7 *+infixr 8 ^+++{- |+Ring encapsulates the mathematical structure+of a (not necessarily commutative) ring, with the laws++@+  a * (b * c) === (a * b) * c+      one * a === a+      a * one === a+  a * (b + c) === a * b + a * c+@++Typical examples include integers, polynomials, matrices, and quaternions.++Minimal definition: '*', ('one' or 'fromInteger')+-}++class (Additive.C a) => C a where+    (*)         :: a -> a -> a+    one         :: a+    fromInteger :: Integer -> a+    {- |+    The exponent has fixed type 'Integer' in order+    to avoid an arbitrarily limitted range of exponents,+    but to reduce the need for the compiler to guess the type (default type).+    In practice the exponent is most oftenly fixed, and is most oftenly @2@.+    Fixed exponents can be optimized away and+    thus the expensive computation of 'Integer's doesn't matter.+    The previous solution used a 'Algebra.ToInteger.C' constrained type+    and the exponent was converted to Integer before computation.+    So the current solution is not less efficient.++    A variant of '^' with more flexibility is provided by 'Algebra.Core.ringPower'.+    -}+    (^)         :: a -> Integer -> a++    fromInteger n = if n < 0+                      then reduceRepeated (+) zero (negate one) (negate n)+                      else reduceRepeated (+) zero one n+    a ^ n = if n >= zero+              then reduceRepeated (*) one a n+              else error "(^): Illegal negative exponent"+    one = fromInteger 1+++sqr :: C a => a -> a+sqr x = x*x++product :: (C a) => [a] -> a+product = foldl (*) one++product1 :: (C a) => [a] -> a+product1 = foldl1 (*)+++scalarProduct :: C a => [a] -> [a] -> a+scalarProduct as bs = sum (zipWithMatch (*) as bs)+++{- * Instances for atomic types -}++instance C Integer where+    (*)    = (P.*)+    one    = P.fromInteger 1+    fromInteger = P.fromInteger++instance C Int where+    (*)    = (P.*)+    one    = P.fromInteger 1++instance C Float where+    (*)    = (P.*)+    one    = P.fromInteger 1++instance C Double where+    (*)    = (P.*)+    one    = P.fromInteger 1+++++propAssociative       :: (Eq a, C a) => a -> a -> a -> Bool+propLeftDistributive  :: (Eq a, C a) => a -> a -> a -> Bool+propRightDistributive :: (Eq a, C a) => a -> a -> a -> Bool+propLeftIdentity      :: (Eq a, C a) => a -> Bool+propRightIdentity     :: (Eq a, C a) => a -> Bool++propAssociative       =  Laws.associative (*)+propLeftDistributive  =  Laws.leftDistributive  (*) (+)+propRightDistributive =  Laws.rightDistributive (*) (+)+propLeftIdentity      =  Laws.leftIdentity  (*) one+propRightIdentity     =  Laws.rightIdentity (*) one++propPowerCascade      :: (Eq a, C a) => a -> Integer -> Integer -> Property+propPowerProduct      :: (Eq a, C a) => a -> Integer -> Integer -> Property+propPowerDistributive :: (Eq a, C a) => Integer -> a -> a -> Property++propPowerCascade      x i j  =  i>=0 && j>=0 ==> Laws.rightCascade (*) (^) x i j+propPowerProduct      x i j  =  i>=0 && j>=0 ==> Laws.homomorphism (x^) (+) (*) i j+propPowerDistributive i x y  =  i>=0 ==> Laws.leftDistributive (^) (*) i x y++{- | Commutativity need not be satisfied by all instances of 'Algebra.Ring.C'. -}+propCommutative :: (Eq a, C a) => a -> a -> Bool++propCommutative  =  Laws.commutative (*)+++-- legacy++instance (P.Integral a) => C (Ratio98.Ratio a) where+   one                 =  1+   fromInteger         =  P.fromInteger+   (*)                 =  (P.*)
+ src/Algebra/ToInteger.hs view
@@ -0,0 +1,73 @@+module Algebra.ToInteger where++import qualified Number.Ratio as Ratio++import qualified Algebra.ToRational     as ToRational+import qualified Algebra.Field          as Field+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.RealIntegral   as RealIntegral+import qualified Algebra.Ring           as Ring++import Number.Ratio (T((:%)), )++import Algebra.Field ((^-), )+import Algebra.Ring ((^), fromInteger, )++import qualified Prelude as P+import PreludeBase+import Prelude(Int,Integer)+++{- |+The two classes 'Algebra.ToInteger.C' and 'Algebra.ToRational.C'+exist to allow convenient conversions,+primarily between the built-in types.+They should satisfy++>   fromInteger .  toInteger === id+>    toRational .  toInteger === toRational++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.+-}+class (ToRational.C a, RealIntegral.C a) => C a where+   toInteger :: a -> Integer+++fromIntegral :: (C a, Ring.C b) => a -> b+fromIntegral = fromInteger . toInteger+++instance C Integer where+   toInteger = id++instance C Int where+   toInteger = P.toInteger++instance (C a, PID.C a) => ToRational.C (Ratio.T a) where+   toRational (x:%y)   =  toInteger x :% toInteger y+++{-|+A prefix function of '(Algebra.Ring.^)'+with a parameter order that fits the needs of partial application+and function composition.+It has generalised exponent.++See: Argument order of @expNat@ on+<http://www.haskell.org/pipermail/haskell-cafe/2006-September/018022.html>+-}+ringPower :: (Ring.C a, C b) => b -> a -> a+ringPower exponent basis = basis ^ toInteger exponent++{- |+A prefix function of '(Algebra.Field.^-)'.+It has a generalised exponent.+-}+fieldPower :: (Field.C a, C b) => b -> a -> a+fieldPower exponent basis = basis ^- toInteger exponent
+ src/Algebra/ToRational.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.ToRational where++import qualified Algebra.Real           as Real+import Algebra.Field (fromRational, )+import Algebra.Ring (fromInteger, )++import Number.Ratio (Rational, )++import qualified Prelude as P+import PreludeBase+import Prelude(Int,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".+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'++Laws that must be satisfied by instances:++>  fromRational' . toRational === id+-}+class (Real.C a) => C a where+   -- | Lossless conversion from any representation of a rational to 'Rational'+   toRational :: a -> Rational++instance C Integer where+   toRational = fromInteger++instance C Int where+   toRational = toRational . P.toInteger++instance C Float where+   toRational = fromRational . P.toRational++instance C Double where+   toRational = fromRational . P.toRational
+ src/Algebra/Transcendental.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS -fno-implicit-prelude #-}+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++import Algebra.Algebraic (sqrt)+import Algebra.Field     ((/), recip)+import Algebra.Ring      ((*), (^), fromInteger)+import Algebra.Additive  ((+), (-), negate)++import qualified Prelude as P+import PreludeBase+++infixr 8  **++{-|+Transcendental is the type of numbers supporting the elementary+transcendental functions.  Examples include real numbers, complex+numbers, and computable reals represented as a lazy list of rational+approximations.++Note the default declaration for a superclass.  See the comments+below, under "Instance declaractions for superclasses".++The semantics of these operations are rather ill-defined because of+branch cuts, etc.++Minimal complete definition:+     pi, exp, log, sin, cos, asin, acos, atan+-}+class (Algebraic.C a) => C a where+    pi                  :: a+    exp, log            :: a -> a+    logBase, (**)       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x++    tan  x           =  sin x / cos x++    asin x           =  atan (x / sqrt (1-x^2))+    acos x           =  pi/2 - asin x++    -- if these definitions have errors, then those in FMP.Types have them, too+    sinh x           =  (exp x - exp (-x)) / 2+    cosh x           =  (exp x + exp (-x)) / 2+    -- tanh x           =  (exp x - exp (-x)) / (exp x + exp (-x))+    tanh x           =  sinh x / cosh x++    asinh x          =  log (sqrt (x^2+1) + x)+    acosh x          =  log (sqrt (x^2-1) + x)+    atanh x          =  (log (1+x) - log (1-x)) / 2+++instance C P.Float where+    (**)  = (P.**)+    exp   = P.exp;   log   = P.log;   logBase = P.logBase+    pi    = P.pi;+    sin   = P.sin;   cos   = P.cos;   tan     = P.tan+    asin  = P.asin;  acos  = P.acos;  atan    = P.atan+    sinh  = P.sinh;  cosh  = P.cosh;  tanh    = P.tanh+    asinh = P.asinh; acosh = P.acosh; atanh   = P.atanh++instance C P.Double where+    (**)  = (P.**)+    exp   = P.exp;   log   = P.log;   logBase = P.logBase+    pi    = P.pi;+    sin   = P.sin;   cos   = P.cos;   tan     = P.tan+    asin  = P.asin;  acos  = P.acos;  atan    = P.atan+    sinh  = P.sinh;  cosh  = P.cosh;  tanh    = P.tanh+    asinh = P.asinh; acosh = P.acosh; atanh   = P.atanh+++{-* Transcendental laws, will only hold approximately on floating point numbers -}++propExpLog      :: (Eq a, C a) => a -> Bool+propLogExp      :: (Eq a, C a) => a -> Bool+propExpNeg      :: (Eq a, C a) => a -> Bool+propLogRecip    :: (Eq a, C a) => a -> Bool+propExpProduct  :: (Eq a, C a) => a -> a -> Bool+propExpLogPower :: (Eq a, C a) => a -> a -> Bool+propLogSum      :: (Eq a, C a) => a -> a -> Bool++propExpLog      x   = exp (log x)     == x+propLogExp      x   = log (exp x)     == x+propExpNeg      x   = exp (negate x)  == recip (exp x)+propLogRecip    x   = log (recip x)   == negate (log x)+propExpProduct  x y = Laws.homomorphism exp (+) (*) x y+propExpLogPower x y = exp (log x * y) == x ** y+propLogSum      x y = Laws.homomorphism log (*) (+) x y+++propPowerCascade      :: (Eq a, C a) => a -> a -> a -> Bool+propPowerProduct      :: (Eq a, C a) => a -> a -> a -> Bool+propPowerDistributive :: (Eq a, C a) => a -> a -> a -> Bool++propPowerCascade      x i j  =  Laws.rightCascade (*) (**) x i j+propPowerProduct      x i j  =  Laws.homomorphism (x**) (+) (*) i j+propPowerDistributive i x y  =  Laws.rightDistributive (**) (*) i x y++{- * Trigonometric laws, addition theorems -}++propTrigonometricPythagoras :: (Eq a, C a) => a -> Bool+propTrigonometricPythagoras x  =  cos x ^ 2 + sin x ^ 2 == 1++propSinPeriod   :: (Eq a, C a) => a -> Bool+propCosPeriod   :: (Eq a, C a) => a -> Bool+propTanPeriod   :: (Eq a, C a) => a -> Bool++propSinPeriod x = sin (x+2*pi) == sin x+propCosPeriod x = cos (x+2*pi) == cos x+propTanPeriod x = tan (x+2*pi) == tan x++propSinAngleSum  :: (Eq a, C a) => a -> a -> Bool+propCosAngleSum  :: (Eq a, C a) => a -> a -> Bool++propSinAngleSum x y  =  sin (x+y) == sin x * cos y + cos x * sin y+propCosAngleSum x y  =  cos (x+y) == cos x * cos y - sin x * sin y++propSinDoubleAngle :: (Eq a, C a) => a -> Bool+propCosDoubleAngle :: (Eq a, C a) => a -> Bool++propSinDoubleAngle x  =  sin (2*x) == 2 * sin x * cos x+propCosDoubleAngle x  =  cos (2*x) == 2 * cos x ^ 2 - 1++propSinSquare :: (Eq a, C a) => a -> Bool+propCosSquare :: (Eq a, C a) => a -> Bool++propSinSquare x  =  sin x ^ 2 == (1 - cos (2*x)) / 2+propCosSquare x  =  cos x ^ 2 == (1 + cos (2*x)) / 2+
+ src/Algebra/Units.hs view
@@ -0,0 +1,127 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.Units (+    {- * Class -}+    C,+    isUnit,+    stdAssociate,+    stdUnit,+    stdUnitInv,++    {- * Standard implementations for instances -}+    intQuery,+    intAssociate,+    intStandard,+    intStandardInverse,++    {- * Properties -}+    propComposition,+    propInverseUnit,+    propUniqueAssociate,+    propAssociateProduct,+  ) where++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.IntegralDomain (div)+import Algebra.Ring           (one, (*))+import Algebra.Additive       (negate)+import Algebra.ZeroTestable   (isZero)++import PreludeBase+import Prelude (Integer, Int)+import qualified Prelude as P+import Test.QuickCheck ((==>), Property)+++{- |+This class lets us deal with the units in a ring.+'isUnit' tells whether an element is a unit.+The other operations let us canonically+write an element as a unit times another element.+Two elements a, b of a ring R are _associates_ if a=b*u for a unit u.+For an element a, we want to write it as a=b*u where b is an associate of a.+The map (a->b) is called+"StandardAssociate" by Gap,+"unitCanonical" by Axiom,+and "canAssoc" by DoCon.+The map (a->u) is called+"canInv" by DoCon and+"unitNormal(x).unit" by Axiom.++The laws are++>   stdAssociate x * stdUnit x === x+>     stdUnit x * stdUnitInv x === 1+>  isUnit u ==> stdAssociate x === stdAssociate (x*u)++Currently some algorithms assume++>  stdAssociate(x*y) === stdAssociate x * stdAssociate y++Minimal definition:+   'isUnit' and ('stdUnit' or 'stdUnitInv') and optionally 'stdAssociate'+-}++class (Integral.C a) => C a where+  isUnit :: a -> Bool+  stdAssociate, stdUnit, stdUnitInv :: a -> a++  stdAssociate x = x * stdUnitInv x+  stdUnit      x = div one (stdUnitInv x)  -- should be safeDiv+  stdUnitInv   x = div one (stdUnit x)+++++{- * Instances for atomic types -}++intQuery :: (P.Integral a, Ring.C a) => a -> Bool+intQuery = flip elem [one, negate one]+{- constraint must be replaced by NumericPrelude.Real -}+intAssociate, intStandard, intStandardInverse ::+   (P.Integral a, Ring.C a, ZeroTestable.C a) => a -> a+intAssociate = P.abs+intStandard x = if isZero x then one else P.signum x+intStandardInverse = intStandard++instance C Int where+  isUnit       = intQuery+  stdAssociate = intAssociate+  stdUnit      = intStandard+  stdUnitInv   = intStandardInverse++instance C Integer where+  isUnit       = intQuery+  stdAssociate = intAssociate+  stdUnit      = intStandard+  stdUnitInv   = intStandardInverse+++{-+fieldQuery = not . isZero+fieldAssociate = 1+fieldStandard        x = if isZero x then 1 else x+fieldStandardInverse x = if isZero x then 1 else recip x+-}++++propComposition      :: (Eq a, C a) => a -> Bool+propInverseUnit      :: (Eq a, C a) => a -> Bool+propUniqueAssociate  :: (Eq a, C a) => a -> a -> Property+propAssociateProduct :: (Eq a, C a) => a -> a -> Bool++propComposition x  =  stdAssociate x * stdUnit x == x+propInverseUnit x  =    stdUnit x * stdUnitInv x == one+propUniqueAssociate u x =+                     isUnit u ==> stdAssociate x == stdAssociate (x*u)++{- | Currently some algorithms assume this property. -}+propAssociateProduct =+    Laws.homomorphism stdAssociate (*) (*)+
+ src/Algebra/Vector.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2004-2005++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable++Abstraction of vectors+-}++module Algebra.Vector where++import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive++import Algebra.Ring     ((*))+import Algebra.Additive ((+))++import Data.List (zipWith, foldl)+-- import Data.Functor (Functor, fmap)++import Prelude((.), (==), Bool, Functor, fmap)+import qualified Prelude as P+++-- Is this right?+infixr 7 *>++{-|+A Module over a ring satisfies:++>   a *> (b + c) === a *> b + a *> c+>   (a * b) *> c === a *> (b *> c)+>   (a + b) *> c === a *> c + b *> c+-}+class C v where+    -- duplicate some methods from Additive+    -- | zero element of the vector space+    zero  :: (Additive.C a) => v a+    -- | add and subtract elements+    (<+>) :: (Additive.C a) => v a -> v a -> v a+    -- | scale a vector by a scalar+    (*>)  :: (Ring.C a) => a -> v a -> v a++infixl 6 <+>+++{- |+We need a Haskell 98 type class+which provides equality test for Vector type constructors.+-}+class Eq v where+   eq :: P.Eq a => v a -> v a -> Bool+++infix 4 `eq`+++{-* Instances for standard type constructors -}++functorScale :: (Functor v, Ring.C a) => a -> v a -> v a+functorScale = fmap . (*)++instance C [] where+   zero  = Additive.zero+   (<+>) = (Additive.+)+   (*>)  = functorScale++instance C ((->) b) where+   zero     = Additive.zero+   (<+>)    = (Additive.+)+   (*>) s f = (s*) . f++instance Eq [] where+   eq = (==)++++{-* Related functions -}++{-|+Compute the linear combination of a list of vectors.+-}+linearComb :: (Ring.C a, C v) => [a] -> [v a] -> v a+linearComb c = foldl (<+>) zero . zipWith (*>) c+++{- * Properties -}++propCascade :: (C v, Eq v, Ring.C a, P.Eq a) =>+   a -> a -> v a -> Bool+propCascade a b c           = (a * b) *> c  `eq`  a *> (b *> c)++propRightDistributive :: (C v, Eq v, Ring.C a, P.Eq a) =>+   a -> v a -> v a -> Bool+propRightDistributive a b c =   a *> (b <+> c)  `eq`  a*>b <+> a*>c++propLeftDistributive :: (C v, Eq v, Ring.C a, P.Eq a) =>+   a -> a -> v a -> Bool+propLeftDistributive a b c  =   (a+b) *> c  `eq`  a*>c <+> b*>c
+ src/Algebra/VectorSpace.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+module Algebra.VectorSpace where++import qualified Algebra.Module+import qualified Algebra.Field as Field++-- import NumericPrelude+import qualified Prelude as P+++class (Field.C a, Algebra.Module.C a b) => C a b+++{-* Instances for atomic types -}++instance C P.Float P.Float++instance C P.Double P.Double++{-* Instances for composed types -}++instance (C a b0, C a b1) => C a (b0, b1)++instance (C a b0, C a b1, C a b2) => C a (b0, b1, b2)++instance (C a b) => C a [b]++instance (C a b) => C a (c -> b)
+ src/Algebra/ZeroTestable.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Algebra.ZeroTestable where++import qualified Prelude as P+import PreludeBase++import qualified Algebra.Additive as Additive++{- |+Maybe the naming should be according to Algebra.Unit:+Algebra.Zero as module name, and @query@ as method name.+-}+class C a where+   isZero :: a -> Bool++{- |+Checks if a number is the zero element.+This test is not possible for all 'Additive.C' types,+since e.g. a function type does not belong to Eq.+isZero is possible for some types where (==zero) fails+because there is no unique zero.+Examples are+vector (the length of the zero vector is unknown),+physical values (the unit of a zero quantity is unknown),+residue class (the modulus is unknown).+-}+defltIsZero :: (Eq a, Additive.C a) => a -> Bool+defltIsZero = (Additive.zero==)+++{-* Instances for atomic types -}++instance C P.Integer where+    isZero = defltIsZero++instance C P.Int where+    isZero = defltIsZero++instance C P.Float where+    isZero = defltIsZero++instance C P.Double where+    isZero = defltIsZero+++{-* Instances for composed types -}++instance (C v0, C v1) => C (v0, v1) where+    isZero (x0,x1) = isZero x0 && isZero x1++instance (C v0, C v1, C v2) => C (v0, v1, v2) where+    isZero (x0,x1,x2) = isZero x0 && isZero x1 && isZero x2+++instance (C v) => C [v] where+    isZero = all isZero
+ src/MathObj/Algebra.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Mikael Johansson 2006+Maintainer   :   mik@math.uni-jena.de+Stability    :   provisional+Portability  :   requires multi-parameter type classes++The generic case of a k-algebra generated by a monoid.+-}++module MathObj.Algebra where++import qualified Algebra.Vector   as Vector+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive+import qualified Algebra.Monoid   as Monoid++import Algebra.Ring((*))+import Algebra.Additive((+),negate,zero)+import Algebra.Monoid((<*>))++import Control.Monad(liftM2,Functor,fmap)+import Data.Map(Map)+import qualified Data.Map as Map+import Data.List(intersperse)++import PreludeBase(Ord,Eq,{-Read,-}Show,(++),($),+                   concat,map,show)+++newtype {- (Ord a, Monoid.C a, Ring.C b) => -}+     T a b = Cons (Map a b)+         deriving (Eq {- ,Read -} )++instance Functor (T a) where+   fmap f (Cons x) = Cons (fmap f x)++-- is an Indexable instance better than an Ord instance here?++instance (Ord a, Additive.C b) => Additive.C (T a b) where+   (+) = zipWith (+)+   {- This implementation is attracting but wrong.+     It fails if terms are present in b that are missing in a.+     Default implementation is better here.+   (-) = zipWith (-)+   -}+   negate = fmap negate+   zero = Cons Map.empty++zipWith :: (Ord a) => (b -> b -> b) -> (T a b -> T a b -> T a b)+zipWith op (Cons ma) (Cons mb) = Cons (Map.unionWith op ma mb)++instance Ord a => Vector.C (T a) where+   zero  = zero+   (<+>) = (+)+   (*>)  = Vector.functorScale++instance (Ord a, Monoid.C a, Ring.C b) => Ring.C (T a b) where+   one = Cons $ Map.singleton Monoid.idt Ring.one+   (Cons ma) * (Cons mb) =+      Cons $ Map.fromListWith (+) $+         liftM2 mulMonomial (Map.toList ma) (Map.toList mb)++mulMonomial :: (Monoid.C a, Ring.C b) => (a,b) -> (a,b) -> (a,b)+mulMonomial (c1,m1) (c2,m2) = (c1<*>c2,m1*m2)++instance (Show a, Show b) => Show (T a b) where+   show (Cons ma) = concat $+           intersperse "+" $+           map (\(m,c) -> show c ++ "." ++ show m)+               (Map.toList ma)++monomial :: a -> b -> (T a b)+monomial index coefficient = Cons (Map.singleton index coefficient)
+ src/MathObj/DiscreteMap.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+DiscreteMap is a class that unifies+Map and Array,+thus one can simply choose between+ - Map for sparse arrays+ - Array for full arrays.++Ok, forget it,+the Edison package provides the class AssocX+which probably will do it.++So long I use this module for some numeric instances for FiniteMaps+-}++module MathObj.DiscreteMap where++import qualified Algebra.NormedSpace.Sum       as NormedSum+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+import qualified Algebra.Vector                as Vector+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.Additive              as Additive++import Algebra.Module   ((*>))+import Algebra.Additive (zero,(+),negate)+import qualified Data.Map as Map+import Data.Map (Map)++import qualified Prelude as P+import PreludeBase++-- *** Should this be implemented by isZero?+-- | Remove all zero values from the map.+strip :: (Ord i, Eq v, Additive.C v) => Map i v -> Map i v+strip = Map.filter (zero /=)+--strip = Map.filter (((0 /=) .) . (flip const))++instance (Ord i, Eq v, Additive.C v) => Additive.C (Map i v) where+   zero = Map.empty+   (+)  = (strip.). Map.unionWith (+)+   --(+) y x = strip (Map.unionWith (+) y x)+   (-) x y = (+) x (negate y)+   {- won't work because Map.unionWith won't negate a value from y if no x value corresponds to it+   (-) x y = strip (Map.unionWith sub x y)+   -}+   negate  = fmap negate++instance Ord i => Vector.C (Map i) where+   zero  = Map.empty+   (<+>) = Map.unionWith (+)+   -- requires Eq instance for expo+   -- expo *> x = if expo == zero then zero else Vector.functorScale expo x+   (*>)  = Vector.functorScale++instance (Ord i, Eq a, Eq v, Module.C a v)+             => Module.C a (Map i v) where+--   (*>) 0    = \_ -> zero+--   (*>) expo = fmap ((*>) expo)+   (*>) expo x = if expo == zero then zero else fmap (expo *>) x++instance (Ord i, Eq a, Eq v, VectorSpace.C a v)+             => VectorSpace.C a (Map i v)++instance (Ord i, Eq a, Eq v, NormedSum.C a v)+             => NormedSum.C a (Map i v) where+   norm = foldl (+) zero . map NormedSum.norm . Map.elems++instance (Ord i, Eq a, Eq v, NormedEuc.Sqr a v)+             => NormedEuc.Sqr a (Map i v) where+   normSqr = foldl (+) zero . map NormedEuc.normSqr . Map.elems++instance (Ord i, Eq a, Eq v, Algebraic.C a, NormedEuc.Sqr a v)+             => NormedEuc.C a (Map i v) where+   norm = NormedEuc.defltNorm++instance (Ord i, Eq a, Eq v, NormedMax.C a v)+             => NormedMax.C a (Map i v) where+   norm = foldl max zero . map NormedMax.norm . Map.elems
+ src/MathObj/LaurentPolynomial.hs view
@@ -0,0 +1,284 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2004-2006++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Polynomials with negative and positive exponents.+-}+module MathObj.LaurentPolynomial where++import qualified MathObj.Polynomial  as Poly+import qualified MathObj.PowerSeries as PS++import qualified Algebra.VectorSpace  as VectorSpace+import qualified Algebra.Module       as Module+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 qualified Algebra.ZeroTestable as ZeroTestable++import qualified Number.Complex as Complex++import Algebra.ZeroTestable(isZero)+import Algebra.Module((*>))++import qualified PreludeBase as P+import qualified NumericPrelude as NP++import PreludeBase    hiding (const, reverse, )+import NumericPrelude hiding (div, negate, )++import qualified Data.List as List+import NumericPrelude.List (zipNeighborsWith)+++{- | Polynomial including negative exponents -}++data T a = Cons {expon :: Int, coeffs :: [a]}+++{- * Basic Operations -}++const :: a -> T a+const x = fromCoeffs [x]++(!) :: Additive.C a => T a -> Int -> a+(!) (Cons xt x) n =+   if n<xt+     then zero+     else head (drop (n-xt) x ++ [zero])++fromCoeffs :: [a] -> T a+fromCoeffs = fromShiftCoeffs 0++fromShiftCoeffs :: Int -> [a] -> T a+fromShiftCoeffs = Cons++fromPolynomial :: Poly.T a -> T a+fromPolynomial (Poly.Cons xs) = fromCoeffs xs++fromPowerSeries :: PS.T a -> T a+fromPowerSeries (PS.Cons xs) = fromCoeffs xs++bounds :: T a -> (Int, Int)+bounds (Cons xt x) = (xt, xt + length x - 1)++translate :: Int -> T a -> T a+translate t (Cons xt x) = Cons (xt+t) x+++instance Functor T where+  fmap f (Cons xt xs) = Cons xt (map f xs)+++{- * Show -}++appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons xt xs) =+    showParen (p >= appPrec)+       (showString "LaurentPolynomial.Cons " . shows xt .+        showString " " . shows xs)++{- * Additive -}++add :: Additive.C a => T a -> T a -> T a+add (Cons _ [])  y          = y+add  x          (Cons _ []) = x+add (Cons xt x) (Cons yt y) =+   if xt < yt+     then Cons xt (addShifted (yt-xt) x y)+     else Cons yt (addShifted (xt-yt) y x)++{-+Compute the value of a series of Laurent polynomials.++Requires that the start exponents constitute a (weakly) rising sequence,+where each exponent occurs only finitely often.++Cf. Synthesizer.Cut.arrange+-}+series :: (Additive.C a) => [T a] -> T a+series [] = fromCoeffs []+series ps =+   let es = map expon  ps+       xs = map coeffs ps+       ds = zipNeighborsWith subtract es+   in  Cons (head es) (addShiftedMany ds xs)++{- |+Add lists of numbers respecting a relative shift between the starts of the lists.+The shifts must be non-negative.+The list of relative shifts is one element shorter+than the list of summands.+Infinitely many summands are permitted,+provided that runs of zero shifts are all finite.+++We could add the lists either with 'foldl' or with 'foldr',+'foldl' would be straightforward, but more time consuming (quadratic time)+whereas foldr is not so obvious but needs only linear time.++(stars denote the coefficients,+ frames denote what is contained in the interim results)+'foldl' sums this way:++> | | | *******************************+> | | +--------------------------------+> | |          ************************+> | +----------------------------------+> |                        ************+> +------------------------------------++I.e. 'foldl' would use much time find the time differences+by successive subtraction 1.++'foldr' mixes this way:++>     +--------------------------------+>     | *******************************+>     |      +-------------------------+>     |      | ************************+>     |      |           +-------------+>     |      |           | ************++-}+addShiftedMany :: (Additive.C a) => [Int] -> [[a]] -> [a]+addShiftedMany ds xss =+   foldr (uncurry addShifted) [] (zip (ds++[0]) xss)++++addShifted :: Additive.C a => Int -> [a] -> [a] -> [a]+addShifted del px py =+   let recurse 0 x      = PS.add x py+       recurse d []     = replicate d zero ++ py+       recurse d (x:xs) = x : recurse (d-1) xs+   in  if del >= 0+         then recurse del px+         else error "LaurentPolynomial.addShifted: negative shift"+++negate :: Additive.C a => T a -> T a+negate (Cons xt x) = Cons xt (map NP.negate x)++sub :: Additive.C a => T a -> T a -> T a+sub x y = add x (negate y)++instance Additive.C a => Additive.C (T a) where+   zero   = fromCoeffs []+   (+)    = add+   (-)    = sub+   negate = negate+++{- * Module -}++scale :: Ring.C a => a -> [a] -> [a]+scale = Poly.scale++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = Vector.functorScale++instance (Module.C a b) => Module.C a (T b) where+    x *> Cons yt ys = Cons yt (x *> ys)++instance (Field.C a, Module.C a b) => VectorSpace.C a (T b)+++{- * 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)++instance (Ring.C a) => Ring.C (T a) where+    one           = const one+    fromInteger n = const (fromInteger n)+    (*)           = mul+++{- * Field.C -}++div :: (Field.C a, ZeroTestable.C a) => T a -> T a -> T a+div (Cons xt xs) (Cons yt ys) =+   let (xzero,x) = span isZero xs+       (yzero,y) = span isZero ys+   in  Cons (xt - yt + length xzero - length yzero)+            (PS.divide x y)++instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where+   (/) = div++divExample :: T NP.Rational+divExample = div (Cons 1 [0,0,1,2,1]) (Cons 1 [0,0,0,1,1])+++++{- * Comparisons -}++{- |+Two polynomials may be stored differently.+This function checks whether two values of type @LaurentPolynomial@+actually represent the same polynomial.+-}+equivalent :: (Eq a, ZeroTestable.C a) => T a -> T a -> Bool+equivalent xs ys =+   let (Cons xt x, Cons yt y) =+          if expon xs <= expon ys+            then (xs,ys)+            else (ys,xs)+       (xPref, xSuf) = splitAt (yt-xt) x+       aux (a:as) (b:bs) = a == b && aux as bs+       aux []     bs     = all isZero bs+       aux as     []     = all isZero as+   in  all isZero xPref  &&  aux xSuf y++instance (Eq a, ZeroTestable.C a) => Eq (T a) where+   (==) = equivalent+++identical :: (Eq a) => T a -> T a -> Bool+identical (Cons xt xs) (Cons yt ys) =+   xt==yt && xs == ys+++{- |+Check whether a Laurent polynomial has only the absolute term,+that is, it represents the constant polynomial.+-}+isAbsolute :: (ZeroTestable.C a) => T a -> Bool+isAbsolute (Cons xt x) =+   and (zipWith (\i xi -> isZero xi || i==0) [xt..] x)++++{- * Transformations of arguments -}++{- | p(z) -> p(-z) -}+alternate :: Additive.C a => T a -> T a+alternate (Cons xt x) =+   Cons xt (zipWith id (drop (mod xt 2) (cycle [id,NP.negate])) x)++{- | p(z) -> p(1\/z) -}+reverse :: T a -> T a+reverse (Cons xt x) =+   Cons (1 - xt - length x) (List.reverse x)++{- | p(exp(i·x)) -> conjugate(p(exp(i·x)))++If you interpret @(p*)@ as a linear operator on the space of Laurent polynomials,+then @(adjoint p *)@ is the adjoint operator.+-}+adjoint :: Additive.C a => T (Complex.T a) -> T (Complex.T a)+adjoint x =+   let (Cons yt y) = reverse x+   in  (Cons yt (map Complex.conjugate y))
+ src/MathObj/Matrix.hs view
@@ -0,0 +1,151 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright    :   (c) Mikael Johansson 2006+Maintainer   :   mik@math.uni-jena.de+Stability    :   provisional+Portability  :   requires multi-parameter type classes++Routines and abstractions for Matrices and+basic linear algebra over fields or rings.+-}++module MathObj.Matrix where++import qualified Algebra.Module   as Module+import qualified Algebra.Vector   as Vector+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive++import Algebra.Module((*>))+import Algebra.Ring((*), fromInteger, scalarProduct)+import Algebra.Additive((+), (-), zero, subtract)++import Data.Array (Array, listArray, elems, bounds, (!), ixmap, range)+import qualified Data.List as List++import Control.Monad (liftM2)+import Control.Exception (assert)++import NumericPrelude.List (outerProduct)+import NumericPrelude(Integer)+import PreludeBase hiding (zipWith)++{- |+A matrix is a twodimensional array of ring elements, indexed by integers.+-}++data {-(Ring.C a) =>-}+       T a = Cons (Array (Integer, Integer) a) deriving (Eq,Ord,Read)++{- |+Transposition of matrices is just transposition in the sense of+Data.List.+-}+++-- candidate for Utility+twist :: (Integer,Integer) -> (Integer,Integer)+twist (x,y) = (y,x)++transpose :: T a -> T a+transpose (Cons m) =+   let (lower,upper) = bounds m+   in  Cons (ixmap (twist lower, twist upper) twist m)++rows :: T a -> [[a]]+rows (Cons m) =+   let ((lr,lc), (ur,uc)) = bounds m+   in  outerProduct (curry(m!)) (range (lr,ur)) (range (lc,uc))++columns :: T a -> [[a]]+columns (Cons m) =+   let ((lr,lc), (ur,uc)) = bounds m+   in  outerProduct (curry(m!)) (range (lc,uc)) (range (lr,ur))++fromList :: Integer -> Integer -> [a] -> T a+fromList m n xs = Cons (listArray ((1,1),(m,n)) xs)++instance (Ring.C a, Show a) => Show (T a) where+  show m = List.unlines $ map (\r -> "(" ++ r ++ ")")+        $ map (unwords . map show) $ rows m+++dimension :: T a -> (Integer,Integer)+dimension (Cons m) = uncurry subtract (bounds m) + (1,1)++numRows :: T a -> Integer+numRows = fst . dimension++numColumns :: T a -> Integer+numColumns = snd . dimension++-- These implementations may benefit from a better exception than+-- just assertions to validate dimensionalities+instance (Additive.C a) => Additive.C (T a) where+  (+) = zipWith (+)+  (-) = zipWith (-)+  zero = zeroMatrix 1 1++zipWith :: (a -> b -> c) -> T a -> T b -> T c+zipWith op mM@(Cons m) nM@(Cons n) =+   let d = dimension mM+       em = elems m+       en = elems n+   in  assert (d == dimension nM) $+         uncurry fromList d (List.zipWith op em en)++zeroMatrix :: (Additive.C a) => Integer -> Integer -> T a+zeroMatrix m n = fromList m n $+   List.repeat zero+--    List.replicate (fromInteger (m*n)) zero++instance (Ring.C a) => Ring.C (T a) where+  mM * nM = assert (numRows mM == numColumns nM) $+        fromList (numColumns mM) (numRows nM)+           (liftM2 scalarProduct (rows mM) (columns nM))+  fromInteger n = fromList 1 1 [fromInteger n]++instance Functor T where+   fmap f (Cons m) = Cons (fmap f m)++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = Vector.functorScale++instance Module.C a b => Module.C a (T b) where+   x *> m = fmap (x*>) m++{- |+What more do we need from our matrix class? We have addition,+subtraction and multiplication, and thus composition of generic+free-module-maps. We're going to want to solve linear equations with+or without fields underneath, so we're going to want an implementation+of the Gaussian algorithm as well as most probably Smith normal+form. Determinants are cool, and these are to be calculated either+with the Gaussian algorithm or some other goodish method.+-}++{- |+ We'll want generic linear equation solving, returning one solution,+any solution really, or nothing. Basically, this is asking for the+preimage of a given vector over the given map, so++a_11 x_1 + .. + a_1n x_n = y_1+ ...+a_m1 x_1 + .. + a_mn a_n = y_m++has really x_1,...,x_n as a preimage of the vector y_1,..,y_m under+the map (a_ij), since obviously y_1,..,y_m = (a_ij) x_1,..,x_n++So, generic linear equation solving boils down to the function+-}+preimage :: (Ring.C a) => T a -> T a -> Maybe (T a)+preimage a y = assert+        (numRows a == numRows y &&     -- they match+         numColumns y == 1)               -- and y is a column vector+                Nothing++{-+Cf. /usr/lib/hugs/demos/Matrix.hs+-}
+ src/MathObj/PartialFraction.hs view
@@ -0,0 +1,399 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Henning Thielemann 2007+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :   portable++Implementation of partial fractions.+Useful e.g. for fractions of integers and fractions of polynomials.++For the considered ring the prime factorization must be unique.+-}++module MathObj.PartialFraction where++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+import qualified Algebra.Indexable            as Indexable++import Number.Ratio((%))+import Algebra.IntegralDomain(divMod, divModZero, decomposeVarPositionalInf)+import Algebra.Units(stdAssociate, stdUnitInv)+import Algebra.Field((/))+import Algebra.Ring((*), one, product)+import Algebra.Additive((+), zero, negate)+import Algebra.ZeroTestable (isZero)++import qualified Data.List as List++import Data.Map(Map)+import qualified Data.Map as Map+import Data.Maybe(fromMaybe)+import NumericPrelude.List(replicateMatch, dropWhileRev)+import Data.List(group, sortBy, mapAccumR)++import PreludeBase hiding (zipWith)++import NumericPrelude(Int, fromInteger)++++{- |+@Cons z (indexMapFromList [(x0,[y00,y01]), (x1,[y10]), (x2,[y20,y21,y22])])@+represents the partial fraction+@z + y00/x0 + y01/x0^2 + y10/x1 + y20/x2 + y21/x2^2 + y22/x2^3@+The denominators @x0, x1, x2, ...@ must be irreducible,+but we can't check this in general.+It is also not enough to have relatively prime denominators,+because when adding two partial fraction representations+there might concur denominators that have non-trivial common divisors.+-}+data T a =+   Cons a (Map (Indexable.ToOrd a) [a])+      deriving (Eq)++{- |+Unchecked construction.+-}+fromFractionSum :: (Indexable.C a) => a -> [(a,[a])] -> T a+fromFractionSum z m =+   Cons z (indexMapFromList m)++toFractionSum :: (Indexable.C a) => T a -> (a, [(a,[a])])+toFractionSum (Cons z m) =+   (z, indexMapToList m)++appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons z m) =+    showParen (p >= appPrec)+       (showString "PartialFraction.fromFractionSum " .+        showsPrec (succ appPrec) z . showString " " .+        shows (indexMapToList m))+++toFraction :: PID.C a => T a -> Ratio.T a+toFraction (Cons z m) =+   let fracs = map (uncurry multiToFraction) (indexMapToList m)+   in  foldl (+) (Ratio.fromValue z) fracs++{- |+'PrincipalIdealDomain.C' is not really necessary here and+only due to invokation of 'toFraction'.+-}+toFactoredFraction :: (PID.C a) => T a -> ([a], a)+toFactoredFraction x@(Cons _ m) =+   let r = toFraction x+       denoms = concat $ Map.elems $ indexMapMapWithKey (flip replicateMatch) m+       numer = foldl (flip Ratio.scale) r denoms+       {- From the theory it must be Ratio.denominator denom==1.+          We could check this dynamically, if there would be an Eq instance.+          We could omit this completely,+          if we would reimplement Ratio addition. -}+   in  (denoms, Ratio.numerator numer)++{- |+'PrincipalIdealDomain.C' is not really necessary here and+only due to invokation of 'Ratio.%'.+-}+multiToFraction :: PID.C a => a -> [a] -> Ratio.T a+multiToFraction denom =+   foldr (\numer acc ->+            (Ratio.fromValue numer + acc) / Ratio.fromValue denom) zero++hornerRev :: Ring.C a => a -> [a] -> a+hornerRev x = foldl (\val c -> val*x+c) zero+++{- |+@fromFactoredFraction x y@+computes the partial fraction representation of @y % product x@,+where the elements of @x@ must be irreducible.+The function transforms the factors into their standard form+with respect to unit factors.++There are more direct methods for special cases+like polynomials over rational numbers+where the denominators are linear factors.+-}+fromFactoredFraction :: (PID.C a, Indexable.C a) => [a] -> a -> T a+fromFactoredFraction denoms0 numer0 =+   let denoms = group $ sortBy Indexable.compare $ map stdAssociate denoms0+       numer  = foldl (*) numer0 $ map stdUnitInv denoms0+       denomPowers = map product denoms+          {- since the sub-lists contain the same value,+             the products are powers,+             which could be computed more efficiently -}+       partProdLeft         = scanl (*) one denomPowers+       (prod:partProdRight) = scanr (*) one denomPowers+       (intPart,numerRed) = divMod numer prod+       facs = List.zipWith (*) partProdLeft partProdRight+       numers =+          fromMaybe+             (error $ "PartialFraction.fromFactoredFraction: " +++                      "denominators must be relatively prime")+             (PID.diophantineMulti numerRed facs)+       pairs = List.zipWith multiFromFraction denoms numers+       -- Is reduceHeads also necessary for polynomial partial fractions?+   in  removeZeros $ reduceHeads $ Cons intPart (indexMapFromList pairs)++fromFactoredFractionAlt :: (PID.C a, Indexable.C a) => [a] -> a -> T a+fromFactoredFractionAlt denoms numer =+   foldl (\p d -> scaleFrac (one%d) p) (fromValue numer) denoms++{- |+The list of denominators must contain equal elements.+Sorry for this hack.+-}+multiFromFraction :: PID.C a => [a] -> a -> (a,[a])+multiFromFraction (d:ds) n =+   (d, reverse $ decomposeVarPositionalInf ds n)+multiFromFraction [] _ =+   error "PartialFraction.multiFromFraction: there must be one denominator"++fromValue :: a -> T a+fromValue x = Cons x Map.empty+++{- |+A normalization step which separates the integer part+from the leading fraction of each sub-list.+-}+reduceHeads :: Integral.C a => T a -> T a+reduceHeads (Cons z m0) =+   let m1 = indexMapMapWithKey (\x (y:ys) -> let (q,r) = divMod y x in (q,r:ys)) m0+   in  Cons+          (foldl (+) z (map fst $ Map.elems m1))+          (fmap snd m1)++{- |+Cf. Number.Positional+-}+carryRipple :: Integral.C a => a -> [a] -> (a,[a])+carryRipple b =+   mapAccumR (\carry y -> divMod (y+carry) b) zero+++{- |+A normalization step which reduces all elements in sub-lists+modulo their denominators.+Zeros might be the result, that must be remove with 'removeZeros'.+-}+normalizeModulo :: Integral.C a => T a -> T a+normalizeModulo (Cons z0 m0) =+   let m1 = indexMapMapWithKey carryRipple m0+       -- would be nice to have a Map.unzip function+       ints = Map.elems $ fmap fst m1+   in  Cons (foldl (+) z0 ints) (fmap snd m1)++++{- |+Remove trailing zeros in sub-lists+because if lists are converted to fractions by 'multiToFraction'+we must be sure that the denominator of the (cancelled) fraction+is indeed the stored power of the irreducible denominator.+Otherwise 'mulFrac' leads to wrong results.+-}+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+++{-+instance Functor (T a) where+   fmap f (Cons x) = Cons (fmap f x)+-}++zipWith :: (Indexable.C a) => (a -> a -> a) -> ([a] -> [a] -> [a]) ->+   (T a -> T a -> T a)+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+   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.+     Default implementation is better here.+     a - b = removeZeros $ normalizeModulo $ zipWith (-) (-) a b+   -}+   negate (Cons z m) = Cons (negate z) (fmap negate m)+   zero = fromValue zero++{- |+Transforms a product of two partial fractions+into a sum of two fractions.+The denominators must be at least relatively prime.+Since 'T' requires irreducible denominators,+these are also relatively prime.++Example: @mulFrac (1%6) (1%4)@ fails because of the common divisor @2@.+-}+mulFrac :: (PID.C a) => Ratio.T a -> Ratio.T a -> (a, a)+mulFrac x y =+   let dx = Ratio.denominator x+       dy = Ratio.denominator y+   in  fromMaybe+          (error "PartialFraction.mulFrac: denominators must be relatively prime")+          (PID.diophantine (Ratio.numerator x * Ratio.numerator y) dy dx)++{-+nx/dx * ny/dy = a/dx + b/dy+nx*ny = a*dy + b*dx+-}++mulFrac' :: (PID.C a) => Ratio.T a -> Ratio.T a -> (Ratio.T a, Ratio.T a)+mulFrac' x y =+   let (na,nb) = mulFrac x y+   in  (na % Ratio.denominator x, nb % Ratio.denominator y)++{-+Also works if the operands share a non-trivial divisor.++mulFracOverlap :: (PID.C a) =>+   Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a)+mulFracOverlap x y =+   let dx = Ratio.denominator x+       dy = Ratio.denominator y+       (g,(a0,b0)) = extendedGCD dy dx+       (q,r) = divModZero (Ratio.numerator x * Ratio.numerator y) g+   in  if (isZero r)+         then ((q*a, q*b), zero)+         else+           let fx = safeDiv dx g+               fy = safeDiv 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:+nx/(g*fx) * ny/(g*fy) = a/fx + b/fy + c/g^2+nx*ny = a*fy*g^2 + b*fx*g^2 + c*fx*fy+      = a*dy*g   + b*dx*g   + c*fx*fy+a0*dy + b0*dx = g+a=a0*k+b=b0*k++This approach does still fail on 1%2 * 1%4.+-}++{- |+Works always but simply puts the product into the last fraction.+-}+mulFracStupid :: (PID.C a) =>+   Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a)+mulFracStupid x y =+   let dx = Ratio.denominator x+       dy = Ratio.denominator y+       [a,b,c] =+          fromMaybe+             (error "PartialFraction.mulFracOverlap: (gcd 1 x) must always be a unit")+             (PID.diophantineMulti+                 (Ratio.numerator x * Ratio.numerator y) [dy, dx, one])+   in  ((a % dx, b % dy), c%(dx*dy))++{- |+Also works if the operands share a non-trivial divisor.+However the results are quite arbitrary.+-}+mulFracOverlap :: (PID.C a) =>+   Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a)+mulFracOverlap x y =+   let dx = Ratio.denominator x+       dy = Ratio.denominator y+       nx = Ratio.numerator x+       ny = Ratio.numerator y+       (g,(a,b)) = PID.extendedGCD dy dx+       (q,r) = divModZero (nx*ny) g+   in  (((q*a)%dx, (q*b)%dy), r%(dx*dy))+++{- |+Expects an irreducible denominator as associate in standard form.+-}+scaleFrac :: (PID.C a, Indexable.C a) => Ratio.T a -> T a -> T a+scaleFrac s (Cons z0 m) =+   let ns = Ratio.numerator s+       ds = Ratio.denominator s+       dsOrd = Indexable.toOrd ds+       -- (z,zr) = Ratio.split (Ratio.scale z0 s)+       (z,zr) = divMod (z0*ns) ds+       scaleFracs =+          (\(scs,fracs) ->+             Map.insert dsOrd [foldl (+) zr scs] $+                indexMapFromList $+                   map (uncurry multiFromFraction) fracs) .+          unzip .+          map (\(dis,r) ->+                 let (sc,rc) = mulFrac s r+                 in  (sc, (dis, rc))) .+          Map.elems .+          indexMapMapWithKey+             (\d l -> (replicateMatch l d, multiToFraction d l))+   in  removeZeros $ reduceHeads $ Cons z+          (mapApplySplit dsOrd (+)+             (uncurry (:) . carryRipple ds . map (ns*))+             scaleFracs m)++scaleInt :: (PID.C a, Indexable.C a) => a -> T a -> T a+scaleInt x (Cons z m) =+   removeZeros $ normalizeModulo $+      Cons (x*z) (Map.map (map (x*)) m)+++mul :: (PID.C a, Indexable.C a) => T a -> T a -> T a+mul (Cons z m) a =+   foldl+      (+) (scaleInt z a)+      (map (\(d,l) ->+              -- cf. to multiToFraction+              foldr (\numer acc ->+                 scaleFrac (one%d) (scaleInt numer a + acc)) zero l)+           (indexMapToList m))++mulFast :: (PID.C a, Indexable.C a) => T a -> T a -> T a+mulFast pa pb =+   let ra = toFactoredFraction pa+       rb = toFactoredFraction pb+   in  fromFactoredFraction (fst ra ++ fst rb) (snd ra * snd rb)+++instance (PID.C a, Indexable.C a) => Ring.C (T a) where+   one = fromValue one+   (*) = mulFast+++{- * Helper functions for work with Maps with Indexable keys -}++indexMapMapWithKey :: (a -> b -> c)+                      -> Map (Indexable.ToOrd a) b+                      -> Map (Indexable.ToOrd a) c+indexMapMapWithKey f = Map.mapWithKey (f . Indexable.fromOrd)++indexMapToList :: Map (Indexable.ToOrd a) b -> [(a, b)]+indexMapToList = map (\(k,e) -> (Indexable.fromOrd k, e)) . Map.toList++indexMapFromList :: Indexable.C a => [(a, b)] -> Map (Indexable.ToOrd a) b+indexMapFromList = Map.fromList . map (\(k,e) -> (Indexable.toOrd k, e))++{- |+Apply a function on a specific element if it exists,+and another function to the rest of the map.+-}+mapApplySplit :: Ord a =>+   a -> (c -> c -> c) -> +   (b -> c) -> (Map a b -> Map a c) -> Map a b -> Map a c+mapApplySplit key addOp f g m =+   maybe+      (g m)+      (\x -> Map.insertWith addOp key (f x) $ g (Map.delete key m))+      (Map.lookup key m)+
+ src/MathObj/Permutation.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Henning Thielemann 2006+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :++Routines and abstractions for permutations of Integers.++***+Seems to be a candidate for Algebra directory.+Algebra.PermutationGroup ?+-}++module MathObj.Permutation where++import Data.Array(Ix)++-- import NumericPrelude (Integer)+import PreludeBase+++{- |+There are quite a few way we could represent elements of permutation+groups: the images in a row, a list of the cycles, et.c. All of these+differ highly in how complex various operations end up being.+-}++class C p where+   domain  :: (Ix i) => p i -> (i, i)+   apply   :: (Ix i) => p i -> i -> i+   inverse :: (Ix i) => p i -> p i
+ src/MathObj/Permutation/CycleList.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Mikael Johansson 2006+Maintainer   :   mik@math.uni-jena.de+Stability    :   provisional+Portability  :   requires multi-parameter type classes++Permutation of Integers represented by cycles.+-}++module MathObj.Permutation.CycleList where++import Data.Set(Set)+import qualified Data.Set as Set++import Data.List (unfoldr)+import Data.Array(Ix)+import qualified Data.Array as Array++import NumericPrelude.List (takeMatch)+import NumericPrelude.Condition (toMaybe)+import NumericPrelude (fromInteger)+import PreludeBase+++type Cycle i = [i]+type T i = [Cycle i]++++fromFunction :: (Ix i) =>+   (i, i) -> (i -> i) -> T i+fromFunction rng f =+   let extractCycle available =+          do el <- choose available+             let orb = orbit f el+             return (orb, Set.difference available (Set.fromList orb))+       cycles = unfoldr extractCycle (Set.fromList (Array.range rng))+   in  keepEssentials cycles++++-- right action of a cycle+cycleRightAction :: (Eq i) => i -> Cycle i -> i+x `cycleRightAction` c = cycleAction c x++-- left action of a cycle+cycleLeftAction :: (Eq i) => Cycle i -> i -> i+c `cycleLeftAction` x = cycleAction (reverse c) x++cycleAction :: (Eq i) => [i] -> i -> i+cycleAction cyc x =+   case dropWhile (x/=) (cyc ++ [head cyc]) of+      _:y:_ -> y+      _ -> x+++cycleOrbit :: (Ord i) => Cycle i -> i -> [i]+cycleOrbit cyc = orbit (flip cycleRightAction cyc)++{- |+Right (left?) group action on the Integers.+Close to, but not the same as the module action in Algebra.Module.+-}+(*>) :: (Eq i) => T i -> i -> i+p *> x = foldr (flip cycleRightAction) x p++cyclesOrbit ::(Ord i) => T i -> i -> [i]+cyclesOrbit p = orbit (p *>)++orbit :: (Ord i) => (i -> i) -> i -> [i]+orbit op x0 = takeUntilRepetition (iterate op x0)++-- | candidates for NumericPrelude.List ?+takeUntilRepetition :: Ord a => [a] -> [a]+takeUntilRepetition xs =+   let accs = scanl (flip Set.insert) Set.empty xs+       lenlist = takeWhile not (zipWith Set.member xs accs)+   in  takeMatch lenlist xs++takeUntilRepetitionSlow :: Eq a => [a] -> [a]+takeUntilRepetitionSlow xs =+   let accs = scanl (flip (:)) [] xs+       lenlist = takeWhile not (zipWith elem xs accs)+   in  takeMatch lenlist xs+++{-+Alternative to Data.Set.minView in GHC-6.6.+-}+choose :: Set a -> Maybe a+choose set =+   toMaybe (not (Set.null set)) (Set.findMin set)++keepEssentials :: T i -> T i+keepEssentials = filter isEssential++-- is more lazy than (length cyc > 1)+isEssential :: Cycle i -> Bool+isEssential = not . null . drop 1++inverse :: T i -> T i+inverse = map reverse
+ src/MathObj/Permutation/CycleList/Check.hs view
@@ -0,0 +1,125 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Henning Thielemann 2006+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :   requires multi-parameter type classes+-}++module MathObj.Permutation.CycleList.Check where++import qualified MathObj.Permutation.CycleList as PermCycle+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 Data.Array((!), Ix)+import qualified Data.Array as Array++-- import NumericPrelude (Integer)+import PreludeBase hiding (cycle)++{- |+We shall make a little bit of a hack here, enabling us to use additive+or multiplicative syntax for groups as we wish by simply instantiating+Num with both operations corresponding to the group operation of the+permutation group we're studying+-}++{- |+There are quite a few way we could represent elements of permutation+groups: the images in a row, a list of the cycles, et.c. All of these+differ highly in how complex various operations end up being.+-}++newtype Cycle i = Cycle { cycle :: [i] } deriving (Read,Eq)+data T i = Cons { range :: (i, i), cycles :: [Cycle i] }++{- |+Does not check whether the input values are in range.+-}+fromCycles :: (i, i) -> [[i]] -> T i+fromCycles rng = Cons rng . map Cycle++toCycles :: T i -> [[i]]+toCycles = map cycle . cycles++toTable :: (Ix i) => T i -> PermTable.T i+toTable x = PermTable.fromCycles (range x) (toCycles x)++fromTable :: (Ix i) => PermTable.T i -> T i+fromTable x =+   let rng = Array.bounds x+   in  fromCycles rng (PermCycle.fromFunction rng (x!))+++errIncompat :: a+errIncompat = error "Permutation.CycleList: Incompatible domains"++liftCmpTable2 :: (Ix i) =>+   (PermTable.T i -> PermTable.T i -> a) -> T i -> T i -> a+liftCmpTable2 f x y =+   if range x == range y+     then f (toTable x) (toTable y)+     else errIncompat++liftTable2 :: (Ix i) =>+   (PermTable.T i -> PermTable.T i -> PermTable.T i) -> T i -> T i -> T i+liftTable2 f x y = fromTable (liftCmpTable2 f x y)+++closure :: (Ix i) => [T i] -> [T i]+closure = map fromTable . PermTable.closure . map toTable+++instance Perm.C T where+   domain    = range+   apply   p = ((toCycles p) PermCycle.*>)+   inverse p = fromCycles (range p) (PermCycle.inverse (toCycles p))++instance Show i => Show (Cycle i) where+   show c = "(" +++           (unwords $+            map show $+            cycle c) ++ ")"++instance Show i => Show (T i) where+   show p =+      case cycles p of+         []  -> "Id"+         cyc -> concatMap show cyc+++{- |+These instances may need more work+They involve converting a permutation to a table.+-}+instance Ix i => Eq (T i) where+   (==)  =  liftCmpTable2 (==)++instance Ix i => Ord (T i) where+   compare  =  liftCmpTable2 compare++{- Better: Group class and instances+instance Additive.C (T i) where+   p + q = p * q+   negate = inverse+   zero = one++instance Ring.C (T i) where+   (Cons op cp) * (Cons oq cq) = reduceCycles $+           Cons (max op oq) (cp ++ cq)+   one = Cons 1 []+-}++instance Ix i => Monoid.C (T i) where+   (<*>) = liftTable2 PermTable.compose+   idt   = error "There is no generic unit element"
+ src/MathObj/Permutation/Table.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Henning Thielemann 2006+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :++Permutation represented by an array of the images.+-}++module MathObj.Permutation.Table where++import qualified MathObj.Permutation as Perm++import Data.Set(Set)+import qualified Data.Set as Set++import Data.Array(Array,(!),(//),Ix)+import qualified Data.Array as Array++import Data.List ((\\), nub, unfoldr)++import NumericPrelude.Condition (toMaybe)++-- import NumericPrelude (Integer)+import PreludeBase hiding (cycle)+++type T i = Array i i+++fromFunction :: (Ix i) =>+   (i, i) -> (i -> i) -> T i+fromFunction rng f =+   Array.listArray rng (map f (Array.range rng))++toFunction :: (Ix i) => T i -> (i -> i)+toFunction = (!)++{-+Create a permutation in table form+from any other permutation representation.+-}+fromPermutation :: (Ix i, Perm.C p) => p i -> T i+fromPermutation x =+   let rng = Perm.domain x+   in  Array.listArray rng (map (Perm.apply x) (Array.range rng))++fromCycles :: (Ix i) => (i, i) -> [[i]] -> T i+fromCycles rng = foldl (flip cycle) (identity rng)+++identity :: (Ix i) => (i, i) -> T i+identity rng = Array.listArray rng (Array.range rng)++cycle :: (Ix i) => [i] -> T i -> T i+cycle cyc p =+   p // zipWith (\i j -> (j,p!i)) cyc (tail (cyc++cyc))++inverse :: (Ix i) => T i -> T i+inverse p =+   let rng = Array.bounds p+   in  Array.array rng (map swap (Array.assocs p))++compose :: (Ix i) => T i -> T i -> T i+compose p q =+   let pRng = Array.bounds p+       qRng = Array.bounds q+   in  if pRng==qRng+         then fmap (p!) q+         else error "compose: ranges differ"+--                     ++ show pRng ++ " /= " ++ show qRng)++-- | candidate for Utility+swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)+++{- |+Extremely naïve algorithm+to generate a list of all elements in a group.+Should be replaced by a Schreier-Sims system+if this code is ever used for anything bigger than .. say ..+groups of order 512 or so.+-}+{-+Alternative to Data.Set.minView in GHC-6.6.+-}+choose :: Set a -> Maybe (a, Set a)+choose set =+   toMaybe (not (Set.null set)) (Set.deleteFindMin set)++closure :: (Ix i) => [T i] -> [T i]+closure [] = []+closure generators@(gen:_) =+   let genSet = Set.fromList generators+       idSet  = Set.singleton (identity (Array.bounds gen))+       generate (registered, candidates) =+          do (cand, remCands) <- choose candidates+             let newCands =+                    flip Set.difference registered $+                    Set.map (compose cand) genSet+             return (cand, (Set.union registered newCands,+                            Set.union remCands newCands))+   in  unfoldr generate (idSet, idSet)++closureSlow :: (Ix i) => [T i] -> [T i]+closureSlow [] = []+closureSlow generators@(gen:_) =+   let addElts grp [] = grp+       addElts grp cands@(cand:remCands) =+          let group'   = grp ++ [cand]+              newCands = map (compose cand) generators+              cands'   = nub (remCands ++ newCands) \\ (grp ++ cands)+          in  addElts group' cands'+   in  addElts [] [identity (Array.bounds gen)]
+ src/MathObj/Polynomial.hs view
@@ -0,0 +1,374 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}++{- |+Polynomials and rational functions in a single indeterminate.+Polynomials are represented by a list of coefficients.+All non-zero coefficients are listed, but there may be extra '0's at the end.++Usage:+Say you have the ring of 'Integer' numbers+and you want to add a transcendental element @x@,+that is an element, which does not allow for simplifications.+More precisely, for all positive integer exponents @n@+the power @x^n@ cannot be rewritten as a sum of powers with smaller exponents.+The element @x@ must be represented by the polynomial @[0,1]@.++In principle, you can have more than one transcendental element+by using polynomials whose coefficients are polynomials as well.+However, most algorithms on multi-variate polynomials+prefer a different (sparse) representation,+where the ordering of elements is not so fixed.++If you want division, you need "Number.Ratio"s+of polynomials with coefficients from a "Algebra.Field".++You can also compute with an algebraic element,+that is an element which satisfies an algebraic equation like+@x^3-x-1==0@.+Actually, powers of @x@ with exponents above @3@ can be simplified,+since it holds @x^3==x+1@.+You can perform these computations with "Number.ResidueClass" of polynomials,+where the divisor is the polynomial equation that determines @x@.+If the polynomial is irreducible+(in our case @x^3-x-1@ cannot be written as a non-trivial product)+then the residue classes also allow unrestricted division+(except by zero, of course).+That is, using residue classes of polynomials+you can work with roots of polynomial equations+without representing them by radicals+(powers with fractional exponents).+It is well-known, that roots of polynomials of degree above 4+may not be representable by radicals.+-}++module MathObj.Polynomial(T(..), fromCoeffs, showsExpressionPrec, const,+                  eval, compose, equal, add, sub, negate,+                  shift, unShift,+                  mul, scale, divMod,+                  tensorProduct, tensorProduct',+                  mulShear, mulShearTranspose,+                  horner, horner',+                  progression, differentiate, integrate, integrateInt,+                  fromRoots, alternate)+where++import qualified Algebra.Differential         as Differential+import qualified Algebra.VectorSpace          as VectorSpace+import qualified Algebra.Module               as Module+import qualified Algebra.Vector               as Vector+import qualified Algebra.Field                as Field+import qualified Algebra.PrincipalIdealDomain as PID+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.Indexable            as Indexable++import Algebra.Module((*>))+import Algebra.ZeroTestable(isZero)++import Control.Monad (liftM)+import qualified Data.List as List+import NumericPrelude.List+   (zipWithOverlap, dropWhileRev, shear, shearTranspose, outerProduct)++import Test.QuickCheck (Arbitrary(arbitrary,coarbitrary))++import qualified Prelude     as P98+import qualified PreludeBase as P+import qualified NumericPrelude as NP++import PreludeBase    hiding (const)+import NumericPrelude hiding (divMod, negate, stdUnit)++newtype T a = Cons {coeffs :: [a]}++fromCoeffs :: [a] -> T a+fromCoeffs = lift0++lift0 :: [a] -> T a+lift0 = Cons++lift1 :: ([a] -> [a]) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++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 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)++plusPrec, appPrec :: Int+plusPrec = 6+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons xs) =+    showParen (p >= appPrec) (showString "Polynomial.fromCoeffs " . shows xs)++showsExpressionPrec :: (Show a, ZeroTestable.C a, Additive.C a) =>+   Int -> String -> T a -> String -> String+showsExpressionPrec p var poly =+    if isZero poly+      then showString "0"+      else+        let terms = filter (not . isZero . fst)+                       (zip (coeffs poly) monomials)+            monomials = id :+                        showString "*" . showString var :+                        map (\k -> showString "*" . showString var+                                 . showString "^" . shows k)+                            [(2::Int)..]+            showsTerm x showsMon = showsPrec (plusPrec+1) x . showsMon+        in showParen (p > plusPrec)+           (foldl (.) id $ List.intersperse (showString " + ") $+            map (uncurry showsTerm) terms)++{- |+Horner's scheme for evaluating an polynomial+-}++horner' :: Ring.C a => a -> [a] -> a+horner' x = foldr (\c val -> c+x*val) zero++{-+***** Module types are more general,+but most times this flexibility is not needed and+let type inference fail.+-}++horner :: Module.C a b => a -> [b] -> b+horner x = foldr (\c val -> c+x*>val) zero++eval :: Module.C a b => T b -> a -> b+eval (Cons y) x = horner x y++{- |+'compose' is the functional composition of polynomials.++It fulfills+  @ eval x . eval y == eval (compose x y) @+-}++-- compose :: Module.C a b => T b -> T a -> T a+-- compose (Cons x) y = horner y (map const x)+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.+-}++normalize :: (ZeroTestable.C a) => [a] -> [a]+normalize = dropWhileRev isZero++{- |+Multiply by the variable, used internally.+-}++shift :: (Additive.C a) => [a] -> [a]+shift [] = []+shift l  = zero : l++unShift :: [a] -> [a]+unShift []     = []+unShift (_:xs) = xs++const :: a -> T a+const x = lift0 [x]++equal :: (Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool+equal x y = and (zipWithOverlap isZero isZero (==) x y)++instance (Eq a, ZeroTestable.C a) => Eq (T a) where+  (Cons x) == (Cons y) = equal x y++instance (Indexable.C a, ZeroTestable.C a) => Indexable.C (T a) where+  compare = Indexable.liftCompare coeffs++instance (ZeroTestable.C a) => ZeroTestable.C (T a) where+  isZero (Cons x) = isZero x+++add, sub :: (Additive.C a) => [a] -> [a] -> [a]+add = (+)+sub = (-)++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+++scale :: Ring.C a => a -> [a] -> [a]+scale s = map (s*)+++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = Vector.functorScale++instance (Module.C a b) => Module.C a (T b) where+   (*>) x = lift1 (x *>)++instance (Field.C a, Module.C a b) => VectorSpace.C a (T b)+++tensorProduct :: Ring.C a => [a] -> [a] -> [[a]]+tensorProduct = outerProduct (*)++tensorProduct' :: Ring.C a => [a] -> [a] -> [[a]]+tensorProduct' xs ys = map (flip scale ys) xs++{- |+'mul' is fast if the second argument is a short polynomial,+'MathObj.PowerSeries.**' relies on that fact.+-}++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)) []++mulShear :: Ring.C a => [a] -> [a] -> [a]+mulShear xs ys = map sum (shear (tensorProduct xs ys))++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+++divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a])+divMod x y =+    let (y0:ys) = dropWhile isZero (reverse y)+        aux l xs' =+          if l < 0+            then ([], xs')+            else+              let (x0:xs) = xs'+                  q0      = x0/y0+                  (d',m') = aux (l-1) (sub xs (scale q0 ys))+              in  (q0:d',m')+        (d, m) = aux (length x - length y) (reverse x)+    in  if isZero y+          then error "MathObj.Polynomial: division by zero"+          else (reverse d, reverse m)++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)++stdUnit :: (ZeroTestable.C a, Ring.C a) => [a] -> a+stdUnit x = case normalize x of+    [] -> one+    l  -> last l++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))++{-+Polynomials are a Euclidean domain, so no instance is necessary+(although it might be faster).+-}++instance (ZeroTestable.C a, Field.C a) => PID.C (T a)++progression :: Ring.C a => [a]+progression = iterate (one+) one++differentiate :: (Ring.C a) => [a] -> [a]+differentiate = zipWith (*) progression . tail++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.+-}+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+++fromRoots :: (Ring.C a) => [a] -> T a+fromRoots = Cons . foldl (flip mulLinearFactor) [1]++mulLinearFactor :: Ring.C a => a -> [a] -> [a]+mulLinearFactor x yt@(y:ys) = Additive.negate (x*y) : yt - scale x ys+mulLinearFactor _ [] = []++alternate :: Additive.C a => [a] -> [a]+alternate = zipWith ($) (cycle [id, Additive.negate])++{-+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+   coarbitrary = undefined+++{- * legacy instances -}++{- |+It is disputable whether polynomials shall be represented by number literals or not.+An advantage is, that one can write+let x = polynomial [0,1]+in  (x^2+x+1)*(x-1)+However the output looks much different.+-}+legacyInstance :: a+legacyInstance =+   error "legacy Ring.C instance for simple input of numeric literals"++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++instance (Field.C a, Eq a, Show a, ZeroTestable.C a) => P98.Fractional (T a) where+   fromRational = const . fromRational+   (/) = legacyInstance
+ src/MathObj/PowerSeries.hs view
@@ -0,0 +1,396 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}++{- |+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 Algebra.Differential   as Differential+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.VectorSpace    as VectorSpace+import qualified Algebra.Module         as Module+import qualified Algebra.Vector         as Vector+import qualified Algebra.Transcendental as Transcendental+import qualified Algebra.Algebraic      as Algebraic+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 Algebra.Module((*>))+import Algebra.ZeroTestable(isZero)++import NumericPrelude.List(splitAtMatch)+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)++newtype T a = Cons {coeffs :: [a]} deriving (Ord)++fromCoeffs :: [a] -> T a+fromCoeffs = lift0++lift0 :: [a] -> T a+lift0 = Cons++lift1 :: ([a] -> [a]) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a)+lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)++const :: a -> T a+const x = lift0 [x]++{-+Functor instance is e.g. useful for showing power series in residue rings.+@fmap (ResidueClass.concrete 7) (powerSeries [1,4,4::ResidueClass.T Integer] * powerSeries [1,5,6])@+-}++instance Functor T where+  fmap f (Cons xs) = Cons (map f xs)++appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons xs) =+    showParen (p >= appPrec) (showString "PowerSeries.fromCoeffs " . shows xs)+++truncate :: Int -> T a -> T a+truncate n = lift1 (take n)++{- |+Evaluate (truncated) power series.+-}++eval :: Module.C a b => [b] -> a -> b+eval = flip Poly.horner++evaluate :: Module.C a b => T b -> a -> b+evaluate (Cons y) = eval y++{- |+Evaluate approximations that is evaluated all truncations of the series.+-}++approx :: Module.C a b => [b] -> a -> [b]+approx y x =+   scanl (+) zero (zipWith (*>) (iterate (x*) 1) y)++approximate :: Module.C a b => T b -> a -> [b]+approximate (Cons y) = approx 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])+++{- * 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++instance (Additive.C a) => Additive.C (T a) where+    negate = lift1 Poly.negate+    (+)    = lift2 Poly.add+    (-)    = lift2 Poly.sub+    zero   = lift0 []++instance (Ring.C a) => Ring.C (T a) where+    one           = const one+    fromInteger n = const (fromInteger n)+    (*)           = lift2 mul++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = Vector.functorScale++instance (Module.C a b) => Module.C a (T b) where+    (*>) 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+++divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a],[a])+divMod xs ys =+   let (yZero,yRem) = span isZero ys+       (xMod, xRem) = splitAtMatch 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)+++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+++{- |+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)+                       (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)+   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)++{- |+It fulfills+  @ evaluate x . evaluate y == evaluate (compose x y) @+-}++compose :: (Ring.C a, ZeroTestable.C a) => T a -> T a -> T a+compose (Cons [])    (Cons []) = Cons []+compose (Cons (x:_)) (Cons []) = Cons [x]+compose (Cons x) (Cons (y:ys)) =+   if isZero y+     then Cons (comp 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.+-}++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)
+ src/MathObj/PowerSeries/DifferentialEquation.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Lazy evaluation allows for the solution+ of differential equations in terms of power series.+Whenever you can express the highest derivative of the solution+ as explicit expression of the lower derivatives+ where each coefficient of the solution series+ depends only on lower coefficients,+ the recursive algorithm will work.+-}++module MathObj.PowerSeries.DifferentialEquation where++import qualified MathObj.PowerSeries         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+++{- |+Example for a linear equation:+   Setup a differential equation for @y@ with++>    y   t = (exp (-t)) * (sin t)+>    y'  t = -(exp (-t)) * (sin t) + (exp (-t)) * (cos t)+>    y'' t = -2 * (exp (-t)) * (cos t)++Thus the differential equation++>    y'' = -2 * (y' + y)++holds.++The following function generates+a power series for @exp (-t) * sin t@+by solving the differential equation.+-}++solveDiffEq0 :: (Field.C a) => [a]+solveDiffEq0 =+   let -- the initial conditions are passed to "PS.integrate"+       y   = PS.integrate 0 y'+       y'  = PS.integrate 1 y''+       y'' = PS.scale (-2) (PS.add y' y)+   in  y++verifyDiffEq0 :: (Field.C a) => [a]+verifyDiffEq0 =+   PS.mul (zipWith (*) (iterate negate 1) PSE.exp) PSE.sin++propDiffEq0 :: Bool+propDiffEq0 =  solveDiffEq0 == (verifyDiffEq0 :: [Rational])+++{- |+We are not restricted to linear equations!+ Let the solution be y with+  y   t =   (1-t)^-1+  y'  t =   (1-t)^-2+  y'' t = 2*(1-t)^-3+ then it holds+  y'' = 2 * y' * y+-}++solveDiffEq1 :: (ZeroTestable.C a, Field.C a) => [a]+solveDiffEq1 =+   let -- the initial conditions are passed to "PS.integrate"+       y   = PS.integrate 1 y'+       y'  = PS.integrate 1 y''+       y'' = PS.scale 2 (PS.mul y' y)+   in  y++verifyDiffEq1 :: (ZeroTestable.C a, Field.C a) => [a]+verifyDiffEq1 = PS.divide [1] [1, -1]++propDiffEq1 :: Bool+propDiffEq1 =  solveDiffEq1 == (verifyDiffEq1 :: [Rational])
+ src/MathObj/PowerSeries/Example.hs view
@@ -0,0 +1,156 @@+{-# OPTIONS -fno-implicit-prelude #-}+module MathObj.PowerSeries.Example where++import qualified MathObj.PowerSeries 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 NumericPrelude.List (sieve)++import NumericPrelude (one, (*), (/),+                       fromInteger, {-fromRational,-} pi)+import PreludeBase -- (Bool, const, map, zipWith, id, (&&), (==))+++{- * Default implementations. -}++recip :: (Ring.C a) => [a]+recip = recipExpl++exp, sin, cos,+  log, asin, atan, sqrt :: (Field.C a) => [a]+acos :: (Transcendental.C a) => [a]+tan :: (ZeroTestable.C a, Field.C a) => [a]+exp = expODE+sin = sinODE+cos = cosODE+tan = tanExplSieve+log = logODE+asin = asinODE+acos = acosODE+atan = atanODE++sinh, cosh, atanh :: (Field.C a) => [a]+sinh  = sinhODE+cosh  = coshODE+atanh = atanhODE++pow :: (Field.C a) => a -> [a]+pow = powExpl+sqrt = sqrtExpl+++{- * Generate Taylor series explicitly. -}++recipExpl :: (Ring.C a) => [a]+recipExpl = cycle [1,-1]++expExpl, sinExpl, cosExpl :: (Field.C a) => [a]+expExpl = scanl (*) one PS.recipProgression+sinExpl = zero : PS.holes2alternate (tail expExpl)+cosExpl =        PS.holes2alternate       expExpl++tanExpl, tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a]+tanExpl = PS.divide sinExpl cosExpl+-- ignore zero values+tanExplSieve =+   concatMap+      (\x -> [zero,x])+      (PS.divide (sieve 2 (tail sin)) (sieve 2 cos))++logExpl, atanExpl, sqrtExpl :: (Field.C a) => [a]+logExpl  = zero : PS.alternate       PS.recipProgression+atanExpl = zero : PS.holes2alternate PS.recipProgression++sinhExpl, coshExpl, atanhExpl :: (Field.C a) => [a]+sinhExpl  = zero : PS.holes2 (tail expExpl)+coshExpl  =        PS.holes2       expExpl+atanhExpl = zero : PS.holes2 PS.recipProgression++{- * Power series of (1+x)^expon using the binomial series. -}++powExpl :: (Field.C a) => a -> [a]+powExpl expon =+   scanl (*) 1 (zipWith (/)+      (iterate (subtract 1) expon) PS.progression)+sqrtExpl = powExpl (1/2)++{- |+Power series of error function (almost).+More precisely @ erf = 2 \/ sqrt pi * integrate (\x -> exp (-x^2)) @,+with @erf 0 = 0@.+-}++erf :: (Field.C a) => [a]+erf = PS.integrate 0 $ intersperse 0 $ PS.alternate exp++{-+integrate (\x -> exp (-x^2/2)) :++erf = PS.integrate 0 $ intersperse 0 $+    snd $ mapAccumL (\twoPow c -> (twoPow/(-2), twoPow*c)) 1 exp+-}+++{- * Generate Taylor series from differential equations. -}++{-+exp' x == exp x+sin' x == cos x+cos' x == - sin x++tan' x == 1 + tan x ^ 2+       == cos x ^ (-2)+-}++expODE, sinODE, cosODE, tanODE, tanODESieve :: (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))+tanODESieve =+   -- sieve is too strict here because it wants to detect end of lists+   let tan2 = map head (iterate (drop 2) (tail tanODESieve))+   in  PS.integrate 0 (intersperse zero (1 : PS.mul tan2 tan2))++{-+log' (1+x) == 1/(1+x)+asin' x == acos' x == 1/sqrt(1-x^2)+atan' x == 1/(1+x^2)+-}++logODE, recipCircle, asinODE, atanODE, sqrtODE :: (Field.C a) => [a]+logODE  = PS.integrate zero recip+recipCircle = intersperse zero (PS.alternate (powODE (-1/2)))+asinODE = PS.integrate 0 recipCircle+atanODE = PS.integrate zero (cycle [1,0,-1,0])+sqrtODE = powODE (1/2)++acosODE :: (Transcendental.C a) => [a]+acosODE = PS.integrate (pi/2) recipCircle++sinhODE, coshODE, atanhODE :: (Field.C a) => [a]+sinhODE = PS.integrate 0 coshODE+coshODE = PS.integrate 1 sinhODE+atanhODE = PS.integrate zero (cycle [1,0])+++{-+Power series for y with+   y x = (1+x) ** alpha+by solving the differential equation+   alpha * y x = (1+x) * y' x+-}++powODE :: (Field.C a) => a -> [a]+powODE expon =+   let y  = PS.integrate 1 y'+       y' = PS.scale expon (scanl1 subtract y)+   in  y
+ src/MathObj/PowerSeries/Mean.hs view
@@ -0,0 +1,232 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+This module computes power series for+representing some means as generalized $f$-means.+-}+module MathObj.PowerSeries.Mean where++import qualified MathObj.PowerSeries2        as PS2+import qualified MathObj.PowerSeries         as PS+import qualified MathObj.PowerSeries.Example as PSE++import qualified Algebra.Field as Field+import qualified Algebra.Ring  as Ring++import NumericPrelude.List (shearTranspose)++import NumericPrelude+import PreludeBase++{-+$M_f$ is a generalized $f$-mean (quasi-arithmetic) if+\[M_f x = f^{ -1}\right(\frac{1}{n}\cdot\sum_{k=1}^{n} f(x_k)\left)\]++For instance there is the logarithmic mean+defined by+\[\frac{x-y}{\ln x - \ln y}\]+whose definition is inherently bound to two variables.+If we find a representation as a generalized $f$-mean+we can generalize this mean to more than two variables.++Btw. we can easily see that the logarithmic mean is not a quasi-arithmetic mean,+because \[ \anonymfunc{(a,b,c,d)}{L(L(a,b),L(c,d))} \]+is not commutative, but quasi-arithmetic means are always commutative.++First we note that an arbitrary constant offset and+an arbitrary scaling of $f$ does not alter the mean.+Therefore we choose $f(1)=0, f'(1)=1$+and we expand $f$ into a Taylor series with respect to 1.++For the logarithmic mean we will choose $y=0$.+This way we might get additional virtual solutions,+but we can identify them afterwards by a test.+\begin{eqnarray*}+f^{ -1}\left(\frac{f(1+x)+f(1+y)}{2}\right)+ &=& \frac{x-y}{\ln(1+x) - \ln(1+y)} \\+f^{ -1}\left(\frac{f(1+x)}{2}\right)+ &=& \frac{x}{\ln(1+x)} \\+f(1+x)+ &=& 2 \cdot f\left(\frac{x}{\ln(1+x)}\right)+\end{eqnarray*}+This cannot be solved immediately+because in the power series expansions on both sides+unknown coefficients occur at the same monomials.+We can resolve that by subtracting the series of $2\cdot f(1+x/2)$+off both sides.+\begin{eqnarray*}+f(1+x) - 2\cdot f(1+x/2)+ &=& 2 \cdot (f\left(\frac{x}{\ln(1+x)}\right) - f(1+x/2))+\end{eqnarray*}+We note that $1+x/2$ is the truncated series of $\frac{x}{\ln(1+x)}$.+This is also necessary in order to obtain an equation.++Now we have to derive an implementation of the right-hand side.+This is a difference of two series compositions, namely+$f(x+a*x^2+b*x^3+\dots) - f(x)$ .+The implementation takes care that the vanishing terms are not computed+and thus allows solution of series fixed point equations.+It is just done by throwing away the leading terms of all powers+of the series $x+a*x^2+b*x^3+\dots$.+In $x$ the constant monomial is omitted,+in the result both the constant and the linear term are omitted.+-}++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])))))++{-+Now we solve+\[+\frac{1}{2}\cdot f(1+2\cdot x) - f(1+x)+ &=& f\left(\frac{2\cdot x}{\ln(1+2\cdot x)}\right) - f(1+x)+\]+-}++logarithmic :: (Field.C a) => [a]+logarithmic =+   let -- series for \frac{2\cdot x}{\ln(1+2\cdot x)}+       fracLn = PS.divide [2]+                      (tail (zipWith (*) (iterate (2*) 1) PSE.log))+       fDiffFracLn = diffComp f (tail fracLn)+       f = 0 : 1 : zipWith (/) fDiffFracLn+                      (map (subtract 1) (iterate (2*) 2))+   in  f++elemSym3_2 :: (Field.C a) => [a]+elemSym3_2 =+   let -- series for \frac{2\cdot x}{\ln(1+2\cdot x)}+       root = zipWith (*) (iterate (2*) 1) PSE.sqrt+       fDiffRoot = diffComp f (tail root)+       f = 0 : 1 : zipWith (/) fDiffRoot+                      (map (subtract 1) (iterate (3*) 3))+   in  f+++{-+Means constructed by mean value theorem.++\[ M(x,y) = f'^{ -1}((f(x)-f(y))/(x-y)) \]++\[ f(x) = x^2  \implies M - arithmetic mean \]+\[ f(x) = 1/x  \implies M - geometric mean \]++Try to find a power series for $f$ for $M(x,y) = \sqrt{(x^2+y^2)/2}$+(quadratic mean).+Expansion point: 1.+$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]++quadraticMVF :: (Field.C a) => [a]+quadraticMVF =+   -- [1,1,1,1,1/2,3/23,2/143]+   -- [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)++{-+Result: It seems,+that we cannot find an appropriate coefficient for the 5th power.+This indicates that it is not possible to represent+the quadratic mean as mean value mean.+-}++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+       {- instead of computing an inverse series+          we could also apply (compose) the derived series+          to the series of the quadratic mean. -}+   in  quadratic - meanValuePS++{-+Represent quadratic mean with a two-variate power series.++$M(1+x,1+y) = \sqrt{1+x+y+(x^2+y^2)/2}$+-}+quadratic2 :: (Field.C a, Eq a) => PS2.Core a+quadratic2 =+   PS2.sqrt (\1 -> 1) [[1],[1,1],[1/2,0,1/2]]++quadraticDiff2 :: (Field.C a, Eq a) => PS2.Core a+quadraticDiff2 =+   meanValueDiff2 quadratic2 quadraticMVF++++{-+We can alter the square coefficient,+but consequently we have to scale the sub-sequent coefficients.+If the square coefficient is zero then the equation is fulfilled,+but this is a non-solution because it is degenerate.+-}+harmonicMVF :: (Field.C a) => [a]+harmonicMVF =+   -- [1,1,1,-2,7/2,-62/11]+   -- [1,1,2,-4,7,-124/11]+   [1,1,3,-6,21/2,-186/11]++{-+$M(1+x,1+y) = 2/(recip (1+x) + recip (1+y))$+-}+harmonic2 :: (Field.C a, Eq a) => PS2.Core a+harmonic2 =+   let rec = PS.fromCoeffs PSE.recip+   in  PS2.divide [[2]] $+       PS2.coeffs $+          PS2.fromPowerSeries0 rec ++          PS2.fromPowerSeries1 rec++harmonicDiff2 :: (Field.C a, Eq a) => PS2.Core a+harmonicDiff2 =+   meanValueDiff2 harmonic2 harmonicMVF++++arithmeticMVF :: (Field.C a) => [a]+arithmeticMVF = [1,2,1]++{-+$M(1+x,1+y) = 1+x/2+y/2$+-}+arithmetic2 :: (Field.C a, Eq a) => PS2.Core a+arithmetic2 = [[1],[1/2,1/2]]++arithmeticDiff2 :: (Field.C a, Eq a) => PS2.Core a+arithmeticDiff2 =+   meanValueDiff2 arithmetic2 arithmeticMVF+++geometricMVF :: (Field.C a) => [a]+geometricMVF = PSE.recip++{-+$M(1+x,1+y) = \sqrt{(1+x)·(1+y)}$+-}+geometric2 :: (Field.C a, Eq a) => PS2.Core a+geometric2 =+   PS2.sqrt (\1 -> 1) [[1],[1,1],[0,1,0]]++geometricDiff2 :: (Field.C a, Eq a) => PS2.Core a+geometricDiff2 =+   meanValueDiff2 geometric2 geometricMVF+++++meanValueDiff2 :: (Field.C a, Eq a) =>+   PS2.Core a -> [a] -> PS2.Core 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)+   in  meanValuePS - divDiffPS
+ src/MathObj/PowerSeries2.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}++{- |+Two-variate power series.+-}++module MathObj.PowerSeries2 where++import qualified MathObj.PowerSeries    as PS+import qualified MathObj.Polynomial     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+import qualified Algebra.Ring           as Ring+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 NumericPrelude.List (compareLength)++import PreludeBase    hiding (const)+import NumericPrelude hiding (negate, stdUnit,+                              sqrt, exp, log,+                              sin, cos, tan, asin, acos, atan)++{- |+In order to handle both variables equivalently+we maintain a list of coefficients for terms of the same total degree.+That is++> eval [[a], [b,c], [d,e,f]] (x,y) ==+>    a + b*x+c*y + d*x^2+e*x*y+f*y^2++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)++type Core a = [[a]]++isValid :: [[a]] -> Bool+isValid = flip isPrefixOf [1..] . map length++check :: [[a]] -> [[a]]+check xs =+   zipWith (\n x ->+      if compareLength n x == EQ+        then x+        else error "PowerSeries2.check: invalid length of sub-list")+     (iterate (():) [()]) xs+++fromCoeffs :: [[a]] -> T a+fromCoeffs  =  Cons . check++fromPowerSeries0 :: Ring.C a => PS.T a -> T a+fromPowerSeries0 x =+   fromCoeffs $+   zipWith (:) (PS.coeffs x) $+   iterate (0:) []++fromPowerSeries1 :: Ring.C a => PS.T a -> T a+fromPowerSeries1 x =+   fromCoeffs $+   zipWith (++) (iterate (0:) []) $+   map (:[]) (PS.coeffs x)+++lift0 :: Core a -> T a+lift0 = Cons++lift1 :: (Core a -> Core 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 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]]+++instance Functor T where+  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+++instance (Eq a, ZeroTestable.C a) => Eq (T a) where+    (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 []+++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++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = 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)+++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
+ src/MathObj/PowerSum.hs view
@@ -0,0 +1,231 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2004-2005++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++For a multi-set of numbers,+we describe a sequence of the sums of powers of the numbers in the set.+These can be easily converted to polynomials and back.+Thus they provide an easy way for computations on the roots of a polynomial.+-}+module MathObj.PowerSum where++import qualified MathObj.Polynomial  as Poly+import qualified MathObj.PowerSeries as PS++import qualified Algebra.VectorSpace  as VectorSpace+import qualified Algebra.Module       as Module+import qualified Algebra.Algebraic    as Algebraic+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 Algebra.Module((*>))++import Control.Monad(liftM2)+import qualified Data.List as List+import NumericPrelude.List (shearTranspose, sieve)++import PreludeBase as P hiding (const)+import NumericPrelude as NP+++newtype T a = Cons {sums :: [a]}+++{- * Conversions -}++lift0 :: [a] -> T a+lift0 = Cons++lift1 :: ([a] -> [a]) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a)+lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)+++const :: (Ring.C a) => a -> T a+const x = Cons [1,x]++{- Newton-Girard formulas,  cf. Modula-3: arithmetic/RootBasic.mg+   s'/s = p -}++{-+  s[k] - the elementary symmetric polynomial of degree k+  p[k] - sum of the k-th power++  s[0](x0,x1,x2) = 1+  s[1](x0,x1,x2) = x0+x1+x2+  s[2](x0,x1,x2) = x0*x1+x1*x2+x2*x0+  s[3](x0,x1,x2) = x0*x1*x2+  s[4](x0,x1,x2) = 0++  p[0](x0,x1,x2) =  1   +  1   +  1+  p[1](x0,x1,x2) = x0   + x1   + x2+  p[2](x0,x1,x2) = x0^2 + x1^2 + x2^2+  p[3](x0,x1,x2) = x0^3 + x1^3 + x2^3+  p[4](x0,x1,x2) = x0^4 + x1^4 + x2^4++  s(t) := s[0] + s[1]*t + s[2]*t^2 + ...+  p(t) :=        p[1]*t + p[2]*t^2 + ...++  Then it holds+    t*s'(t) + p(-t)*s(t) = 0+  This can be proven by considering p as sum of geometric series+  and differentiating s in the root-wise factored form.++  Note that we index the coefficients the other way round+  and that the coefficients of the polynomial+  are not pure elementary symmetric polynomials of the roots+  but have alternating signs, too.+-}+fromElemSym :: (Eq a, Ring.C a) => [a] -> [a]+fromElemSym s =+   fromIntegral (length s - 1) :+      Poly.alternate (divOneFlip s (Poly.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)+       aux [] = []+   in  aux+divOneFlip _ =+   error "divOneFlip: first element must be one"++fromElemSymDenormalized :: (Field.C a, ZeroTestable.C a) => [a] -> [a]+fromElemSymDenormalized s =+   fromIntegral (length s - 1) :+      Poly.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'+   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'+   in  s++++fromPolynomial :: (Field.C a, ZeroTestable.C a) => Poly.T a -> [a]+fromPolynomial =+   let aux s =+          fromIntegral (length s - 1) :+             Poly.negate (PS.derivedLog s)+   in  aux . reverse . Poly.coeffs++elemSymFromPolynomial :: Additive.C a => Poly.T a -> [a]+elemSymFromPolynomial = Poly.alternate . reverse . Poly.coeffs++{- toPolynomial is not possible because this had to consume the whole sum sequence. -}++++binomials :: Ring.C a => [[a]]+binomials = [1] : binomials + map (0:) binomials++{- * Show -}++appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons xs) =+    showParen (p >= appPrec)+       (showString "PowerSum.Cons " . shows xs)+++{- * Additive -}++{- Use binomial expansion of (x+y)^n -}+add :: (Ring.C a) => [a] -> [a] -> [a]+add xs ys =+   let powers = shearTranspose (Poly.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+++{- * Ring -}++mul :: (Ring.C a) => [a] -> [a] -> [a]+mul xs ys = zipWith (*) xs ys++pow :: Integer -> [a] -> [a]+pow n =+   if n<0+     then error "PowerSum.pow: negative exponent"+     else sieve (fromInteger n)+       -- map head . iterate (List.genericDrop (toInteger n))++instance (Ring.C a) => Ring.C (T a) where+   one           = const one+   fromInteger n = const (fromInteger n)+   (*)           = lift2 mul+   x^n           = lift1 (pow n) x+++{- * Module -}++instance (Module.C a v, Ring.C v) => Module.C a (T v) where+   x *> y = lift1 (zipWith (*>) (iterate (x*) one)) y++instance (VectorSpace.C a v, Ring.C v) => VectorSpace.C a (T v)+++{- * Field.C -}++instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where+   recip = lift1 (fromElemSymDenormalized . reverse . toElemSym)+++{- * Algebra -}++root :: (Ring.C a) => Integer -> [a] -> [a]+root n xs =+   let upsample m ys =+          concat (List.intersperse+             (List.genericReplicate (m - 1) zero)+             (map (:[]) ys))+   in  case compare n 0 of+          LT -> upsample (-n) (reverse xs)+          GT -> upsample n xs+          EQ -> [1]++instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where+   root n = lift1 (fromElemSymDenormalized . root n . toElemSym)+++{- given the list of power sums @x1^j + ... + xn^j@+   and a power series for the function @f@,+   compute the series approximations of @f(x1) + ... + f(xn)@. -}+approxSeries :: Module.C a b => [b] -> [a] -> [b]+approxSeries y x =+   scanl (+) zero (zipWith (*>) x y)+++{- input lists contain roots -}+propOp :: (Eq a, Field.C a, ZeroTestable.C a) =>+   ([a] -> [a] -> [a]) -> (a -> a -> a) -> [a] -> [a] -> [Bool]+propOp powerOp op xs ys =+   let zs = liftM2 op xs ys+       xp = fromPolynomial (Poly.fromRoots xs)+       yp = fromPolynomial (Poly.fromRoots ys)+       ze = elemSymFromPolynomial (Poly.fromRoots zs)+   in  zipWith (==) (toElemSym (powerOp xp yp)) ze+       -- Poly.equal (toElemSym (powerOp xp yp)) ze
+ src/MathObj/RootSet.hs view
@@ -0,0 +1,170 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2004-2005++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Computations on the set of roots of a polynomial.+These are represented as the list of their elementar symmetric terms.+The difference between a polynomial and the list of elementar symmetric terms+is the reversed order and the alternated signs.++Cf. /MathObj.PowerSum/ .+-}+module MathObj.RootSet where++import qualified MathObj.Polynomial  as Poly+import qualified MathObj.PowerSum    as PowerSum++import qualified Algebra.Algebraic    as Algebraic+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.ZeroTestable as ZeroTestable++import NumericPrelude.List (takeMatch)+import Control.Monad (liftM2)++import PreludeBase as P hiding (const)+import NumericPrelude as NP+++newtype T a = Cons {coeffs :: [a]}+++{- * Conversions -}++lift0 :: [a] -> T a+lift0 = Cons++lift1 :: ([a] -> [a]) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a)+lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)+++const :: (Ring.C a) => a -> T a+const x = Cons [1,x]+++toPolynomial :: Poly.T a -> T a+toPolynomial (Poly.Cons xs) = Cons (reverse xs)++fromPolynomial :: T a -> Poly.T a+fromPolynomial (Cons xs) = Poly.Cons (reverse xs)++++toPowerSums :: (Field.C a, ZeroTestable.C a) => [a] -> [a]+toPowerSums = PowerSum.fromElemSymDenormalized++fromPowerSums :: (Field.C a, ZeroTestable.C a) => [a] -> [a]+fromPowerSums = PowerSum.toElemSym+++{- | cf. 'MathObj.Polynomial.mulLinearFactor' -}+addRoot :: Ring.C a => a -> [a] -> [a]+addRoot x yt@(y:ys) =+   y : (ys + Poly.scale x yt)+addRoot _ [] =+   error "addRoot: list of elementar symmetric terms must consist at least of a 1"++fromRoots :: Ring.C a => [a] -> [a]+fromRoots = foldl (flip addRoot) [1]++++liftPowerSum1Gen :: ([a] -> [a]) -> ([a] -> [a]) ->+   ([a] -> [a]) -> ([a] -> [a])+liftPowerSum1Gen fromPS toPS op x =+   takeMatch x (fromPS (op (toPS x)))++liftPowerSum2Gen :: ([a] -> [a]) -> ([a] -> [a]) ->+   ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a])+liftPowerSum2Gen fromPS toPS op x y =+   takeMatch (undefined : liftM2 (,) (tail x) (tail y))+             (fromPS (op (toPS x) (toPS y)))+++liftPowerSum1 :: (Field.C a, ZeroTestable.C a) =>+   ([a] -> [a]) -> ([a] -> [a])+liftPowerSum1 = liftPowerSum1Gen fromPowerSums toPowerSums++liftPowerSum2 :: (Field.C a, ZeroTestable.C a) =>+   ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a])+liftPowerSum2 = liftPowerSum2Gen fromPowerSums toPowerSums++liftPowerSumInt1 :: (Integral.C a, Eq a, ZeroTestable.C a) =>+   ([a] -> [a]) -> ([a] -> [a])+liftPowerSumInt1 = liftPowerSum1Gen PowerSum.toElemSymInt PowerSum.fromElemSym++liftPowerSumInt2 :: (Integral.C a, Eq a, ZeroTestable.C a) =>+   ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a])+liftPowerSumInt2 = liftPowerSum2Gen PowerSum.toElemSymInt PowerSum.fromElemSym+++++{- * Show -}++appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+  showsPrec p (Cons xs) =+    showParen (p >= appPrec)+       (showString "RootSet.Cons " . shows xs)+++{- * Additive -}++{- Use binomial expansion of (x+y)^n -}+add :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -> [a]+add = liftPowerSum2 PowerSum.add++addInt :: (Integral.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> [a]+addInt = liftPowerSumInt2 PowerSum.add++instance (Field.C a, ZeroTestable.C a) => Additive.C (T a) where+   zero   = const zero+   (+)    = lift2 add+   negate = lift1 Poly.alternate+++{- * Ring -}++mul :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -> [a]+mul = liftPowerSum2 PowerSum.mul++mulInt :: (Integral.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> [a]+mulInt = liftPowerSumInt2 PowerSum.mul+++pow :: (Field.C a, ZeroTestable.C a) => Integer -> [a] -> [a]+pow n = liftPowerSum1 (PowerSum.pow n)++powInt :: (Integral.C a, Eq a, ZeroTestable.C a) => Integer -> [a] -> [a]+powInt n = liftPowerSumInt1 (PowerSum.pow n)+++instance (Field.C a, ZeroTestable.C a) => Ring.C (T a) where+   one           = const one+   fromInteger n = const (fromInteger n)+   (*)           = lift2 mul+   x^n           = lift1 (pow n) x+++{- * Field.C -}++instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where+   recip = lift1 reverse+++{- * Algebra -}++instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where+   root n = lift1 (PowerSum.root n)
+ src/MyPrelude.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS -fno-implicit-prelude #-}+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
@@ -0,0 +1,467 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Module      :  Number.Complex+Copyright   :  (c) The University of Glasgow 2001+License     :  BSD-style (see the file libraries/base/LICENSE)++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable (?)++Complex numbers.+-}++module Number.Complex+	(+	-- * Cartesian form+	  T(real,imag)+        , fromReal++	, (+:)+	, (-:)+	-- * Polar form+	, fromPolar+	, cis+        , signum+	, toPolar+	, magnitude+	, phase+        , Polar+	, defltMagnitude+	, defltPhase+	-- * Conjugate+	, conjugate++        -- * Properties+        , propPolar++        -- * Auxiliary classes+        , Divisible(divide)+        , defltDiv+        , Power(power)+        , 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.VectorSpace        as VectorSpace+import qualified Algebra.Module             as Module+import qualified Algebra.Vector             as Vector+import qualified Algebra.RealTranscendental as RealTrans+import qualified Algebra.Transcendental     as Trans+import qualified Algebra.Algebraic          as Algebraic+import qualified Algebra.Field              as Field+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.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 qualified Prelude as P+import PreludeBase+import NumericPrelude hiding (signum)+import NumericPrelude.Text (showsInfixPrec, readsInfixPrec)+++-- import qualified Data.Typeable as Ty++infix  6  +:, `Cons`++{- * The Complex type -}++-- | Complex numbers are an algebraic type.+data T a+  = Cons {real :: !a   -- ^ real part+         ,imag :: !a   -- ^ imaginary part+         }+  deriving (Eq)++fromReal :: Additive.C a => a -> T a+fromReal x = Cons x zero+++plusPrec :: Int+plusPrec = 6++instance (Show a) => Show (T a) where+   showsPrec prec (Cons x y) = showsInfixPrec "+:" plusPrec prec x y++instance (Read a) => Read (T a) where+   readsPrec prec = readsInfixPrec "+:" plusPrec prec (+:)++++{- * Functions -}++-- | Construct a complex number from real and imaginary part.+(+:) :: a -> a -> T a+(+:) = Cons++-- | Construct a complex number with negated imaginary part.+(-:) :: Additive.C a => a -> a -> T a+(-:) x y = Cons x (-y)++-- | The conjugate of a complex number.+{-# SPECIALISE conjugate :: T Double -> T Double #-}+conjugate	 :: (Additive.C a) => T a -> T a+conjugate (Cons x y) =  Cons x (-y)++-- | Scale a complex number by a real number.+{-# SPECIALISE scale :: Double -> T Double -> T Double #-}+scale		 :: (Ring.C a) => a -> T a -> T a+scale r (Cons x y) =  Cons (r * x) (r * y)++-- | Turn the point one quarter to the right.+orthoRight, orthoLeft :: (Additive.C a) => T a -> T a+orthoRight (Cons x y) = Cons   y  (-x)+orthoLeft  (Cons x y) = Cons (-y)   x++{- | 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.+-}+{-# SPECIALISE signum :: T Double -> T Double #-}+signum :: (Algebraic.C a, NormedEuc.C a a, ZeroTestable.C a) => T a -> T a+signum z =+   if isZero z+     then zero+     else scale (recip (NormedEuc.norm z)) z++-- | Form a complex number from polar components of magnitude and phase.+{-# SPECIALISE fromPolar :: Double -> Double -> T Double #-}+fromPolar		 :: (Trans.C a) => a -> a -> T a+fromPolar r theta	 =  scale r (cis theta)++-- | @'cis' t@ is a complex value with magnitude @1@+-- and phase @t@ (modulo @2*'pi'@).+{-# SPECIALISE cis :: Double -> T Double #-}+cis		 :: (Trans.C a) => a -> T a+cis theta	 =  Cons (cos theta) (sin theta)++propPolar :: (Polar a, RealTrans.C a) => T a -> Bool+propPolar z  =  uncurry fromPolar (toPolar z) == z+++-- | The nonnegative magnitude of a complex number.+floatMagnitude :: (P.RealFloat a, Algebraic.C a) => T a -> a+floatMagnitude (Cons x y) =  P.scaleFloat k+		     (sqrt (P.scaleFloat mk x ^ 2 ++                            P.scaleFloat mk y ^ 2))+		    where k  = max (P.exponent x) (P.exponent y)+		          mk = - k++defltMagnitude :: (Algebraic.C a) => T a -> a+defltMagnitude = sqrt . defltMagnitudeSqr++-- like NormedEuc.normSqr with lifted class constraints+defltMagnitudeSqr :: (Ring.C a) => T a -> a+defltMagnitudeSqr (Cons x y) = x^2 + y^2++-- | The phase of a complex number, in the range @(-'pi', 'pi']@.+-- If the magnitude is zero, then so is the phase.+defltPhase :: (RealTrans.C a, ZeroTestable.C a) => T a -> a+defltPhase z =+   if isZero z+     then zero   -- SLPJ July 97 from John Peterson+     else case z of (Cons x y) -> atan2 y x+++{- |+Minimal implementation: toPolar or (magnitude and phase),+usually the instance definition++@+magnitude = defltMagnitude+phase     = defltPhase+@++is enough.++This class requires transcendent number types+although 'magnitude' can be computed algebraically.+-}+class RealTrans.C a => Polar a where+   {- |+   The function 'toPolar' takes a complex number and+   returns a (magnitude, phase) pair in canonical form:+   the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@;+   if the magnitude is zero, then so is the phase.+   -}+   {--# SPECIALISE toPolar :: T Double -> (Double,Double) #--}+   toPolar   :: T a -> (a,a)+   toPolar z = (magnitude z, phase z)++   {--# SPECIALISE magnitude :: T Double -> Double #--}+   magnitude :: T a -> a+   magnitude = fst . toPolar++   {--# SPECIALISE phase :: T Double -> Double #--}+   phase     :: T a -> a+   phase     = snd . toPolar++instance Polar Float where+   magnitude = floatMagnitude+   phase     = defltPhase++instance Polar Double where+   magnitude = floatMagnitude+   phase     = defltPhase++++{- * Instances of T -}++{-+complexTc = Ty.mkTyCon "Complex.T"+instance Ty.Typeable1 T where { typeOf1 _ = Ty.mkTyConApp complexTc [] }+instance Ty.Typeable a => Ty.Typeable (T a) where { typeOf = Ty.typeOfDefault }+-}++instance  (Indexable.C a) => Indexable.C (T a) where+    compare (Cons x y) (Cons x' y')  =  Indexable.compare (x,y) (x',y')++instance  (ZeroTestable.C a) => ZeroTestable.C (T a)  where+    isZero (Cons x y)  = isZero x && isZero y++instance  (Additive.C a) => Additive.C (T a)  where+    {-# SPECIALISE instance Additive.C (T Float) #-}+    {-# SPECIALISE instance Additive.C (T Double) #-}+    zero			=  Cons zero zero+    (Cons x y) + (Cons x' y')	=  Cons (x+x') (y+y')+    (Cons x y) - (Cons x' y')	=  Cons (x-x') (y-y')+    negate (Cons x y)		=  Cons (negate x) (negate y)++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+    (Cons x y) * (Cons x' y')	=  Cons (x*x'-y*y') (x*y'+y*x')+    fromInteger			=  fromReal . fromInteger++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = scale++-- | The '(*>)' method can't replace 'scale'+--   because it requires the Algebra.Module constraint+instance (Module.C a b) => Module.C a (T b) where+   s *> (Cons x y)  = Cons (s *> x) (s *> y)++instance (VectorSpace.C a b) => VectorSpace.C a (T b)++instance (Additive.C a, NormedSum.C a v) => NormedSum.C a (T v) where+   norm x = NormedSum.norm (real x) + NormedSum.norm (imag x)++instance (NormedEuc.Sqr a b) => NormedEuc.Sqr a (T b) where+   normSqr x = NormedEuc.normSqr (real x) + NormedEuc.normSqr (imag x)++instance (Algebraic.C a, NormedEuc.Sqr a b) => NormedEuc.C a (T b) where+   norm = NormedEuc.defltNorm++instance (Ord a, NormedMax.C a v) => NormedMax.C a (T v) where+   norm x = max (NormedMax.norm (real x)) (NormedMax.norm (imag x))+++{-+  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.+  The magnitude of the remainder might be larger than that of the divisor+  thus the Euclidean algorithm can fail.+-}++instance  (Integral.C a) => Integral.C (T a)  where+    divMod z z' =+       let denom = defltMagnitudeSqr z'+           zBig  = z * conjugate z'+           re    = divMod (real zBig) denom+           im    = divMod (imag zBig) denom+           q     = Cons (fst re) (fst im)+       in  (q, z-q*z')+++{-+  This variant of divMod tries to come close to the origin.+  Thus the remainder has smaller magnitude than the divisor.+  This variant of divModCent can be used for Euclidean's algorithm.+-}+divModCent :: (Ord a, Integral.C a) => T a -> T a -> (T a, T a)+divModCent z z' =+   let denom = defltMagnitudeSqr z'+       zBig  = z * conjugate z'+       re    = divMod (real zBig) denom+       im    = divMod (imag zBig) denom+       q  = Cons (fst re) (fst im)+       r  = Cons (snd re) (snd im)+       q' = Cons+              (real q + if 2 * real r > denom then one else zero)+              (imag q + if 2 * imag r > denom then one else zero)+   in  (q', z-q'*z')++modCent :: (Ord a, Integral.C a) => T a -> T a -> T a+modCent z z' = snd (divModCent z z')++instance  (Ord a, Units.C a) => Units.C (T a)  where+    isUnit (Cons x y) =+       isUnit x && y==zero  ||+       isUnit y && x==zero+    stdAssociate z@(Cons x y) =+       let z' = if y<0  ||  y==0 && x<0 then negate z else z+       in  if real z'<=0 then orthoRight z' else z'+    stdUnit z@(Cons x y) =+       if z==zero+         then 1+         else+           let (x',sgn') = if y<0  ||  y==0 && x<0+                             then (negate x, -1)+                             else (x, 1)+           in  if x'<=0 then orthoLeft sgn' else sgn'+++instance  (Ord a, ZeroTestable.C a, Units.C a) => PID.C (T a) where+   gcd         = euclid modCent+   extendedGCD = extendedEuclid divModCent+++defltDiv :: (Field.C a) => T a -> T a -> T a+defltDiv (Cons x y) z'@(Cons x' y') =+   let d = defltMagnitudeSqr z'+   in  Cons ((x*x'+y*y') / d) ((y*x'-x*y') / d)++-- | Special implementation of @(\/)@ for floating point numbers+--   which prevent intermediate overflows.+floatDiv :: (P.RealFloat a, Field.C a) => T a -> T a -> T a+floatDiv (Cons x y) (Cons x' y') =+   let k   = - max (P.exponent x') (P.exponent y')+       x'' = P.scaleFloat k x'+       y'' = P.scaleFloat k y'+       d   = x'*x'' + y'*y''+   in  Cons ((x*x''+y*y'') / d) ((y*x''-x*y'') / d)++{-|+   In order to have an efficient implementation+   for both complex floats and exact complex numbers,+   we define the intermediate class Complex.Divisible+   which in fact implements the complex division.+   This way we avoid overlapping and undecidable instances.+   In most cases it should suffice to define+   an instance of Complex.Divisible with no method implementation+   for each instance of Fractional.+-}+class (Field.C a) => Divisible a where+    divide :: T a -> T a -> T a+    divide  =  defltDiv++instance  Divisible Float  where+    divide  =  floatDiv++instance  Divisible Double  where+    divide  =  floatDiv++instance  (PID.C a) => Divisible (Ratio.T a)+++instance  (Divisible a) => Field.C (T a)  where+    (/)			=  divide+    fromRational'	=  fromReal . fromRational'++{-|+   We like to build the Complex Algebraic instance+   on top of the Algebraic instance of the scalar type.+   This poses no problem to 'sqrt'.+   However, 'Number.Complex.root' requires computing the complex argument+   which is a transcendent operation.+   In order to keep the type class dependencies clean+   for more sophisticated algebraic number types,+   we introduce a type class which actually performs the radix operation.+-}+class (Algebraic.C a) => (Power a) where+    power  ::  Rational -> T a -> T a+++defltPow :: (Polar a, RealTrans.C a) =>+    Rational -> T a -> T a+defltPow r x =+    let (mag,arg) = toPolar x+    in  fromPolar (mag ^/ r)+                  (arg * fromRational' r)+++instance  Power Float where+    power  =  defltPow++instance  Power Double where+    power  =  defltPow+++instance  (Polar a, Real.C a, Algebraic.C a, Divisible a, Power a) =>+          Algebraic.C (T a)  where+    sqrt z@(Cons x y)  =  if z == zero+                            then zero+                            else+                              let v'    = abs y / (u'*2)+                                  u'    = sqrt ((magnitude z + abs x) / 2)+                                  (u,v) = if x < 0 then (v',u') else (u',v')+                              in  Cons u (if y < 0 then -v else v)+    (^/) = flip power+++instance  (Polar a, Real.C a, RealTrans.C a, Divisible a, Power a) =>+          Trans.C (T a)  where+    {-# SPECIALISE instance Trans.C (T Float) #-}+    {-# SPECIALISE instance Trans.C (T Double) #-}+    pi                 =  fromReal pi+    exp (Cons x y)     =  scale (exp x) (cis y)+    log z              =  let (m,p) = toPolar z in Cons (log m) p++    -- use defaults for tan, tanh++    sin (Cons x y)     =  Cons (sin x * cosh y) (  cos x * sinh y)+    cos (Cons x y)     =  Cons (cos x * cosh y) (- sin x * sinh y)++    sinh (Cons x y)    =  Cons (cos y * sinh x) (sin y * cosh x)+    cosh (Cons x y)    =  Cons (cos y * cosh x) (sin y * sinh x)++    asin z             =  orthoRight (log (orthoLeft z + sqrt (1 - z^2)))+    acos z             =  orthoRight (log (z + orthoLeft (sqrt (1 - z^2))))+    atan z@(Cons x y)  =  orthoRight (log (Cons (1-y) x / sqrt (1+z^2)))++{- use the default implementation+    asinh z        =  log (z + sqrt (1+z^2))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z^2))+-}+++{- * legacy instances -}++legacyInstance :: a+legacyInstance =+   error "legacy Ring.C instance for simple input of numeric literals"++instance (Ring.C a, Eq a, Show a) => P.Num (T a) where+   fromInteger = fromReal . fromInteger+   negate = negate -- for unary minus+   (+)    = legacyInstance+   (*)    = legacyInstance+   abs    = legacyInstance+   signum = legacyInstance++instance (Ring.C a, Eq a, Show a, Divisible a) => P.Fractional (T a) where+   fromRational = fromRational+   (/) = legacyInstance
+ src/Number/DimensionTerm.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable+++See "Algebra.DimensionTerm".+-}++module Number.DimensionTerm where++import qualified Algebra.DimensionTerm as Dim++import qualified Algebra.OccasionallyScalar as OccScalar+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.Ring          as Ring+import qualified Algebra.Additive      as Additive++import Algebra.Additive ((+), (-), zero, negate, )+import Algebra.Module ((*>), )++import System.Random (Random, randomR, random)++import PreludeBase+import Prelude ()+++{- * Number type -}++newtype T u a = Cons a+   deriving (Eq, Ord)+++instance (Dim.C u, Show a) => Show (T u a) where+   showsPrec p x =+      let disect :: T u a -> (u,a)+          disect (Cons y) = (undefined, y)+          (u,z) = disect x+      in  showParen (p >= Dim.appPrec)+            (showString "DimensionNumber.fromNumberWithDimension " . showsPrec Dim.appPrec u .+             showString " " . showsPrec Dim.appPrec z)+++fromNumber :: a -> Scalar a+fromNumber = Cons++toNumber :: Scalar a -> a+toNumber (Cons x) = x++fromNumberWithDimension :: Dim.C u => u -> a -> T u a+fromNumberWithDimension _ = Cons++toNumberWithDimension :: Dim.C u => u -> T u a -> a+toNumberWithDimension _ (Cons x) = x+++instance (Dim.C u, Additive.C a) => Additive.C (T u a) where+   zero                = Cons zero+   (Cons a) + (Cons b) = Cons (a+b)+   (Cons a) - (Cons b) = Cons (a-b)+   negate (Cons a)     = Cons (negate a)++instance (Dim.C u, Module.C a b) => Module.C a (T u b) where+   a *> (Cons b) = Cons (a *> b)++instance (OccScalar.C a b) => OccScalar.C a (Scalar b) where+   toScalar = OccScalar.toScalar . toNumber+   toMaybeScalar = OccScalar.toMaybeScalar . toNumber+   fromScalar = fromNumber . OccScalar.fromScalar++mapFst :: (a -> c) -> (a,b) -> (c,b)+mapFst f ~(x,y) = (f x, y)++instance (Dim.C u, Random a) => Random (T u a) where+  randomR (Cons l, Cons u) = mapFst Cons . randomR (l,u)+  random = mapFst Cons . random+++infixl 7 &*&, *&+infixl 7 &/&++(&*&) :: (Dim.C u, Dim.C v, Ring.C a) =>+   T u a -> T v a -> T (Dim.Mul u v) a+(&*&) (Cons x) (Cons y) = Cons (x Ring.* y)++(&/&) :: (Dim.C u, Dim.C v, Field.C a) =>+   T u a -> T v a -> T (Dim.Mul u (Dim.Recip v)) a+(&/&) (Cons x) (Cons y) = Cons (x Field./ y)++mulToScalar :: (Dim.C u, Ring.C a) =>+   T u a -> T (Dim.Recip u) a -> a+mulToScalar x y = cancelToScalar (x &*& y)++divToScalar :: (Dim.C u, Field.C a) =>+   T u a -> T u a -> a+divToScalar x y = cancelToScalar (x &/& y)++cancelToScalar :: (Dim.C u) =>+   T (Dim.Mul u (Dim.Recip u)) a -> a+cancelToScalar =+   toNumber . rewriteDimension Dim.cancelRight+++recip :: (Dim.C u, Field.C a) =>+   T u a -> T (Dim.Recip u) a+recip (Cons x) = Cons (Field.recip x)++unrecip :: (Dim.C u, Field.C a) =>+   T (Dim.Recip u) a -> T u a+unrecip (Cons x) = Cons (Field.recip x)++sqr :: (Dim.C u, Ring.C a) =>+   T u a -> T (Dim.Sqr u) a+sqr x = x &*& x++sqrt :: (Dim.C u, Algebraic.C a) =>+   T (Dim.Sqr u) a -> T u a+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)++absSignum :: (Dim.C u, Real.C a) => T u a -> (T u a, a)+absSignum x0@(Cons x) = (abs x0, Real.signum x)++scale, (*&) :: (Dim.C u, Ring.C a) =>+   a -> T u a -> T u a+scale x (Cons y) = Cons (x Ring.* y)++(*&) = scale+++rewriteDimension :: (Dim.C u, Dim.C v) => (u -> v) -> T u a -> T v a+rewriteDimension _ (Cons x) = Cons x+++{-+type class for converting Dim types to Dim value is straight-forward+   class SIDimensionType u where+      dynamic :: DimensionNumber u a -> SIValue a++   instance SIDimensionType Scalar where+      dynamic (DimensionNumber.Cons x) = SIValue.scalar x++   instance SIDimensionType Length where+      dynamic (DimensionNumber.Cons x) = SIValue.meter * dynamic x+-}+++{- * Example constructors -}++type Scalar      a = T Dim.Scalar a+type Length      a = T Dim.Length a+type Time        a = T Dim.Time a+type Mass        a = T Dim.Mass a+type Charge      a = T Dim.Charge a+type Angle       a = T Dim.Angle a+type Temperature a = T Dim.Temperature a+type Information a = T Dim.Information a++type Frequency   a = T Dim.Frequency a+type Voltage     a = T Dim.Voltage a+++length :: a -> Length a+length = Cons++time :: a -> Time a+time = Cons++mass :: a -> Mass a+mass = Cons++charge :: a -> Charge a+charge = Cons++frequency :: a -> Frequency a+frequency = Cons++angle :: a -> Angle a+angle = Cons++temperature :: a -> Temperature a+temperature = Cons++information :: a -> Information a+information = Cons+++voltage :: a -> Voltage a+voltage = Cons
+ src/Number/DimensionTerm/SI.hs view
@@ -0,0 +1,125 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2003+License     :  GPL++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable++Special physical units: SI unit system+-}++module Number.DimensionTerm.SI (+    second, minute, hour, day, year,+    hertz,+    meter,+    -- liter,+    gramm, tonne,+    -- newton,+    -- pascal,+    -- bar,+    -- joule,+    -- watt,+    coulomb,+    -- ampere,+    volt,+    -- ohm,+    -- farad,+    kelvin,+    bit, byte,+    -- baud,++    inch, foot, yard, astronomicUnit, parsec,++    SI.yocto, SI.zepto, SI.atto,  SI.femto, SI.pico, SI.nano,+    SI.micro, SI.milli, SI.centi, SI.deci,  SI.one,  SI.deca,+    SI.hecto, SI.kilo,  SI.mega,  SI.giga,  SI.tera, SI.peta,+    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)+++second  :: Field.C a => DN.Time        a+second  = DN.time        1e+0+minute  :: Field.C a => DN.Time        a+minute  = DN.time        SI.secondsPerMinute+hour    :: Field.C a => DN.Time        a+hour    = DN.time        SI.secondsPerHour+day     :: Field.C a => DN.Time        a+day     = DN.time        SI.secondsPerDay+year    :: Field.C a => DN.Time        a+year    = DN.time        SI.secondsPerYear+hertz   :: Field.C a => DN.Frequency a+hertz   = DN.frequency   1e+0+meter   :: Field.C a => DN.Length      a+meter   = DN.length      1e+0+-- liter   :: Field.C a => DN.Volume      a+-- liter   = DN.volume      1e-3+gramm   :: Field.C a => DN.Mass        a+gramm   = DN.mass        1e-3+tonne   :: Field.C a => DN.Mass        a+tonne   = DN.mass        1e+3+-- newton  :: Field.C a => DN.Force       a+-- newton  = DN.force       1e+0+-- pascal  :: Field.C a => DN.Pressure    a+-- pascal  = DN.pressure    1e+0+-- bar     :: Field.C a => DN.Pressure    a+-- bar     = DN.pressure    1e+5+-- joule   :: Field.C a => DN.Energy      a+-- joule   = DN.energy      1e+0+-- watt    :: Field.C a => DN.Power       a+-- watt    = DN.power       1e+0+coulomb :: Field.C a => DN.Charge      a+coulomb = DN.charge      1e+0+-- ampere  :: Field.C a => DN.Current     a+-- ampere  = DN.current     1e+0+volt    :: Field.C a => DN.Voltage     a+volt    = DN.voltage     1e+0+-- ohm     :: Field.C a => DN.Resistance  a+-- ohm     = DN.resistance  1e+0+-- farad   :: Field.C a => DN.Capacitance a+-- farad   = DN.capacitance 1e+0+kelvin  :: Field.C a => DN.Temperature a+kelvin  = DN.temperature 1e+0+bit     :: Field.C a => DN.Information a+bit     = DN.information 1e+0+byte    :: Field.C a => DN.Information a+byte    = DN.information SI.bytesize+-- baud    :: Field.C a => DN.DataRate    a+-- baud    = DN.dataRate    1e+0++inch, foot, yard, astronomicUnit, parsec+   :: Field.C a => DN.Length a++inch           = DN.length SI.meterPerInch+foot           = DN.length SI.meterPerFoot+yard           = DN.length SI.meterPerYard+astronomicUnit = DN.length SI.meterPerAstronomicUnit+parsec         = DN.length SI.meterPerParsec++{-+accelerationOfEarthGravity :: Field.C a => DN.Acceleration    a+accelerationOfEarthGravity = DN.acceleration SI.accelerationOfEarthGravity++mach         :: Field.C a => DN.Speed a+speedOfLight :: Field.C a => DN.Speed a+electronVolt :: Field.C a => DN.Energy a+calorien     :: Field.C a => DN.Energy a+horsePower   :: Field.C a => DN.Power a++mach         = DN.speed        SI.mach+speedOfLight = DN.speed        SI.speedOfLight+electronVolt = DN.energy       SI.electronVolt+calorien     = DN.energy       SI.calorien+horsePower   = DN.power        SI.horsePower+-}
+ src/Number/FixedPoint.hs view
@@ -0,0 +1,233 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Fixed point numbers.+They are implemented as ratios with fixed denominator.+Many routines fail for some arguments.+When they work,+they can be useful for obtaining approximations of some constants.+We have not paid attention to rounding errors+and thus some of the trailing digits may be wrong.+-}+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.Transcendental as Trans+import qualified MathObj.PowerSeries.Example as PSE++import NumericPrelude.List (dropWhileRev, mapLast, padLeft)+import NumericPrelude.Condition (toMaybe)+import Data.List (transpose, unfoldr)+import Data.Char (intToDigit)++import PreludeBase+import NumericPrelude hiding (recip, sqrt, exp, sin, cos, tan,+                              fromRational')++import qualified NumericPrelude as NP+++{- ** Conversion -}++{- ** other number types -}++fromFloat :: RealField.C a => Integer -> a -> Integer+fromFloat den x =+   round (x * NP.fromInteger den)++-- | denominator conversion+fromFixedPoint :: Integer -> Integer -> Integer -> Integer+fromFixedPoint denDst denSrc x = div (x*denDst) denSrc+++{- ** text -}++{- |+very efficient because it can make use of the decimal output of 'show'+-}+showPositionalDec :: Integer -> Integer -> String+showPositionalDec den = liftShowPosToInt $ \x ->+   let packetSize = 50  -- process digits in packets of this size+       basis = ringPower packetSize 10+       (int,frac) = toPositional basis den x+   in  show int ++ "." +++          concat (mapLast (dropWhileRev ('0'==))+             (map (padLeft '0' packetSize . show) frac))++showPositionalHex :: Integer -> Integer -> String+showPositionalHex = showPositionalBasis 16++showPositionalBin :: Integer -> Integer -> String+showPositionalBin = showPositionalBasis 2++showPositionalBasis :: Integer -> Integer -> Integer -> String+showPositionalBasis basis den = liftShowPosToInt $ \x ->+   let (int,frac) = toPositional basis den x+   in  show int ++ "." ++ map (intToDigit . fromInteger) frac++liftShowPosToInt :: (Integer -> String) -> (Integer -> String)+liftShowPosToInt f n =+   if n>=0+     then       f   n+     else '-' : f (-n)++toPositional :: Integer -> Integer -> Integer -> (Integer, [Integer])+toPositional basis den x =+   let (int, frac) = divMod x den+   in  (int, unfoldr (\rm -> toMaybe (rm/=0) (divMod (basis*rm) den)) frac)+++{- * Additive -}++add :: Integer -> Integer -> Integer -> Integer+add _ = (+)++sub :: Integer -> Integer -> Integer -> Integer+sub _ = (-)+++{- * Ring -}++mul :: Integer -> Integer -> Integer -> Integer+mul den x y = div (x*y) den+++{- * Field -}++divide :: Integer -> Integer -> Integer -> Integer+divide den x y = div (x*den) y++recip :: Integer -> Integer -> Integer+recip den x = div (den^2) x+++{- * Algebra -}++{-+Newton's method for computing roots.+-}++magnitudes :: [Integer]+magnitudes =+   concat (transpose [iterate (^2) 4, iterate (^2) 8])++{-+Maybe we can speed up the algorithm+by calling sqrt recursively on deflated arguments.+-}+sqrt :: Integer -> Integer -> Integer+sqrt den x =+   let xden     = x*den+       initial  = fst (head (dropWhile ((<= xden) . snd)+                                (zip magnitudes (tail (tail magnitudes)))))+       approxs  = iterate (\y -> div (y + div xden y) 2) initial+       isRoot y = y^2 <= xden && xden < (y+1)^2+   in  head (dropWhile (not . isRoot) approxs)++-- bug: needs too long:  root (12::Int) (fromIntegerBase 10 1000 2)+root :: Integer -> Integer -> Integer -> Integer+root n den x =+   let n1       = n-1+       xden     = x * den^n1+       initial  = fst (head (dropWhile ((\y -> y^n <= xden) . snd)+                                (zip magnitudes (tail magnitudes))))+       approxs  = iterate (\y -> div (n1*y + div xden (y^n1)) n) initial+       isRoot y = y^n <= xden && xden < (y+1)^n+   in  head (dropWhile (not . isRoot) approxs)++++{- * Transcendental -}++-- very simple evaluation by power series with lots of rounding errors+evalPowerSeries :: [Rational] -> Integer -> Integer -> Integer+evalPowerSeries series den x =+   let powers   = iterate (mul den x) den+       summands = zipWith (\c p -> round (c * fromInteger p)) series powers+   in  sum (map snd (takeWhile (\(c,s) -> s/=0 || c==0)+                               (zip series summands)))++cos, sin, tan :: Integer -> Integer -> Integer+cos = evalPowerSeries PSE.cos+sin = evalPowerSeries PSE.sin+-- tan will suffer from inaccuracies for small cosine+tan den x = divide den (sin den x) (cos den x)++-- it must abs x <= den+arctanSmall :: Integer -> Integer -> Integer+arctanSmall = evalPowerSeries PSE.atan++-- will fail for large inputs+arctan :: Integer -> Integer -> Integer+arctan den x =+   let estimate = fromFloat den+                     (Trans.atan (NP.fromRational' (x % den)) :: Double)+       tanEst   = tan den estimate+       residue  = divide den (x-tanEst) (den + mul den x tanEst)+   in  estimate + arctanSmall den residue++piConst :: Integer -> Integer+piConst den =+   let den4 = 4*den+       stArcTan k x = let d = k*den4 in arctanSmall d (div d x)+   in  {- formula 4 * (8 * arctan (1/10) - arctan (1/239) - 4 * arctan (1/515))+             from "Bartsch: Mathematische Formeln" -}+       -- (stArcTan 8 10 - stArcTan 1 239 - stArcTan 4 515)+       -- formula by Stoermer+       (stArcTan 44 57 + stArcTan 7 239 - stArcTan 12 682 + stArcTan 24 12943)+++expSmall :: Integer -> Integer -> Integer+expSmall = evalPowerSeries PSE.exp++eConst :: Integer -> Integer+eConst den = expSmall den den++recipEConst :: Integer -> Integer+recipEConst den = expSmall den (-den)++exp :: Integer -> Integer -> Integer+exp den x =+   let den2 = div den 2+       (int,frac) = divMod (x + den2) den+       expFrac = expSmall den (frac-den2)+   in  case compare int 0 of+          EQ -> expFrac+          GT -> reduceRepeated (mul den) expFrac (eConst      den)   int+          LT -> reduceRepeated (mul den) expFrac (recipEConst den) (-int)+          -- LT -> nest (-int) (divide den e) expFrac+++approxLogBase :: Integer -> Integer -> (Int, Integer)+approxLogBase base x =+   until ((<=base) . snd) (\(xE,xM) -> (succ xE, div xM base)) (0,x)++lnSmall :: Integer -> Integer -> Integer+lnSmall den x =+   evalPowerSeries PSE.log den (x-den)++-- uses Double's log for an estimate and dramatic speed up+ln :: Integer -> Integer -> Integer+ln den x =+   let fac = 10^50 {- A constant which is representable by Double+                      and which will quickly split our number it pieces+                      small enough for Double. -}+       (denE, denM) = approxLogBase fac den+       (xE,   xM)   = approxLogBase fac x+       approxDouble :: Double+       approxDouble =+          log (NP.fromInteger fac) * fromIntegral (xE-denE) ++          log (NP.fromInteger xM / NP.fromInteger denM)+       {- We convert first with respect to @fac@+          in order to keep in the range of Double values. -}+       approxFac = round (approxDouble * NP.fromInteger fac)+       approx    = fromFixedPoint den fac approxFac+       xSmall    = divide den x (exp den approx)+   in  add den approx (lnSmall den xSmall)
+ src/Number/FixedPoint/Check.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Number.FixedPoint.Check where++import qualified Number.FixedPoint as FP++import qualified MathObj.PowerSeries.Example as PSE++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.Ring           as Ring+import qualified Algebra.Additive       as Additive+import qualified Algebra.ZeroTestable   as ZeroTestable++import PreludeBase+import NumericPrelude   hiding (fromRational')++import qualified Prelude        as P98+import qualified NumericPrelude as NP+++{- * Types -}++data T = Cons {denominator :: Integer, numerator :: Integer}+++{- * Conversion -}++cons :: Integer -> Integer -> T+cons = Cons++{- ** other number types -}++fromFloat :: RealField.C a => Integer -> a -> T+fromFloat den x =+   cons den (FP.fromFloat den x)++fromInteger' :: Integer -> Integer -> T+fromInteger' den x =+   cons den (x * den)++fromRational' :: Integer -> Rational -> T+fromRational' den x =+   cons den (round (x * NP.fromInteger den))++fromFloatBasis :: RealField.C a => Integer -> Int -> a -> T+fromFloatBasis basis numDigits =+   fromFloat (ringPower numDigits basis)++fromIntegerBasis :: Integer -> Int -> Integer -> T+fromIntegerBasis basis numDigits =+   fromInteger' (ringPower numDigits basis)++fromRationalBasis :: Integer -> Int -> Rational -> T+fromRationalBasis basis numDigits =+   fromRational' (ringPower numDigits basis)++-- | denominator conversion+fromFixedPoint :: Integer -> T -> T+fromFixedPoint denDst (Cons denSrc x) =+   cons denDst (FP.fromFixedPoint denDst denSrc x)+++{- * Lift core function -}++lift0 :: Integer -> (Integer -> Integer) -> T+lift0 den f = Cons den (f den)++lift1 :: (Integer -> Integer -> Integer) -> (T -> T)+lift1 f (Cons xd xn) = Cons xd (f xd xn)++lift2 :: (Integer -> Integer -> Integer -> Integer) -> (T -> T -> T)+lift2 f (Cons xd xn) (Cons yd yn) =+   commonDenominator xd yd $ Cons xd (f xd xn yn)++commonDenominator :: Integer -> Integer -> a -> a+commonDenominator xd yd z =+   if xd == yd+     then z+     else error "Number.FixedPoint: denominators differ"+++{- * Show -}++appPrec :: Int+appPrec  = 10++instance Show T where+  showsPrec p (Cons den num) =+    showParen (p >= appPrec)+       (showString "FixedPoint.cons " . shows den+          . showString " " . shows num)+++defltDenominator :: Integer+defltDenominator = 10^100++defltShow :: T -> String+defltShow (Cons den x) =+   FP.showPositionalDec den x++++instance Additive.C T where+   zero   = cons defltDenominator zero+   (+)    = lift2 FP.add+   (-)    = lift2 FP.sub+   negate (Cons xd xn) = Cons xd (negate xn)+++instance Ring.C T where+   one         = cons defltDenominator defltDenominator+   fromInteger = fromInteger' defltDenominator . NP.fromInteger+   (*)         = lift2 FP.mul+   -- the default instance of (^) cumulates rounding errors but is faster+   -- x^n           = lift1 (pow n) x+++instance Field.C T where+   (/)   = lift2 FP.divide+   recip = lift1 FP.recip+   fromRational' = fromRational' defltDenominator . NP.fromRational'+++instance Algebraic.C T where+   sqrt   = lift1 FP.sqrt+   root n = lift1 (FP.root n)+++-- these function are only implemented for the convergence radius of their Taylor expansions+instance Trans.C T where+   pi    = lift0 defltDenominator FP.piConst+   exp   = lift1 FP.exp+   log   = lift1 FP.ln+   {-+   logBase+   (**)+   -}+   sin   = lift1 (FP.evalPowerSeries PSE.sin)+   cos   = lift1 (FP.evalPowerSeries PSE.cos)+   -- tan   = lift1 (FP.evalPowerSeries PSE.tan)+   asin  = lift1 (FP.evalPowerSeries PSE.asin)+   atan  = lift1 FP.arctan+   {-+   acos  = lift1 (FP.evalPowerSeries PSE.acos)+   sinh  = lift1 (FP.evalPowerSeries PSE.sinh)+   tanh  = lift1 (FP.evalPowerSeries PSE.tanh)+   cosh  = lift1 (FP.evalPowerSeries PSE.cosh)+   asinh = lift1 (FP.evalPowerSeries PSE.asinh)+   atanh = lift1 (FP.evalPowerSeries PSE.atanh)+   acosh = lift1 (FP.evalPowerSeries PSE.acosh)+   -}+++instance ZeroTestable.C T where+   isZero (Cons _ xn)  =  isZero xn++instance Eq T where+   (Cons xd xn) == (Cons yd yn) =+      commonDenominator xd yd (xn==yn)++instance Ord T where+   compare (Cons xd xn) (Cons yd yn) =+      commonDenominator xd yd (compare xn yn)++instance Real.C T where+   abs = lift1 (const abs)+   -- use default implementation for signum++instance RealField.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"++instance P98.Num T where+   fromInteger = fromInteger' defltDenominator+   negate = negate --for unary minus+   (+)    = legacyInstance+   (*)    = legacyInstance+   abs    = legacyInstance+   signum = legacyInstance++instance P98.Fractional T where+   fromRational = fromRational' defltDenominator . fromRational+   (/) = legacyInstance
+ src/Number/NonNegative.hs view
@@ -0,0 +1,215 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2007++Maintainer  :  haskell@henning-thielemann.de+Stability   :  stable+Portability :  Haskell 98++A type for non-negative numbers.+It performs a run-time check at construction time (i.e. at run-time)+and is a member of the non-negative number type class+'Numeric.NonNegative.Class.C'.+-}+module Number.NonNegative+   (T, fromNumber, fromNumberMsg, fromNumberClip, fromNumberUnsafe, toNumber,+    NonNegW.Int, NonNegW.Integer, NonNegW.Float, NonNegW.Double,+    Ratio, Rational) where++import Numeric.NonNegative.Wrapper+   (T, fromNumberUnsafe, toNumber)+import qualified Numeric.NonNegative.Wrapper as NonNegW++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.Field              as Field+import qualified Algebra.RealIntegral       as RealIntegral+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.ZeroTestable       as ZeroTestable++import qualified Algebra.ToInteger          as ToInteger+import qualified Algebra.ToRational         as ToRational+-- import Test.QuickCheck (Arbitrary(..))++import qualified Number.Ratio as R++import qualified Prelude as P++import PreludeBase+import NumericPrelude hiding (Int, Integer, Float, Double, Rational)+++{- |+Convert a number to a non-negative number.+If a negative number is given, an error is raised.+-}+fromNumber :: (Ord a, Additive.C a) =>+      a+   -> T a+fromNumber = fromNumberMsg "fromNumber"++fromNumberMsg :: (Ord a, Additive.C a) =>+      String  {- ^ name of the calling function to be used in the error message -}+   -> a+   -> T a+fromNumberMsg funcName x =+   if x>=zero+     then fromNumberUnsafe x+     else error (funcName++": negative number")++fromNumberWrap :: (Ord a, Additive.C a) =>+      String+   -> a+   -> T a+fromNumberWrap funcName =+   fromNumberMsg ("Number.NonNegative."++funcName)++{- |+Convert a number to a non-negative number.+A negative number will be replaced by zero.+Use this function with care since it may hide bugs.+-}+fromNumberClip :: (Ord a, Additive.C a) =>+      a+   -> T a+fromNumberClip = fromNumberUnsafe . max zero++++{- |+Results are not checked for positivity.+-}+lift :: (a -> a) -> (T a -> T a)+lift f = fromNumberUnsafe . f . toNumber++liftWrap :: (Ord a, Additive.C a) => String -> (a -> a) -> (T a -> T a)+liftWrap msg f = fromNumberWrap msg . f . toNumber+++{- |+Results are not checked for positivity.+-}+lift2 :: (a -> a -> a) -> (T a -> T a -> T a)+lift2 f x y =+   fromNumberUnsafe $ f (toNumber x) (toNumber y)++++instance ZeroTestable.C a => ZeroTestable.C (T a) where+   isZero = isZero . toNumber++instance (Ord a, Additive.C a) => NonNeg.C (T a) where+   x -| y = fromNumberClip (toNumber x - toNumber y)++instance (Ord a, Additive.C a) => Additive.C (T a) where+   zero   = fromNumberUnsafe zero+   (+)    = lift2 (+)+   (-)    = liftWrap "-" . (-) . toNumber+   negate = liftWrap "negate" negate++instance (Ord a, Ring.C a) => Ring.C (T a) where+   (*)    = lift2 (*)+   fromInteger = fromNumberWrap "fromInteger" . fromInteger++instance ToRational.C a => ToRational.C (T a) where+   toRational = ToRational.toRational . toNumber++instance ToInteger.C a => ToInteger.C (T a) where+   toInteger = toInteger . toNumber++{- already defined in the imported module+instance (Ord a, Additive.C a, Enum a) => Enum (T a) where+   toEnum   = fromNumberWrap "toEnum" . toEnum+   fromEnum = fromEnum . toNumber++instance (Ord a, Additive.C a, Bounded a) => Bounded (T a) where+   minBound = fromNumberClip minBound+   maxBound = fromNumberWrap "maxBound" maxBound++instance (Additive.C a, Arbitrary a) => Arbitrary (T a) where+   arbitrary = liftM (fromNumberUnsafe . abs) arbitrary+   coarbitrary = undefined+-}++instance RealIntegral.C a => RealIntegral.C (T a) where+   quot = lift2 quot+   rem  = lift2 rem+   quotRem x y =+      mapPair+         (fromNumberUnsafe, fromNumberUnsafe)+         (quotRem (toNumber x) (toNumber y))++instance (Ord a, Integral.C a) => Integral.C (T a) where+   div  = lift2 div+   mod  = lift2 mod+   divMod x y =+      mapPair+         (fromNumberUnsafe, fromNumberUnsafe)+         (divMod (toNumber x) (toNumber y))++instance (Ord a, Field.C a) => Field.C (T a) where+   fromRational' = fromNumberWrap "fromRational" . fromRational'+   (/) = lift2 (/)+++instance (ZeroTestable.C a, Real.C a) => Real.C (T a) where+   abs    = lift abs+   signum = lift signum++instance (RealField.C a) => RealField.C (T a) where+   splitFraction = mapSnd fromNumberUnsafe . splitFraction . toNumber+   truncate = truncate . toNumber+   round    = round    . toNumber+   ceiling  = ceiling  . toNumber+   floor    = floor    . toNumber++instance (Ord a, Algebraic.C a) => Algebraic.C (T a) where+   sqrt = lift sqrt+   (^/) x r = lift (^/ r) x++instance (Ord a, Trans.C a) => Trans.C (T a) where+   pi = fromNumber pi+   exp  = lift exp+   log  = liftWrap "log" log+   (**) = lift2 (**)+   logBase = liftWrap "logBase" . logBase . toNumber+   sin = liftWrap "sin" sin+   tan = liftWrap "tan" tan+   cos = liftWrap "cos" cos+   asin = liftWrap "asin" asin+   atan = liftWrap "atan" atan+   acos = liftWrap "acos" acos+   sinh = liftWrap "sinh" sinh+   tanh = liftWrap "tanh" tanh+   cosh = liftWrap "cosh" cosh+   asinh = liftWrap "asinh" asinh+   atanh = liftWrap "atanh" atanh+   acosh = liftWrap "acosh" acosh+++type Ratio a  = T (R.T a)+type Rational = T P.Rational+++-- auxiliary functions++mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)+mapPair ~(f,g) ~(x,y) = (f x, g y)++{-+mapFst :: (a -> c) -> (a,b) -> (c,b)+mapFst f ~(x,y) = (f x, y)+-}++mapSnd :: (b -> d) -> (a,b) -> (a,d)+mapSnd g ~(x,y) = (x, g y)+++++{- legacy instances already defined in non-negative package -}
+ src/Number/OccasionallyScalarExpression.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+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.+-}++module Number.OccasionallyScalarExpression where++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 Algebra.ZeroTestable        as ZeroTestable++import Algebra.Algebraic (sqrt, (^/))+import Algebra.OccasionallyScalar as OccScalar++import Data.Maybe(fromMaybe)+import Data.Array(listArray,(!))++import PreludeBase+import NumericPrelude+++{- | A value of type 'T' stores information on how to resolve unit violations.+     The main application of the module are certainly+     Number.Physical type instances+     but in principle it can also be applied to other occasionally scalar types. -}+data T a v = Cons (Term a v) v++data Term a v =+     Const+   | Add (T a v) (T a v)+   | Mul (T a v) (T a v)+   | Div (T a v) (T a v)++fromValue :: v -> T a v+fromValue = Cons Const+++makeLine :: Int -> String -> String+makeLine indent str = replicate indent ' ' ++ str ++ "\n"++showUnitError :: (Show v) => Bool -> Int -> v -> T a v -> String+showUnitError divide indent x (Cons expr y) =+  let indent'   = indent+2+      showSub d = showUnitError d (indent'+2) x+      mulDivArr = listArray (False, True) ["multiply", "divide"]+  in  makeLine indent+         (mulDivArr ! divide +++          " " ++ show y ++ " by " ++ show x) +++      case expr of+        (Const) -> ""+        (Add y0 y1) ->+          makeLine indent' "e.g." +++          showSub divide y0 +++          makeLine indent' "and " +++          showSub divide y1+        (Mul y0 y1) ->+          makeLine indent' "e.g." +++          showSub divide y0 +++          makeLine indent' "or  " +++          showSub divide y1+        (Div y0 y1) ->+          makeLine indent' "e.g." +++          showSub divide y0 +++          makeLine indent' "or  " +++          showSub (not divide) y1+++lift :: (v -> v) -> (T a v -> T a v)+lift f (Cons xe x) = Cons xe (f x)++scalarMap :: (Show v, OccScalar.C a v) =>+   (a -> a) -> (T a v -> T a v)+scalarMap f x = fromScalar (f (toScalar x))++scalarMap2 :: (Show v, OccScalar.C a v) =>+   (a -> a -> a) -> (T a v -> T a v -> T a v)+scalarMap2 f x y = fromScalar (f (toScalar x) (toScalar y))+++instance (Show v) => Show (T a v) where+  show (Cons _ x) = show x++instance (Eq v) => Eq (T a v) where+  (Cons _ x) == (Cons _ y) = x==y++instance (Ord v) => Ord (T a v) where+  compare (Cons _ x) (Cons _ y) = compare x y++instance (Additive.C v) => Additive.C (T a v) where+  zero = Cons Const zero+  xe@(Cons _ x) + ye@(Cons _ y) = Cons (Add xe ye) (x+y)+  xe@(Cons _ x) - ye@(Cons _ y) = Cons (Add xe ye) (x-y)+  negate = lift negate++instance (Ring.C v) => Ring.C (T a v) where+  xe@(Cons _ x) * ye@(Cons _ y) = Cons (Mul xe ye) (x*y)++  fromInteger = fromValue . fromInteger++instance (Field.C v) => Field.C (T a v) where+  xe@(Cons _ x) / ye@(Cons _ y) = Cons (Div xe ye) (x/y)+  fromRational' = fromValue . fromRational'++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+  {- are these definitions sensible? -}+  abs    = lift abs+  signum = lift signum+++{- This instance is not quite satisfying.+   The expression data structure should also keep track of powers+   in order to report according errors. -}+instance (Algebraic.C a, Field.C v, Show v, OccScalar.C a v) =>+    Algebraic.C (T a v) where+  sqrt    = scalarMap  sqrt+  x ^/ y  = scalarMap  (^/ y) x++instance (Trans.C a, Field.C v, Show v, OccScalar.C a v) =>+    Trans.C (T a v) where+  pi      = fromScalar (pi::a)+  log     = scalarMap  log+  exp     = scalarMap  exp+  logBase = scalarMap2 logBase+  (**)    = scalarMap2 (**)+  cos     = scalarMap  cos+  tan     = scalarMap  tan+  sin     = scalarMap  sin+  acos    = scalarMap  acos+  atan    = scalarMap  atan+  asin    = scalarMap  asin+  cosh    = scalarMap  cosh+  tanh    = scalarMap  tanh+  sinh    = scalarMap  sinh+  acosh   = scalarMap  acosh+  atanh   = scalarMap  atanh+  asinh   = scalarMap  asinh+++instance (OccScalar.C a v, Show v)+      => OccScalar.C a (T a v) where+   toScalar xe@(Cons _ x) =+      fromMaybe+         (error (show xe ++ " is not a scalar value.\n" +++                 showUnitError True 0 x xe))+         (toMaybeScalar x)+   toMaybeScalar (Cons _ x) = toMaybeScalar x+   fromScalar = fromValue . fromScalar+++{-+  I would like to use OccasionallyScalar.toScalar+  in fmap and (>>=) to allow more sophisticated error messages+  for types that support more descriptive error messages.+  But this requires constraints to the type arguments of+  Functor and Monad.+-}+++{- Operators for lifting scalar operations to+   operations on physical values -}+{-+instance Functor (T i) where+  fmap f (Cons xu x) =+    if Unit.isScalar xu+    then fromScalar (f x)+    else error "Physics.Quantity.Value.fmap: function for scalars, only"++instance Monad (T i) where+  (>>=) (Cons xu x) f =+    if Unit.isScalar xu+    then f x+    else error "Physics.Quantity.Value.(>>=): function for scalars, only"+  return = fromScalar+-}
+ src/Number/PartiallyTranscendental.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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'.+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,+you might consider using @MathObj.PowerSeries.T (Number.PartiallyTranscendental.T Rational)@+instead of @MathObj.PowerSeries.T Rational@.+-}+module Number.PartiallyTranscendental (T, fromValue, toValue) where++import qualified Algebra.Transcendental as Transcendental+import qualified Algebra.Algebraic      as Algebraic+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 qualified Prelude as P+++newtype T a = Cons {toValue :: a}+   deriving (Eq, Ord, Show)++fromValue :: a -> T a+fromValue = lift0++lift0 :: a -> T a+lift0 = Cons++lift1 :: (a -> a) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++lift2 :: (a -> a -> a) -> (T a -> T a -> T a)+lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)+++instance (Additive.C a) => Additive.C (T a) where+    negate = lift1 negate+    (+)    = lift2 (+)+    (-)    = lift2 (-)+    zero   = lift0 zero++instance (Ring.C a) => Ring.C (T a) where+    one           = lift0 one+    fromInteger n = lift0 (fromInteger n)+    (*)           = lift2 (*)++instance (Field.C a) => Field.C (T a) where+    (/) = lift2 (/)++instance (Algebraic.C a) => Algebraic.C (T a) where+    sqrt x = lift1 sqrt x+    root n = lift1 (Algebraic.root n)+    (^/) x y = lift1 (^/y) x++instance (Algebraic.C a, Eq a) => Transcendental.C (T a) where+    pi = undefined+    exp = \0 -> 1+    sin = \0 -> 0+    cos = \0 -> 1+    tan = \0 -> 0+    x ** y = if x==1 || y==0+               then 1+               else error "partially transcendental power undefined"+    log  = \1 -> 0+    asin = \0 -> 0+    acos = \1 -> 0+    atan = \0 -> 0++++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++instance (P.Num a) => P.Fractional (T a) where+   fromRational = P.fromRational+   (/) = legacyInstance
+ src/Number/Peano.hs view
@@ -0,0 +1,278 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright    :   (c) Henning Thielemann 2007+Maintainer   :   numericprelude@henning-thielemann.de+Stability    :   provisional+Portability  :   portable++Lazy Peano numbers represent natural numbers inclusive infinity.+Since they are lazily evaluated,+they are optimally for use as number type of 'Data.List.genericLength' et.al.+-}+module Number.Peano where++import qualified Algebra.PrincipalIdealDomain as PID+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.Ring                 as Ring+import qualified Algebra.Additive             as Additive+import qualified Algebra.ZeroTestable         as ZeroTestable+import qualified Algebra.Indexable            as Indexable++import qualified Algebra.ToInteger            as ToInteger+import qualified Algebra.ToRational           as ToRational+import qualified Algebra.NonNegative          as NonNeg++import Data.Array(Ix(..))++import qualified Prelude     as P98+import qualified PreludeBase as P+import qualified NumericPrelude as NP++import PreludeBase+import NumericPrelude+++data T = Zero+       | Succ T+   deriving (Show, Read, Eq)++infinity :: T+infinity = Succ infinity++err :: String -> String -> a+err func msg = error ("Number.Peano."++func++": "++msg)+++instance ZeroTestable.C T where+   isZero Zero     = True+   isZero (Succ _) = False++add :: T -> T -> T+add Zero y = y+add (Succ x) y = Succ (add x y)++sub :: T -> T -> T+sub x y =+   let (sign,z) = subNeg y x+   in  if sign+         then err "sub" "negative difference"+         else z++subNeg :: T -> T -> (Bool, T)+subNeg Zero y = (False, y)+subNeg x Zero = (True,  x)+subNeg (Succ x) (Succ y) = subNeg x y++{- efficient implementation of x0 <= x1 && x1 <= x2 ... -}+isAscending :: [T] -> Bool+isAscending [] = True+isAscending (x:xs) =+   if isZero x+     then isAscending xs+     else not (any isZero xs) &&+          isAscending (map pred xs)++mul :: T -> T -> T+mul Zero _ = Zero+mul (Succ x) y = add y (mul x y)++fromPosEnum :: (ZeroTestable.C a, Enum a) => a -> T+fromPosEnum n =+   if isZero n+      then Zero+      else Succ (fromPosEnum (pred n))++toPosEnum :: (Additive.C a, Enum a) => T -> a+toPosEnum Zero = zero+toPosEnum (Succ x) = succ (toPosEnum x)++instance Additive.C T where+   zero = Zero+   (+) = add+   (-) = sub+   negate Zero     = Zero+   negate (Succ _) = err "negate" "cannot negate positive number"++instance Ring.C T where+   one = Succ Zero+   (*) = mul+   fromInteger n =+      if n<0+        then err "fromInteger" "Peano numbers are always non-negative"+        else fromPosEnum n++instance Enum T where+   pred Zero = err "pred" "Zero has no predecessor"+   pred (Succ x) = x+   succ = Succ+   toEnum n =+      if n<0+        then err "toEnum" "Peano numbers are always non-negative"+        else fromPosEnum n+   fromEnum = toPosEnum+   enumFrom x = iterate Succ x+   enumFromThen x y =+      let (sign,d) = subNeg x y+      in  if sign+            then iterate (sub d) x+            else iterate (add d) x+   {-+   enumFromTo =+   enumFromThenTo =+   -}++{-+The default instance is good for compare,+but fails for min and max.+-}+instance Ord T where+   compare (Succ x) (Succ y) = compare x y+   compare Zero     (Succ _) = LT+   compare (Succ _) Zero     = GT+   compare Zero     Zero     = EQ++   min (Succ x) (Succ y) = Succ (min x y)+   min _        _        = Zero++   max (Succ x) (Succ y) = Succ (max x y)+   max Zero     y        = y+   max x        Zero     = x++{- | cf.+To how to find the shortest list in a list of lists efficiently,+this means, also in the presence of infinite lists.+<http://www.haskell.org/pipermail/haskell-cafe/2006-October/018753.html>+-}+argMinFull :: (T,a) -> (T,a) -> (T,a)+argMinFull (x0,xv) (y0,yv) =+   let recurse (Succ x) (Succ y) =+          let (z,zv) = recurse x y+          in  (Succ z, zv)+       recurse Zero _ = (Zero,xv)+       recurse _    _ = (Zero,yv)+   in  recurse x0 y0++{- |+On equality the first operand is returned.+-}+argMin :: (T,a) -> (T,a) -> a+argMin x y = snd $ argMinFull x y++argMinimum :: [(T,a)] -> a+argMinimum = snd . foldl1 argMinFull+++argMaxFull :: (T,a) -> (T,a) -> (T,a)+argMaxFull (x0,xv) (y0,yv) =+   let recurse (Succ x) (Succ y) =+          let (z,zv) = recurse x y+          in  (Succ z, zv)+       recurse x Zero = (x,xv)+       recurse _ y    = (y,yv)+   in  recurse x0 y0++{- |+On equality the first operand is returned.+-}+argMax :: (T,a) -> (T,a) -> a+argMax x y = snd $ argMaxFull x y++argMaximum :: [(T,a)] -> a+argMaximum = snd . foldl1 argMaxFull+++instance Real.C T where+   signum Zero     = zero+   signum (Succ _) = one+   abs             = id++instance ToInteger.C T where+   toInteger = toPosEnum++instance ToRational.C T where+   toRational = toRational . toInteger++instance RealIntegral.C T where+   quot = div+   rem  = mod+   quotRem = divMod++instance Integral.C T where+   div x y = fst (divMod x y)+   mod x y = snd (divMod x y)+   divMod x y =+      let (isNeg,d) = subNeg y x+      in  if isNeg+            then (zero,x)+            else let (q,r) = divMod d y in (succ q,r)++instance NonNeg.C T where+   (-|) x y =+      let (isNeg,d) = subNeg y x+      in  if isNeg+            then zero+            else d++instance Ix T where+   range = uncurry enumFromTo+   index (lower,_) i =+      let (sign,offset) = subNeg lower i+      in  if sign+            then err "index" "index out of range"+            else toPosEnum offset+   inRange (lower,upper) i =+      isAscending [lower, i, upper]+   rangeSize (lower,upper) =+      toPosEnum (sub lower (succ upper))++instance Indexable.C T where+   compare = Indexable.ordCompare++instance Units.C T where+   isUnit x  =  x == one+   stdAssociate  =  id+   stdUnit    _ = one+   stdUnitInv _ = one++instance PID.C T where+   gcd = PID.euclid mod+   extendedGCD = PID.extendedEuclid divMod++instance Bounded T where+   minBound = Zero+   maxBound = infinity++++legacyInstance :: a+legacyInstance =+   error "legacy Ring.C instance for simple input of numeric literals"++instance P98.Num T where+   fromInteger = Ring.fromInteger+   negate = Additive.negate -- for unary minus+   (+) = add+   (-) = sub+   (*) = mul+   signum = legacyInstance+   abs = legacyInstance++-- for use with genericLength et.al.+instance P98.Real T where+   toRational = P98.toRational . toInteger++instance P98.Integral T where+   rem  = div+   quot = mod+   quotRem = divMod+   div x y = fst (divMod x y)+   mod x y = snd (divMod x y)+   divMod x y =+      let (sign,d) = subNeg y x+      in  if sign+            then (0,x)+            else let (q,r) = divMod d y in (succ q,r)+   toInteger = toPosEnum
+ src/Number/Physical.hs view
@@ -0,0 +1,235 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+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+-}++module Number.Physical where++import qualified Number.Physical.Unit as Unit++import           Algebra.OccasionallyScalar  as OccScalar+import qualified Algebra.VectorSpace         as VectorSpace+import qualified Algebra.Module              as Module+import qualified Algebra.Vector              as Vector+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 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 NumericPrelude.Condition(toMaybe)+import Data.Maybe(fromMaybe)++import NumericPrelude+import PreludeBase+++-- | A Physics.Quantity.Value.T combines a numeric value with a physical unit.+data T i a = Cons (Unit.T i) a++-- | Construct a physical value from a numeric value and+-- the full vector representation of a unit.+quantity :: (Ord i, Enum i, Ring.C a) => [Int] -> a -> T i a+quantity v = Cons (Unit.fromVector v)++fromScalarSingle :: a -> T i a+fromScalarSingle = Cons Unit.scalar++-- | Test for the neutral Unit.T. Also a zero has a unit!+isScalar :: T i a -> Bool+isScalar (Cons u _) = Unit.isScalar u+++{- Using (((join.).).liftM2) you can turn madd and msub+   into operations that map Maybes to Maybes -}++-- | apply a function to the numeric value while preserving the unit+lift :: (a -> b) -> T i a -> T i b+lift f (Cons xu x) = Cons xu (f x)++lift2 :: (Eq i) => String -> (a -> b -> c) -> T i a -> T i b -> T i c+lift2 opName op x y =+   fromMaybe (errorUnitMismatch opName) (lift2Maybe op x y)++lift2Maybe :: (Eq i) => (a -> b -> c) -> T i a -> T i b -> Maybe (T i c)+lift2Maybe op (Cons xu x) (Cons yu y) =+   toMaybe (xu==yu) (Cons xu (op x y))++lift2Gen :: (Eq i) => String -> (a -> b -> c) -> T i a -> T i b -> c+lift2Gen opName op (Cons xu x) (Cons yu y) =+   if (xu==yu)+     then op x y+     else errorUnitMismatch opName++errorUnitMismatch :: String -> a+errorUnitMismatch opName =+   error ("Physics.Quantity.Value."++opName++": units mismatch")++++-- | Add two values if the units match, otherwise return Nothing+addMaybe :: (Eq i, Additive.C a) =>+  T i a -> T i a -> Maybe (T i a)+addMaybe = lift2Maybe (+)++-- | Subtract two values if the units match, otherwise return Nothing+subMaybe :: (Eq i, Additive.C a) =>+  T i a -> T i a -> Maybe (T i a)+subMaybe = lift2Maybe (-)+++scale :: (Ord i, Ring.C a) => a -> T i a -> T i a+scale x = lift (x*)++ratPow :: Trans.C a => Ratio.T Int -> T i a -> T i a+ratPow expo (Cons xu x) =+  Cons (Unit.ratScale expo xu) (x ** fromRatio expo)++ratPowMaybe :: (Trans.C a) =>+    Ratio.T Int -> T i a -> Maybe (T i a)+ratPowMaybe expo (Cons xu x) =+  fmap (flip Cons (x ** fromRatio expo)) (Unit.ratScaleMaybe expo xu)++fromRatio :: (Field.C b, ToInteger.C a) => Ratio.T a -> b+fromRatio expo = fromIntegral (numerator expo) /+                 fromIntegral (denominator expo)++++instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where+  isZero (Cons _ x) = isZero x++instance (Eq i, Eq a) => Eq (T i a) where+  (==) = lift2Gen "(==)" (==)++instance (Ord i, Enum i, Show a) => Show (T i a) where+  --show (Cons xu x) = show x ++ " !* " ++ show (Unit.toVector xu)+  show (Cons xu x) = "quantity " ++ show (Unit.toVector xu) ++ " " ++ show x++instance (Ord i, Additive.C a) => Additive.C (T i a) where+  zero   = fromScalarSingle zero+  -- Add two values if the units match, otherwise raise an error+  (+)    = lift2 "(+)" (+)+  -- Subtract two values if the units match, otherwise raise an error+  (-)    = lift2 "(-)" (-)+  negate = lift negate++instance (Ord i, Ring.C a) => Ring.C (T i a) where+  (Cons xu x) * (Cons yu y) = Cons (xu+yu) (x*y)+  fromInteger = fromScalarSingle . fromInteger++instance (Ord i, Ord a) => Ord (T i a) where+  max     = lift2    "max"     max+  min     = lift2    "min"     min+  compare = lift2Gen "compare" compare+  (<)     = lift2Gen "(<)"     (<)+  (>)     = lift2Gen "(>)"     (>)+  (<=)    = lift2Gen "(<=)"    (<=)+  (>=)    = lift2Gen "(>=)"    (>=)++{-+  Are absolute value and signum sensible for unit values?+  What is the sign, what is the absolute value?+  We could see it this way:+  The absolute value has no unit and+  the signum contains the unit and the scalar's sign.+  However the units contain also information of magnitude.+  E.g. if the base unit would be gramm instead kilogramm+  then the scalars would grow to a factor thousand.++  So is it better to give+  the absolute value unit and the absolute value of the scalar and+  the signum has no unit and the signum of the scalar?+  But the unit may also carry a kind of 'negativity' inside,+  e.g. the electric charge.++  It seems that there is no clear answer.+  However in my synthesizer application+  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+  abs               = lift abs+  signum (Cons _ x) = fromScalarSingle (signum x)+++instance (Ord i, Field.C a) => Field.C (T i a) where+  (Cons xu x) / (Cons yu y) = Cons (xu-yu) (x/y)+  fromRational' = fromScalarSingle . fromRational'++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)++instance (Ord i, Trans.C a) => Trans.C (T i a) where+  pi      = fromScalarSingle pi+  log     = liftM  log+  exp     = liftM  exp+  logBase = liftM2 logBase+  (**)    = liftM2 (**)+  cos     = liftM  cos+  tan     = liftM  tan+  sin     = liftM  sin+  acos    = liftM  acos+  atan    = liftM  atan+  asin    = liftM  asin+  cosh    = liftM  cosh+  tanh    = liftM  tanh+  sinh    = liftM  sinh+  acosh   = liftM  acosh+  atanh   = liftM  atanh+  asinh   = liftM  asinh++instance Ord i => Vector.C (T i) where+  zero  = zero+  (<+>) = (+)+  (*>)  = scale++instance (Ord i, Module.C a v) => Module.C a (T i v) where+  x *> (Cons yu y) = Cons yu (x Module.*> y)++instance (Ord i, VectorSpace.C a v) => VectorSpace.C a (T i v)+++instance (OccScalar.C a v)+      => OccScalar.C a (T i v) where+   toScalar = toScalarDefault+   toMaybeScalar (Cons xu x)+            = guard (Unit.isScalar xu) >> toMaybeScalar x+   fromScalar = fromScalarSingle . fromScalar++++{- Operators for lifting scalar operations to+   operations on physical values -}+instance Functor (T i) where+  fmap f (Cons xu x) =+    if Unit.isScalar xu+    then fromScalarSingle (f x)+    else error "Physics.Quantity.Value.fmap: function for scalars, only"++instance Monad (T i) where+  (>>=) (Cons xu x) f =+    if Unit.isScalar xu+    then f x+    else error "Physics.Quantity.Value.(>>=): function for scalars, only"+  return = fromScalarSingle
+ src/Number/Physical/Read.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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.+-}++module Number.Physical.Read where++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++mulPrec :: Int+mulPrec = 7++-- How to handle the 'prec' argument?+readsNat :: (Enum i, Ord i, Read v, VectorSpace.C a v) =>+   Db.T i a -> Int -> ReadS (Value.T i v)+readsNat db prec =+   readParen (prec>=mulPrec)+      (map (\(x, rest) ->+             let (Value.Cons cu c, rest') = readUnitPart (createDict db) rest+             in  (Value.Cons cu (c *> x), rest'))+       .+       readsPrec mulPrec)++readUnitPart :: (Ord i, Field.C a) =>+   Map String (Value.T i a)+      -> String -> (Value.T i a, String)+readUnitPart dict str =+   let parseUnit =+          do p    <- parseProduct+             rest <- many anyChar+             return (product (map (\(unit,n) ->+                        Map.findWithDefault+                           (error ("unknown unit '" ++ unit ++ "'")) unit dict+                           ^ n) p),+                     rest)+   in  case parse parseUnit "unit" str of+          Left  msg -> error (show msg)+          Right val -> val+++{-| This function could also return the value,+    but a list of pairs (String, Integer) is easier for testing. -}+parseProduct :: Parser [(String, Integer)]+parseProduct =+   skipMany space >>+      ((do p <- ignoreSpace parsePower+           t <- parseProductTail+           return (p : t)) <|>+       parseProductTail)++parseProductTail :: Parser [(String, Integer)]+parseProductTail =+   let parseTail c f = +         do ignoreSpace (char c)+            p <- ignoreSpace parsePower+            t <- parseProductTail+            return (f p : t)+   in  parseTail '*' id <|>+       parseTail '/' (\(x,n) -> (x,-n)) <|>+       return []++parsePower :: Parser (String, Integer)+parsePower =+   do w <- ignoreSpace (many1 (letter <|> char '\181'))+      e <- liftM read (ignoreSpace (char '^') >> many1 digit) <|> return 1+      return (w,e)++{- Turns a parser into one that ignores subsequent whitespaces. -}+ignoreSpace :: Parser a -> Parser a+ignoreSpace p =+   do x <- p+      skipMany space+      return x+++createDict :: Db.T i a -> Map String (Value.T i a)+createDict db =+   Map.fromList (concatMap+      (\Db.UnitSet {Db.unit = xu, Db.scales = s}+           -> map (\Db.Scale {Db.symbol = sym, Db.magnitude = x}+                       -> (sym, Value.Cons xu x)) s) db)
+ src/Number/Physical/Show.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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.+-}++module Number.Physical.Show where++import qualified Number.Physical              as Value+import qualified Number.Physical.UnitDatabase as Db+import Number.Physical.UnitDatabase+          (UnitSet, Scale, reciprocal, magnitude, symbol, scales)++import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.Field               as Field+import qualified Algebra.Ring                as Ring++import Data.List(find)+import Data.Maybe(mapMaybe)++import NumericPrelude+import PreludeBase+++mulPrec :: Int+mulPrec = 7++{-| Show the physical quantity in a human readable form+    with respect to a given unit data base. -}+showNat :: (Ord i, Show v, Field.C a, Ord a, NormedMax.C a v) =>+   Db.T i a -> Value.T i v -> String+showNat db x =+   let (y, unitStr) = showSplit db x+   in  if null unitStr+       then show y+       else showsPrec mulPrec y unitStr++{-| Returns the rescaled value as number+    and the unit as string.+    The value can be used re-scale connected values+    and display them under the label of the unit -}+showSplit :: (Ord i, Show v, Field.C a, Ord a, NormedMax.C a v) =>+   Db.T i a -> Value.T i v -> (v, String)+showSplit db (Value.Cons xu x) =+   showScaled x (Db.positiveToFront (Db.decompose xu db))+++showScaled :: (Ord i, Show v, Ord a, Field.C a, NormedMax.C a v) =>+   v -> [UnitSet i a] -> (v, String)+showScaled x [] = (x, "")+showScaled x (us:uss) =+  let (scaledX, sc) = chooseScale x us+  in  (scaledX, showUnitPart False (reciprocal us) sc +++                   concatMap (\us' ->+                      showUnitPart True (reciprocal us') (defScale us')) uss)++{-| Choose a scale where the number becomes handy+    and return the scaled number and the corresponding scale. -}+chooseScale :: (Ord i, Show v, Ord a, Field.C a, NormedMax.C a v) =>+   v -> UnitSet i a -> (v, Scale a)+chooseScale x us =+   let sc = findCloseScale (NormedMax.norm x) (+               {- you should not reverse earlier,+                  otherwise the index of the default unit is wrong -}+               if reciprocal us+               then scales us+               else reverse (scales us))+   in  ((1 / magnitude sc) *> x, sc)+++showUnitPart :: Bool -> Bool -> Scale a -> String+showUnitPart multSign rec sc =+   if rec+   then "/" ++ symbol sc+   else -- the multiplication sign can be omitted before the first unit component+        (if multSign then "*" else " ") ++ symbol sc++defScale :: UnitSet i v -> Scale v+defScale Db.UnitSet{Db.defScaleIx=def, Db.scales=scs} = scs!!def++findCloseScale :: (Ord a, Field.C a) => a -> [Scale a] -> Scale a+findCloseScale _ [sc]     = sc+findCloseScale x (sc:scs) =+   if 0.9 * magnitude sc < x+   then sc+   else findCloseScale x scs+findCloseScale _ _        =+   error "There must be at least one scale for a unit."++{-| unused -}+totalDefScale :: Ring.C a => Db.T i a -> a+totalDefScale =+   foldr (\us -> (magnitude (defScale us) *)) 1++{-| unused -}+getUnit :: Ring.C a => String -> Db.T i a -> Value.T i a+getUnit sym = Db.extractOne .+   (mapMaybe (\Db.UnitSet{Db.unit=u, scales=scs} ->+      fmap (Value.Cons u . magnitude) (find ((sym==) . symbol) scs)))
+ src/Number/Physical/Unit.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2003-2006+License     :  GPL++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable++Abstract Physical Units+-}++module Number.Physical.Unit where++import MathObj.DiscreteMap (strip)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe(fromJust,fromMaybe)++import qualified Number.Ratio as Ratio++import NumericPrelude.Condition(toMaybe)++import PreludeBase+import NumericPrelude++{- | A Unit.T is a sparse vector with integer entries+   Each map n->m means that the unit of the n-th dimension+   is given m times.++   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)]++   In future I want to have more abstraction here,+   e.g. a type class from the Edison project+   that abstracts from the underlying implementation.+   Then one can easily switch between+   Arrays, Binary trees (like Map) and what know I.+-}+type T i = Map i Int++-- | The neutral Unit.T+scalar :: T i+scalar = Map.empty++-- | Test for the neutral Unit.T+isScalar ::  T i -> Bool+isScalar = Map.null++-- | Convert a List to sparse Map representation+-- Example: [-1,0,-2] -> [(0,-1),(2,-2)]+fromVector :: (Enum i, Ord i) => [Int] -> T i+fromVector x = strip (Map.fromList (zip [toEnum 0 .. toEnum ((length x)-1)] x))++-- | Convert Map to a List+toVector :: (Enum i, Ord i) => T i -> [Int]+toVector x = map (flip (Map.findWithDefault 0) x)+                     [(toEnum 0)..(maximum (Map.keys x))]+++ratScale :: Ratio.T Int -> T i -> T i+ratScale expo =+   fmap (fromMaybe (error "Physics.Quantity.Unit.ratScale: fractional result")) .+   ratScaleMaybe2 expo++ratScaleMaybe :: Ratio.T Int -> T i -> Maybe (T i)+ratScaleMaybe expo u =+   let fmMaybe = ratScaleMaybe2 expo u+   in  toMaybe (not (Nothing `elem` Map.elems fmMaybe))+               (fmap fromJust fmMaybe)++-- helper function for ratScale and ratScaleMaybe+ratScaleMaybe2 :: Ratio.T Int -> T i -> Map i (Maybe Int)+ratScaleMaybe2 expo =+   fmap (\c -> let y = Ratio.scale c expo+               in  toMaybe (denominator y == 1) (numerator y))+++{- impossible because Unit.T is a type synonyme but not a data type+instance Show (Unit.T i) where+  show = show.toVector+-}
+ src/Number/Physical/UnitDatabase.hs view
@@ -0,0 +1,186 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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+-}++module Number.Physical.UnitDatabase where++import qualified Number.Physical.Unit as Unit+import qualified Algebra.Field as Field++-- import Algebra.Module((*>))+import Algebra.NormedSpace.Sum(norm)++import NumericPrelude.Condition (toMaybe)+import Data.List (findIndices, partition, unfoldr, find, minimumBy)++import PreludeBase+import NumericPrelude++type T i a = [UnitSet i a]++-- since field names are reused for accessor functions+-- they are global identifiers and can't be reused+data InitUnitSet i a =+  InitUnitSet {+    initUnit        :: Unit.T i,+    initIndependent :: Bool,+    initScales      :: [InitScale a]+  }++data InitScale a =+  InitScale {+    initSymbol  :: String,+    initMag     :: a,+    initIsUnit  :: Bool,+    initDefault :: Bool+  }++-- | An entry for a unit and there scalings.+data UnitSet i a =+  UnitSet {+    unit        :: Unit.T i,+    independent :: Bool,+    defScaleIx  :: Int,+    reciprocal  :: Bool,  {-^ If True the symbols must be preceded with a '/'.+                              Though it sounds like an attribute of Scale+                              it must be the same for all scales and we need it+                              to sort positive powered unitsets to the front+                              of the list of unit components. -}+    scales      :: [Scale a]+  }+  deriving Show++-- | A common scaling for a unit.+data Scale a =+  Scale {+    symbol     :: String,+    magnitude  :: a+  }+  deriving Show+++-- extract the element from a list containing exact one element+-- fails if there are zero or more than one element+-- 'head' fails only if there are zero elements+extractOne :: [a] -> a+extractOne (x:[]) = x+extractOne _      = error "There must be exactly one default unit in the data base."++initScale   :: String -> a -> Bool -> Bool -> InitScale a+initScale   = InitScale+initUnitSet :: Unit.T i -> Bool -> [InitScale a] -> InitUnitSet i a+initUnitSet = InitUnitSet++createScale :: InitScale a -> Scale a+createScale (InitScale sym mg _ _) = (Scale sym mg)++createUnitSet :: InitUnitSet i a -> UnitSet i a+createUnitSet (InitUnitSet u ind scs) = (UnitSet u ind+    (extractOne (findIndices initDefault scs))+    False+    (map createScale scs)+  )++{- Filter out all scales intended for showing.+   If there is none return Nothing. -}+showableUnit :: InitUnitSet i a -> Maybe (InitUnitSet i a)+showableUnit (InitUnitSet u ind scs) =+   let sscs = filter initIsUnit scs+   in  toMaybe (not (null sscs)) (InitUnitSet u ind sscs)+++{- | Raise all scales of a unit and the unit itself to the n-th power -}+powerOfUnitSet :: (Ord i, Field.C a) => Int -> UnitSet i a -> UnitSet i a+powerOfUnitSet n us@UnitSet { unit = u, reciprocal = rec, scales = scs } =+   us { unit = n *> u,+        reciprocal = rec == (n>0),  -- flip sign+        scales = map (powerOfScale n) scs }+++powerOfScale :: Field.C a => Int -> Scale a -> Scale a+powerOfScale n Scale { symbol = sym, magnitude = mag } =+   if n>0+   then Scale { symbol = sym ++ showExp   n,  magnitude = ringPower  n mag }+   else Scale { symbol = sym ++ showExp (-n), magnitude = fieldPower n mag }++showExp :: Int -> String+showExp 1    = ""+--showExp 2    = "²"+--showExp 3    = "³"+showExp expo = "^" ++ show expo+++{- | Reorder the unit components in a way+     that the units with positive exponents lead the list. -}+positiveToFront :: [UnitSet i a] -> [UnitSet i a]+positiveToFront = uncurry (++) . partition (not . reciprocal)++-- | Decompose a complex unit into common ones+decompose :: (Ord i, Field.C a) => Unit.T i -> T i a -> [UnitSet i a]+decompose u db =+   case (findIndep u db) of+      Just us -> [us]+      Nothing ->+        unfoldr (\urem ->+          toMaybe (not (Unit.isScalar urem))+                  (let us = findClosest urem db+                   in  (us, subtract (unit us) urem))+        ) u++findIndep :: (Eq i) => Unit.T i -> T i a -> Maybe (UnitSet i a)+findIndep u = find (\UnitSet {unit=un} -> u==un) . filter independent++findClosest :: (Ord i, Field.C a) => Unit.T i -> T i a -> UnitSet i a+findClosest u =+   fst . minimumBy (\(_,dist0) (_,dist1) -> compare dist0 dist1) .+            evalDist u . filter (not.independent)++evalDist :: (Ord i, Field.C a)+   => Unit.T i+   -> T i a+   -> [(UnitSet i a, Int)] {-^ (UnitSet,distance)   the UnitSet may contain powered units -}+evalDist target = map (\us->+    let (expo,dist)=findBestExp target (unit us)+    in  (powerOfUnitSet expo us, dist)+  )++findBestExp :: (Ord i) => Unit.T i -> Unit.T i -> (Int, Int)+findBestExp target u =+  let bestl = findMinExp (distances target (listMultiples (subtract u) (-1)))+      bestr = findMinExp (distances target (listMultiples ((+)      u)   1 ))+  in  if distLE bestl bestr+      then bestl+      else bestr++{-|+  Find the exponent that lead to minimal distance+  Since the list is infinite 'maximum' will fail+  but the sequence is convex+  and thus we can abort when the distance stop falling+-}+findMinExp :: [(Int, Int)] -> (Int, Int)+findMinExp (x0:x1:rest) =+  if distLE x0 x1+  then x0+  else findMinExp (x1:rest)+findMinExp _ = error "List of unit approximations with respect to the unit exponent must be infinite."++distLE :: (Int, Int) -> (Int, Int) -> Bool+distLE (_,dist0) (_,dist1) = dist0<=dist1+--distLE (exp0,dist0) (exp1,dist1) = (dist0<dist1) || (dist0==dist1 && (abs exp0) <= (abs exp1))++-- [(exponent,unit)] -> [(exponent,distance)]+distances :: (Ord i) => Unit.T i -> [(Int, Unit.T i)] -> [(Int, Int)]+distances targetu = map (\(expo,u)->(expo, norm (subtract u targetu)))++listMultiples :: (Unit.T i -> Unit.T i) -> Int -> [(Int, Unit.T i)]+listMultiples f dir = iterate (\(expo,u)->(expo+dir,f u)) (0,Unit.scalar)
+ src/Number/Positional.hs view
@@ -0,0 +1,1393 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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> .+-}+module Number.Positional where++import qualified MathObj.LaurentPolynomial as LPoly+import qualified MathObj.Polynomial        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 PreludeBase+import NumericPrelude hiding (sqrt, tan, one, zero, )++import qualified Data.List as List+import Data.Char (intToDigit)++import NumericPrelude.Condition (toMaybe, select, if')+import NumericPrelude.List      (replicateMatch, sliceVert, zipNeighborsWith,+                                 padLeft, padRight, mapLast)+++{-+bugs:++defltBase = 10+defltExp = 4++(sqrt 0.5) -- wrong result, probably due to undetected overflows+-}++{- * types -}++type T = (Exponent, Mantissa)+type FixedPoint = (Integer, Mantissa)+type Mantissa = [Digit]+type Digit    = Int+type Exponent = Int+type Basis    = Int+++{- * basic helpers -}++moveToZero :: Basis -> Digit -> (Digit,Digit)+moveToZero b n =+   let b2 = NP.div b 2+       (q,r) = divMod (n+b2) b+   in  (q,r-b2)++checkPosDigit :: Basis -> Digit -> Digit+checkPosDigit b d =+   if d>=0 && d<b+     then d+     else error ("digit " ++ show d ++ " out of range [0," ++ show b ++ ")")++checkDigit :: Basis -> Digit -> Digit+checkDigit b d =+   if abs d < b+     then d+     else error ("digit " ++ show d ++ " out of range ("+                   ++ show (-b) ++ "," ++ show b ++ ")")++{- |+Converts all digits to non-negative digits,+that is the usual positional representation.+However the conversion will fail+when the remaining digits are all zero.+(This cannot be improved!)+-}+nonNegative :: Basis -> T -> T+nonNegative b x =+   let (xe,xm) = compress b x+   in  (xe, nonNegativeMant b xm)++{- |+Requires, that no digit is @(basis-1)@ or @(1-basis)@.+The leading digit might be negative and might be @-basis@ or @basis@.+-}+nonNegativeMant :: Basis -> Mantissa -> Mantissa+nonNegativeMant b =+   let recurse (x0:x1:xs) =+          select (replaceZeroChain x0 (x1:xs))+             [(x1 >=  1,  x0    : recurse (x1:xs)),+              (x1 <= -1, (x0-1) : recurse ((x1+b):xs))]+       recurse xs = xs++       replaceZeroChain x xs =+          let (xZeros,xRem) = span (0==) xs+          in  case xRem of+                [] -> (x:xs)  -- keep trailing zeros, because they show precision in 'show' functions+                (y:ys) ->+                  if y>=0  -- equivalent to y>0+                    then x     : replicateMatch xZeros 0     ++ recurse xRem+                    else (x-1) : replicateMatch xZeros (b-1) ++ recurse ((y+b) : ys)++   in  recurse+++{- |+May prepend a digit.+-}+compress :: Basis -> T -> T+compress _ x@(_, []) = x+compress b (xe, xm) =+   let (hi:his,los) = unzip (map (moveToZero b) xm)+   in  prependDigit hi (xe, Poly.add his los)++{- |+Compress first digit.+May prepend a digit.+-}+compressFirst :: Basis -> T -> T+compressFirst _ x@(_, []) = x+compressFirst b (xe, x:xs) =+   let (hi,lo) = moveToZero b x+   in  prependDigit hi (xe, lo:xs)++{- |+Does not prepend a digit.+-}+compressMant :: Basis -> Mantissa -> Mantissa+compressMant _ [] = []+compressMant b (x:xs) =+   let (his,los) = unzip (map (moveToZero b) xs)+   in  Poly.add his (x:los)++{- |+Compress second digit.+Sometimes this is enough to keep the digits in the admissible range.+Does not prepend a digit.+-}+compressSecondMant :: Basis -> Mantissa -> Mantissa+compressSecondMant b (x0:x1:xs) =+   let (hi,lo) = moveToZero b x1+   in  x0+hi : lo : xs+compressSecondMant _ xm = xm++prependDigit :: Basis -> T -> T+prependDigit 0 x = x+prependDigit x (xe, xs) = (xe+1, x:xs)++{- |+Eliminate leading zero digits.+This will fail for zero.+-}+trim :: T -> T+trim (xe,xm) =+   let (xZero, xNonZero) = span (0 ==) xm+   in  (xe - length xZero, xNonZero)++{- |+Trim until a minimum exponent is reached.+Safe for zeros.+-}+trimUntil :: Exponent -> T -> T+trimUntil e =+   until (\(xe,xm) -> xe<=e ||+              not (null xm || head xm == 0)) trimOnce++trimOnce :: T -> T+trimOnce (xe,[])   = (xe-1,[])+trimOnce (xe,0:xm) = (xe-1,xm)+trimOnce x = x++{- |+Accept a high leading digit for the sake of a reduced exponent.+This eliminates one leading digit.+Like 'pumpFirst' but with exponent management.+-}+decreaseExp :: Basis -> T -> T+decreaseExp b (xe,xm) =+   (xe-1, pumpFirst b xm)++{- |+Merge leading and second digit.+This is somehow an inverse of 'compressMant'.+-}+pumpFirst :: Basis -> Mantissa -> Mantissa+pumpFirst b xm =+   case xm of+     (x0:x1:xs) -> x0*b+x1:xs+     (x0:[])    -> x0*b:[]+     []         -> []++decreaseExpFP :: Basis -> (Exponent, FixedPoint) ->+                          (Exponent, FixedPoint)+decreaseExpFP b (xe,xm) =+   (xe-1, pumpFirstFP b xm)++pumpFirstFP :: Basis -> FixedPoint -> FixedPoint+pumpFirstFP b (x,xm) =+   let xb = x * fromIntegral b+   in  case xm of+         (x0:xs) -> (xb + fromIntegral x0, xs)+         []      -> (xb, [])++{- |+Make sure that a number with absolute value less than 1+has a (small) negative exponent.+Also works with zero because it chooses an heuristic exponent for stopping.+-}+negativeExp :: Basis -> T -> T+negativeExp b x =+   let tx  = trimUntil (-10) x+   in  if fst tx >=0 then decreaseExp b tx else tx+++{- * conversions -}++{- ** integer -}++fromBaseCardinal :: Basis -> Integer -> T+fromBaseCardinal b n =+   let mant = mantissaFromCard b n+   in  (length mant - 1, mant)++fromBaseInteger :: Basis -> Integer -> T+fromBaseInteger b n =+   if n<0+     then neg b (fromBaseCardinal b (negate n))+     else fromBaseCardinal b n++mantissaToNum :: Ring.C a => Basis -> Mantissa -> a+mantissaToNum bInt =+   let b = fromIntegral bInt+   in  foldl (\x d -> x*b + fromIntegral d) 0++mantissaFromCard :: (ToInteger.C a) => Basis -> a -> Mantissa+mantissaFromCard bInt n =+   let b = NP.fromIntegral bInt+   in  reverse (map NP.fromIntegral+          (Integral.decomposeVarPositional (repeat b) n))++mantissaFromInt :: (ToInteger.C a) => Basis -> a -> Mantissa+mantissaFromInt b n =+   if n<0+     then negate (mantissaFromCard b (negate n))+     else mantissaFromCard b n++mantissaFromFixedInt :: Basis -> Exponent -> Integer -> Mantissa+mantissaFromFixedInt bInt e n =+   let b = NP.fromIntegral bInt+   in  map NP.fromIntegral (uncurry (:) (List.mapAccumR+          (\x () -> divMod x b)+          n (replicate (pred e) ())))+++{- ** rational -}++fromBaseRational :: Basis -> Rational -> T+fromBaseRational bInt x =+   let b = NP.fromIntegral bInt+       xDen = denominator x+       (xInt,xNum) = divMod (numerator x) xDen+       (xe,xm) = fromBaseInteger bInt xInt+       xFrac = List.unfoldr+                 (\num -> toMaybe (num/=0) (divMod (num*b) xDen)) xNum+   in  (xe, xm ++ map NP.fromInteger xFrac)++{- ** fixed point -}++{- |+Split into integer and fractional part.+-}+toFixedPoint :: Basis -> T -> FixedPoint+toFixedPoint b (xe,xm) =+   if xe>=0+     then let (x0,x1) = splitAtPadZero (xe+1) xm+          in  (mantissaToNum b x0, x1)+     else (0, replicate (- succ xe) 0 ++ xm)++fromFixedPoint :: Basis -> FixedPoint -> T+fromFixedPoint b (xInt,xFrac) =+   let (xe,xm) = fromBaseInteger b xInt+   in  (xe, xm++xFrac)+++{- ** floating point -}++toDouble :: Basis -> T -> Double+toDouble b (xe,xm) =+   let txm = take (mantLengthDouble b) xm+       bf  = fromIntegral b+       br  = recip bf+   in  fieldPower xe bf * foldr (\xi y -> fromIntegral xi + y*br) 0 txm++{- |+cf. 'Numeric.floatToDigits'+-}+fromDouble :: Basis -> Double -> T+fromDouble b x =+   let (n,frac) = splitFraction x+       (mant,e) = P98.decodeFloat frac+       fracR    = alignMant b (-1)+                     (fromBaseRational b (mant % ringPower (-e) 2))+   in  fromFixedPoint b (n, fracR)++{- |+Only return as much digits as are contained in Double.+This will speedup further computations.+-}+fromDoubleApprox :: Basis -> Double -> T+fromDoubleApprox b x =+   let (xe,xm) = fromDouble b x+   in  (xe, take (mantLengthDouble b) xm)++fromDoubleRough :: Basis -> Double -> T+fromDoubleRough b x =+   let (xe,xm) = fromDouble b x+   in  (xe, take 2 xm)++mantLengthDouble :: Basis -> Exponent+mantLengthDouble b =+   let fi = fromIntegral :: Int -> Double+       x  = undefined :: Double+   in  ceiling+          (logBase (fi b) (fromInteger (P98.floatRadix x)) *+             fi (P98.floatDigits x))++liftDoubleApprox :: Basis -> (Double -> Double) -> T -> T+liftDoubleApprox b f = fromDoubleApprox b . f . toDouble b++liftDoubleRough :: Basis -> (Double -> Double) -> T -> T+liftDoubleRough b f = fromDoubleRough b . f . toDouble b+++{- ** text -}++{- |+Show a number with respect to basis @10^e@.+-}+showDec :: Exponent -> T -> String+showDec = showBasis 10++showHex :: Exponent -> T -> String+showHex = showBasis 16++showBin :: Exponent -> T -> String+showBin = showBasis 2++showBasis :: Basis -> Exponent -> T -> String+showBasis b e xBig =+   let x = rootBasis b e xBig+       (sign,absX) =+          case cmp b x (fst x,[]) of+             LT -> ("-", neg b x)+             _  -> ("", x)+       (int, frac) = toFixedPoint b (nonNegative b absX)+       checkedFrac = map (checkPosDigit b) frac+       intStr =+          if b==10+            then show int+            else map intToDigit (mantissaFromInt b int)+   in  sign ++ intStr ++ '.' : map intToDigit checkedFrac+++{- ** basis -}++{- |+Convert from a @b@ basis representation to a @b^e@ basis.++Works well with every exponent.+-}+powerBasis :: Basis -> Exponent -> T -> T+powerBasis b e (xe,xm) =+   let (ye,r)  = divMod xe e+       (y0,y1) = splitAtPadZero (r+1) xm+       y1pad   = mapLast (padRight 0 e) (sliceVert e y1)+   in  (ye, map (mantissaToNum b) (y0 : y1pad))++{- |+Convert from a @b^e@ basis representation to a @b@ basis.++Works well with every exponent.+-}+rootBasis :: Basis -> Exponent -> T -> T+rootBasis b e (xe,xm) =+   let splitDigit d = padLeft 0 e (mantissaFromInt b d)+   in  nest (e-1) trimOnce+            ((xe+1)*e-1, concatMap splitDigit (map (checkDigit (ringPower e b)) xm))++{- |+Convert between arbitrary bases.+This conversion is expensive (quadratic time).+-}+fromBasis :: Basis -> Basis -> T -> T+fromBasis bDst bSrc x =+   let (int,frac) = toFixedPoint bSrc x+   in  fromFixedPoint bDst (int, fromBasisMant bDst bSrc frac)++fromBasisMant :: Basis -> Basis -> Mantissa -> Mantissa+fromBasisMant _    _    [] = []+fromBasisMant bDst bSrc xm =+   let {- We use a counter that alerts us,+          when the digits are grown too much by Poly.scale.+          Then it is time to do some carry/compression.+          'inc' is essentially the fractional number digits+          needed to represent the destination base in the source base.+          It is multiplied by 'unit' in order to allow integer computation. -}+       inc = ceiling+                (logBase (fromIntegral bSrc) (fromIntegral bDst)+                     * unit * 1.1 :: Double)+          -- Without the correction factor, invalid digits are emitted - why?+       unit :: Ring.C a => a+       unit = 10000+       {-+       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+       -}+       cmpr (mag,xs) = (mag - unit, compressMant bSrc xs)++       scl (_,[]) = Nothing+       scl (mag,xs) =+          let (newMag,y:ys) =+                 until ((<unit) . fst) cmpr+                       (mag + inc, Poly.scale bDst xs)+              (d,y0) = moveToZero bSrc y+          in  Just (d, (newMag, y0:ys))++   in  List.unfoldr scl (0::Int,xm)+++{- * comparison -}++{- |+The basis must be at least ***.+Note: Equality cannot be asserted in finite time on infinite precise numbers.+If you want to assert, that a number is below a certain threshold,+you should not call this routine directly,+because it will fail on equality.+Better round the numbers before comparison.+-}+cmp :: Basis -> T -> T -> Ordering+cmp b x y =+   let (_,dm) = sub b x y+       {- Only differences above 2 allow a safe decision,+          because 1(-9)(-9)(-9)(-9)... and (-1)9999...+          represent the same number, namely zero. -}+       recurse [] = EQ+       recurse (d:[]) = compare d 0+       recurse (d0:d1:ds) =+          select (recurse (d0*b+d1 : ds))+             [(d0 < -2, LT),+              (d0 >  2, GT)]+   in  recurse dm++{-+Compare two numbers approximately.+This circumvents the infinite loop if both numbers are equal.+If @lessApprox bnd b x y@+then @x@ is definitely smaller than @y@.+The converse is not true.+You should use this one instead of 'cmp' for checking for bounds.+-}+lessApprox :: Basis -> Exponent -> T -> T -> Bool+lessApprox b bnd x y =+   let tx = trunc bnd x+       ty = trunc bnd y+   in  LT == cmp b (liftLaurent2 LPoly.add (bnd,[2]) tx) ty++trunc :: Exponent -> T -> T+trunc bnd (xe, xm) =+   if bnd > xe+     then (bnd, [])+     else (xe, take (1+xe-bnd) xm)++equalApprox :: Basis -> Exponent -> T -> T -> Bool+equalApprox b bnd x y =+   fst (trimUntil bnd (sub b x y)) == bnd++++align :: Basis -> Exponent -> T -> T+align b ye x = (ye, alignMant b ye x)++{- |+Get the mantissa in such a form+that it fits an expected exponent.++@x@ and @(e, alignMant b e x)@ represent the same number.+-}+alignMant :: Basis -> Exponent -> T -> Mantissa+alignMant b e (xe,xm) =+   if e>=xe+     then replicate (e-xe) 0 ++ xm+     else let (xm0,xm1) = splitAtPadZero (xe-e+1) xm+          in  mantissaToNum b xm0 : xm1++absolute :: T -> T+absolute (xe,xm) = (xe, absMant xm)++absMant :: Mantissa -> Mantissa+absMant xa@(x:xs) =+   case compare x 0 of+      EQ -> x : absMant xs+      LT -> Poly.negate xa+      GT -> xa+absMant [] = []+++{- * arithmetic -}++fromLaurent :: LPoly.T Int -> T+fromLaurent (LPoly.Cons nxe xm) = (NP.negate nxe, xm)++toLaurent :: T -> LPoly.T Int+toLaurent (xe, xm) = LPoly.Cons (NP.negate xe) xm++liftLaurent2 ::+   (LPoly.T Int -> LPoly.T Int -> LPoly.T Int) ->+      (T -> T -> T)+liftLaurent2 f x y =+   fromLaurent (f (toLaurent x) (toLaurent y))++liftLaurentMany ::+   ([LPoly.T Int] -> LPoly.T Int) ->+      ([T] -> T)+liftLaurentMany f =+   fromLaurent . f . map toLaurent++{- |+Add two numbers but do not eliminate leading zeros.+-}+add :: Basis -> T -> T -> T+add b x y = compress b (liftLaurent2 LPoly.add x y)++sub :: Basis -> T -> T -> T+sub b x y = compress b (liftLaurent2 LPoly.sub x y)++neg :: Basis -> T -> T+neg _ (xe, xm) = (xe, Poly.negate xm)+++{- |+Add at most @basis@ summands.+More summands will violate the allowed digit range.+-}+addSome :: Basis -> [T] -> T+addSome b = compress b . liftLaurentMany sum++{- |+Add many numbers efficiently by computing sums of sub lists+with only little carry propagation.+-}+addMany :: Basis -> [T] -> T+addMany _ [] = zero+addMany b ys =+   let recurse xs =+          case map (addSome b) (sliceVert b xs) of+            [s]  -> s+            sums -> recurse sums+   in  recurse ys+++type Series = [(Exponent, T)]++{- |+Add an infinite number of numbers.+You must provide a list of estimate of the current remainders.+The estimates must be given as exponents of the remainder.+If such an exponent is too small, the summation will be aborted.+If exponents are too big, computation will become inefficient.+-}+series :: Basis -> Series -> T+series _ [] = error "empty series: don't know a good exponent"+-- series _ [] = (0,[]) -- unfortunate choice of exponent+series b summands =+   {- Some pre-processing that asserts decreasing exponents.+      Increasing coefficients can appear legally+      due to non-unique number representation. -}+   let (es,xs)    = unzip summands+       safeSeries = zip (scanl1 min es) xs+   in  seriesPlain b safeSeries++seriesPlain :: Basis -> Series -> T+seriesPlain _ [] = error "empty series: don't know a good exponent"+seriesPlain b summands =+   let (es,m:ms) = unzip (map (uncurry (align b)) summands)+       eDifs     = zipNeighborsWith (-) es+       eDifLists = sliceVert (pred b) eDifs+       mLists    = sliceVert (pred b) ms+       accum sumM (eDifList,mList) =+          let subM = LPoly.addShiftedMany eDifList (sumM:mList)+              -- lazy unary sum+              len = concatMap (flip replicate ()) eDifList+              (high,low)  = splitAtMatchPadZero len subM+          {-+          'compressMant' looks unsafe+          when the residue doesn't decrease for many summands.+          Then there is a leading digit of a chunk+          which is not compressed for long time.+          However, if the residue is estimated correctly+          there can be no overflow.+          -}+          in  (compressMant b low, high)+       (trailingDigits, chunks) =+          List.mapAccumL accum m (zip eDifLists mLists)+   in  compress b (head es, concat chunks ++ trailingDigits)++{-+An alternative series implementation+could reduce carries by do the following cycle+(split, add sub-lists).+This would reduce carries to the minimum+but we must work hard in order to find out lazily+how many digits can be emitted.+-}+++{- |+Like 'splitAt',+but it pads with zeros if the list is too short.+This way it preserves+ @ length (fst (splitAtPadZero n xs)) == n @+-}+splitAtPadZero :: Int -> Mantissa -> (Mantissa, Mantissa)+splitAtPadZero n [] = (replicate n 0, [])+splitAtPadZero 0 xs = ([], xs)+splitAtPadZero n (x:xs) =+   let (ys, zs) = splitAtPadZero (n-1) xs+   in  (x:ys, zs)+-- must get a case for negative index++splitAtMatchPadZero :: [()] -> Mantissa -> (Mantissa, Mantissa)+splitAtMatchPadZero n  [] = (replicateMatch n 0, [])+splitAtMatchPadZero [] xs = ([], xs)+splitAtMatchPadZero n (x:xs) =+   let (ys, zs) = splitAtMatchPadZero (tail n) xs+   in  (x:ys, zs)+++{- |+help showing series summands+-}+truncSeriesSummands :: Series -> Series+truncSeriesSummands = map (\(e,x) -> (e,trunc (-20) x))++++scale :: Basis -> Digit -> T -> T+scale b y x = compress b (scaleSimple y x)++{-+scaleSimple :: ToInteger.C a => a -> T -> T+scaleSimple y (xe, xm) = (xe, Poly.scale (fromIntegral y) xm)+-}++scaleSimple :: Basis -> T -> T+scaleSimple y (xe, xm) = (xe, Poly.scale y xm)++scaleMant :: Basis -> Digit -> Mantissa -> Mantissa+scaleMant b y xm = compressMant b (Poly.scale y xm)++++mulSeries :: Basis -> T -> T -> Series+mulSeries _ (xe,[]) (ye,_) = [(xe+ye, zero)]+mulSeries b (xe,xm) (ye,ym) =+   let zes = iterate pred (xe+ye+1)+       zs  = zipWith (\xd e -> scale b xd (e,ym)) xm (tail zes)+   in  zip zes zs++{- |+For obtaining n result digits it is mathematically sufficient+to know the first (n+1) digits of the operands.+However this implementation needs (n+2) digits,+because of calls to 'compress' in both 'scale' and 'series'.+We should fix that.+-}+mul :: Basis -> T -> T -> T+mul b x y = trimOnce (seriesPlain b (mulSeries b x y))++++{- |+Undefined if the divisor is zero - of course.+Because it is impossible to assert that a real is zero,+the routine will not throw an error in general.++ToDo: Rigorously derive the minimal required magnitude of the leading divisor digit.+-}+divide :: Basis -> T -> T -> T+divide b (xe,xm) (ye',ym') =+   let (ye,ym) = until ((>=b) . abs . head . snd)+                       (decreaseExp b)+                       (ye',ym')+   in  nest 3 trimOnce (compress b (xe-ye, divMant b ym xm))++divMant :: Basis -> Mantissa -> Mantissa -> Mantissa+divMant _ [] _   = error "Number.Positional: division by zero"+divMant b ym xm0 =+   snd $+   List.mapAccumL+      (\xm fullCompress ->+       let z = div (head xm) (head ym)+           {- 'scaleMant' contains compression,+              which is not much of a problem,+              because it is always applied to @ym@.+              That is, there is no nested call. -}+           dif = pumpFirst b (Poly.sub xm (scaleMant b z ym))+           cDif = if fullCompress+                    then compressMant       b dif+                    else compressSecondMant b dif+       in  (cDif, z))+   xm0 (cycle (replicate (b-1) False ++ [True]))++divMantSlow :: Basis -> Mantissa -> Mantissa -> Mantissa+divMantSlow _ [] = error "Number.Positional: division by zero"+divMantSlow b ym =+   List.unfoldr+      (\xm ->+       let z = div (head xm) (head ym)+           d = compressMant b (pumpFirst b+                  (Poly.sub xm (Poly.scale z ym)))+       in  Just (z, d))++reciprocal :: Basis -> T -> T+reciprocal b = divide b one+++{- |+Fast division for small integral divisors,+which occur for instance in summands of power series.+-}+divIntMant :: Basis -> Int -> Mantissa -> Mantissa+divIntMant b y xInit =+   List.unfoldr (\(r,rxs) ->+             let rb = r*b+                 (rbx, xs', run) =+                    case rxs of+                       []     -> (rb,   [], r/=0)+                       (x:xs) -> (rb+x, xs, True)+                 (d,m) = divMod rbx y+             in  toMaybe run (d, (m, xs')))+           (0,xInit)++-- this version is simple but ignores the possibility of a terminating result+divIntMantInf :: Basis -> Int -> Mantissa -> Mantissa+divIntMantInf b y =+   map fst . tail .+      scanl (\(_,r) x -> divMod (r*b+x) y) (undefined,0) .+         (++ repeat 0)++divInt :: Basis -> Digit -> T -> T+divInt b y (xe,xm) =+   -- (xe, divIntMant b y xm)+   let z  = (xe, divIntMant b y xm)+       {- Division by big integers may cause leading zeros.+          Eliminate as many as we can expect from the division.+          If the input number has leading zeros (it might be equal to zero),+          then the result may have, too. -}+       tz = until ((<=1) . fst) (\(yi,zi) -> (div yi b, trimOnce zi)) (y,z)+   in  snd tz+++{- * algebraic functions -}+++sqrt :: Basis -> T -> T+sqrt b = sqrtDriver b sqrtFP++sqrtDriver :: Basis -> (Basis -> FixedPoint -> Mantissa) -> T -> T+sqrtDriver _ _ (xe,[]) = (div xe 2, [])+sqrtDriver b sqrtFPworker x =+   let (exe,ex0:exm) = if odd (fst x) then decreaseExp b x else x+       (nxe,(nx0,nxm)) =+           until (\xi -> fst (snd xi) >= fromIntegral b ^ 2)+                 (nest 2 (decreaseExpFP b))+                 (exe, (fromIntegral ex0, exm))+   in  compress b (div nxe 2, sqrtFPworker b (nx0,nxm))+++sqrtMant :: Basis -> Mantissa -> Mantissa+sqrtMant _ [] = []+sqrtMant b (x:xs) =+   sqrtFP b (fromIntegral x, xs)++{- |+Square root.++We need a leading digit of type Integer,+because we have to collect up to 4 digits.+This presentation can also be considered as 'FixedPoint'.++ToDo:+Rigorously derive the minimal required magnitude+of the leading digit of the root.++Mathematically the @n@th digit of the square root+depends roughly only on the first @n@ digits of the input.+This is because @sqrt (1+eps) `equalApprox` 1 + eps\/2@.+However this implementation requires @2*n@ input digits+for emitting @n@ digits.+This is due to the repeated use of 'compressMant'.+It would suffice to fully compress only every @basis@th iteration (digit)+and compress only the second leading digit in each iteration.+++Can the involved operations be made lazy enough to solve+@y = (x+frac)^2@+by+@frac = (y-x^2-frac^2) \/ (2*x)@ ?+-}+sqrtFP :: Basis -> FixedPoint -> Mantissa+sqrtFP b (x0,xs) =+   let y0   = round (NP.sqrt (fromInteger x0 :: Double))+       dyx0 = fromInteger (x0 - fromIntegral y0 ^ 2)++       accum dif (e,ty) =+          -- (e,ty) == xm - (trunc j y)^2+          let yj = div (head dif + y0) (2*y0)+              newDif = pumpFirst b $+                 LPoly.addShifted e+                    (Poly.sub dif (scaleMant b (2*yj) ty))+                    [yj*yj]+              {- We could always compress the full difference number,+                 but it is not necessary,+                 and we save dependencies on less significant digits. -}+              cNewDif =+                 if mod e b == 0+                   then compressMant       b newDif+                   else compressSecondMant b newDif+          in  (cNewDif, yj)++       truncs = lazyInits y+       y = y0 : snd (List.mapAccumL+                        accum+                        (pumpFirst b (dyx0 : xs))+                        (zip [1..] (drop 2 truncs)))+   in  y+++sqrtNewton :: Basis -> T -> T+sqrtNewton b = sqrtDriver b sqrtFPNewton++{- |+Newton iteration doubles the number of correct digits in every step.+Thus we process the data in chunks of sizes of powers of two.+This way we get fastest computation possible with Newton+but also more dependencies on input than necessary.+The question arises whether this implementation still fits the needs+of computational reals.+The input is requested as larger and larger chunks,+and the input itself might be computed this way,+e.g. a repeated square root.+Requesting one digit too much,+requires the double amount of work for the input computation,+which in turn multiplies time consumption by a factor of four,+and so on.++Optimal fast implementation of one routine+does not preserve fast computation of composed computations.++The routine assumes, that the integer parts is at least @b^2.@+-}+sqrtFPNewton :: Basis -> FixedPoint -> Mantissa+sqrtFPNewton bInt (x0,xs) =+   let b = fromIntegral bInt+       chunkLengths = iterate (2*) 1+       xChunks = map (mantissaToNum bInt) $ snd $+            List.mapAccumL (\x cl -> flipPair (splitAtPadZero cl x))+                           xs chunkLengths+       basisPowers = iterate (^2) b+       truncXs = scanl (\acc (bp,frac) -> acc*bp+frac) x0+                       (zip basisPowers xChunks)+       accum y (bp, x) =+          let ybp  = y * bp+              newY = div (ybp + div (x * div bp b) y) 2+          in  (newY, newY-ybp)+       y0 = round (NP.sqrt (fromInteger x0 :: Double))+       yChunks = snd $ List.mapAccumL accum+                         y0 (zip basisPowers (tail truncXs))+       yFrac = concat $ zipWith (mantissaFromFixedInt bInt) chunkLengths yChunks+   in  fromInteger y0 : yFrac+++{- |+List.inits is defined by+@inits = foldr (\x ys -> [] : map (x:) ys) [[]]@++This is too strict for our application.+@+Prelude> List.inits (0:1:2:undefined)+[[],[0],[0,1]*** Exception: Prelude.undefined+@++The following routine is more lazy+but restricted to infinite lists.+-}+lazyInits :: [a] -> [[a]]+lazyInits ~(x:xs)  =  [] : map (x:) (lazyInits xs)+-- this pattern is never reached, GHC does not complain about it+lazyInits []  =  [[]]++++{- * transcendent functions -}++{- ** exponential functions -}++expSeries :: Basis -> T -> Series+expSeries b xOrig =+   let x   = negativeExp b xOrig+       xps = scanl (\p n -> divInt b n (mul b x p)) one [1..]+   in  map (\xp -> (fst xp, xp)) xps++{- |+Absolute value of argument should be below 1.+-}+expSmall :: Basis -> T -> T+expSmall b x = series b (expSeries b x)+++expSeriesLazy :: Basis -> T -> Series+expSeriesLazy b x@(xe,_) =+   let xps = scanl (\p n -> divInt b n (mul b x p)) one [1..]+       {- much effort for computing the residue exponents+          without touching the arguments mantissa -}+       es :: [Double]+       es = zipWith (-)+               (map fromIntegral (iterate ((1+xe)+) 0))+               (scanl (+) 0+                  (map (logBase (fromIntegral b)+                          . fromInteger) [1..]))+   in  zip (map ceiling es) xps++expSmallLazy :: Basis -> T -> T+expSmallLazy b x = series b (expSeriesLazy b x)+++exp :: Basis -> T -> T+exp b x =+   let (xInt,xFrac) = toFixedPoint b (compress b x)+       yFrac = expSmall b (-1,xFrac)+       {-+       (xFrac0,xFrac1) = splitAt 2 xFrac+       yFrac = mul b+                 -- slow convergence but simple argument+                 (expSmall b (-1, xFrac0))+                 -- fast convergence but big argument+                 (expSmall b (-3, xFrac1))+       -}+   in  intPower b xInt yFrac (recipEConst b) (eConst b)++intPower :: Basis -> Integer -> T -> T -> T -> T+intPower b expon neutral recipX x =+   if expon >= 0+     then cardPower b   expon  neutral x+     else cardPower b (-expon) neutral recipX++cardPower :: Basis -> Integer -> T -> T -> T+cardPower b expon neutral x =+   if expon >= 0+     then reduceRepeated (mul b) neutral x expon+     else error "negative exponent - use intPower"+++{- |+Residue estimates will only hold for exponents+with absolute value below one.++The computation is based on 'Int',+thus the denominator should not be too big.+(Say, at most 1000 for 1000000 digits.)++It is not optimal to split the power into pure root and pure power+(that means, with integer exponents).+The root series can nicely handle all exponents,+but for exponents above 1 the series summands rises at the beginning+and thus make the residue estimate complicated.+For powers with integer exponents the root series turns+into the binomial formula,+which is just a complicated way to compute a power+which can also be determined by simple multiplication.+-}+powerSeries :: Basis -> Rational -> T -> Series+powerSeries b expon xOrig =+   let scaleRat ni yi =+          divInt b (fromInteger (denominator yi) * ni) .+          scaleSimple (fromInteger (numerator yi))+       x   = negativeExp b (sub b xOrig one)+       xps = scanl (\p fac -> uncurry scaleRat fac (mul b x p))+                   one (zip [1..] (iterate (subtract 1) expon))+   in  map (\xp -> (fst xp, xp)) xps++powerSmall :: Basis -> Rational -> T -> T+powerSmall b y x = series b (powerSeries b y x)++power :: Basis -> Rational -> T -> T+power b expon x =+   let num   = numerator   expon+       den   = denominator expon+       rootX = root b den x+   in  intPower b num one (reciprocal b rootX) rootX++root :: Basis -> Integer -> T -> T+root b expon x =+   let estimate = liftDoubleApprox b (** (1 / fromInteger expon)) x+       estPower = cardPower b expon one estimate+       residue  = divide b x estPower+   in  mul b estimate (powerSmall b (1 % fromIntegral expon) residue)++++{- |+Absolute value of argument should be below 1.+-}+cosSinhSmall :: Basis -> T -> (T, T)+cosSinhSmall b x =+   let (coshXps, sinhXps) = unzip (sliceVertPair (expSeries b x))+   in  (series b coshXps,+        series b sinhXps)++{- |+Absolute value of argument should be below 1.+-}+cosSinSmall :: Basis -> T -> (T, T)+cosSinSmall b x =+   let (coshXps, sinhXps) = unzip (sliceVertPair (expSeries b x))+       alternate s =+          zipWith3 if' (cycle [True,False])+             s (map (\(e,y) -> (e, neg b y)) s)+   in  (series b (alternate coshXps),+        series b (alternate sinhXps))+++{- |+Like 'cosSinSmall' but converges faster.+It calls @cosSinSmall@ with reduced arguments+using the trigonometric identities+@+cos (4*x) = 8 * cos x ^ 2 * (cos x ^ 2 - 1) + 1+sin (4*x) = 4 * sin x * cos x * (1 - 2 * sin x ^ 2)+@++Note that the faster convergence is hidden by the overhead.++The same could be achieved with a fourth power of a complex number.+-}+cosSinFourth :: Basis -> T -> (T, T)+cosSinFourth b x =+   let (cosx, sinx) = cosSinSmall b (divInt b 4 x)+       sinx2   = mul b sinx sinx+       cosx2   = mul b cosx cosx+       sincosx = mul b sinx cosx+   in  (add b one (scale b 8 (mul b cosx2 (sub b cosx2 one))),+        scale b 4 (mul b sincosx (sub b one (scale b 2 sinx2))))+++cosSin :: Basis -> T -> (T, T)+cosSin b x =+   let pi2 = divInt b 2 (piConst b)+       {- @compress@ ensures that the leading digit of the fractional part+          is close to zero -}+       (quadrant, frac) = toFixedPoint b (compress b (divide b x pi2))+       -- it's possibly faster if we subtract quadrant*pi/4+       wrapped = if quadrant==0 then x else mul b pi2 (-1, frac)+       (cosW,sinW) = cosSinSmall b wrapped+   in  case mod quadrant 4 of+          0 -> (      cosW,       sinW)+          1 -> (neg b sinW,       cosW)+          2 -> (neg b cosW, neg b sinW)+          3 -> (      sinW, neg b cosW)+          _ -> error "error in implementation of 'mod'"++tan :: Basis -> T -> T+tan b x = uncurry (flip (divide b)) (cosSin b x)++cot :: Basis -> T -> T+cot b x = uncurry (divide b) (cosSin b x)+++{- ** logarithmic functions -}++lnSeries :: Basis -> T -> Series+lnSeries b xOrig =+   let x   = negativeExp b (sub b xOrig one)+       mx  = neg b x+       xps = zipWith (divInt b) [1..] (iterate (mul b mx) x)+   in  map (\xp -> (fst xp, xp)) xps++lnSmall :: Basis -> T -> T+lnSmall b x = series b (lnSeries b x)++{- |+@+x' = x - (exp x - y) \/ exp x+   = x + (y * exp (-x) - 1)+@++First, the dependencies on low-significant places are currently+much more than mathematically necessary.+Check+@+*Number.Positional> expSmall 1000 (-1,100 : replicate 16 0 ++ [undefined])+(0,[1,105,171,-82,76*** Exception: Prelude.undefined+@+Every multiplication cut off two trailing digits.+@+*Number.Positional> nest 8 (mul 1000 (-1,repeat 1)) (-1,100 : replicate 16 0 ++ [undefined])+(-9,[101,*** Exception: Prelude.undefined+@++Possibly the dependencies of expSmall+could be resolved by not computing @mul@ immediately+but computing @mul@ series which are merged and subsequently added.+But this would lead to an explosion of series.++Second, even if the dependencies of all atomic operations+are reduced to a minimum,+the mathematical dependencies of the whole iteration function+are less than the sums of the parts.+Lets demonstrate this with the square root iteration.+It is+@+(1.4140 + 2/1.4140) / 2 == 1.414213578500707+(1.4149 + 2/1.4149) / 2 == 1.4142137288854335+@+That is, the digits @213@ do not depend mathematically on @x@ of @1.414x@,+but their computation depends.+Maybe there is a glorious trick to reduce the computational dependencies+to the mathematical ones.+-}+lnNewton :: Basis -> T -> T+lnNewton b y =+   let estimate = liftDoubleApprox b log y+       expRes   = mul b y (expSmall b (neg b estimate))+       -- try to reduce dependencies by feeding expSmall with a small argument+       residue =+          sub b (mul b expRes (expSmallLazy b (neg b resTrim))) one+       resTrim =+          -- (-3, replicate 4 0 ++ alignMant b (-7) residue)+          align b (- mantLengthDouble b) residue+       lazyAdd (xe,xm) (ye,ym) =+          (xe, LPoly.addShifted (xe-ye) xm ym)+       x = lazyAdd estimate resTrim+   in  x++lnNewton' :: Basis -> T -> T+lnNewton' b y =+   let estimate = liftDoubleApprox b log y+       residue  =+          sub b (mul b y (expSmall b (neg b x))) one+          -- sub b (mul b y (expSmall b (neg b estimate))) one+          -- sub b (mul b y (expSmall b (neg b+          --     (fst estimate, snd estimate ++ [undefined])))) one+       resTrim =+          -- align b (-6) residue+          align b (- mantLengthDouble b) residue+             -- align returns the new exponent immediately+          -- nest (mantLengthDouble b) trimOnce residue+          -- negativeExp b residue+       lazyAdd (xe,xm) (ye,ym) =+          (xe, LPoly.addShifted (xe-ye) xm ym)+       x = lazyAdd estimate resTrim+          -- add b estimate resTrim+                -- LPoly.add checks for empty lists and is thus too strict+   in  x+++ln :: Basis -> T -> T+ln b x@(xe,_) =+   let e  = round (log (fromIntegral b) * fromIntegral xe :: Double)+       ei = fromIntegral e+       y  = trim $+          if e<0+            then reduceRepeated (mul b) x (eConst b)    (-ei)+            else reduceRepeated (mul b) x (recipEConst b) ei+       estimate = liftDoubleApprox b log y+       residue  = mul b (expSmall b (neg b estimate)) y+   in  addSome b [(0,[e]), estimate, lnSmall b residue]+++{- |+This is an inverse of 'cosSin',+also known as @atan2@ with flipped arguments.+It's very slow because of the computation of sinus and cosinus.+However, because it uses the 'atan2' implementation as estimator,+the final application of arctan series should converge rapidly.++It could be certainly accelerated by not using cosSin+and its fiddling with pi.+Instead we could analyse quadrants before calling atan2,+then calling cosSinSmall immediately.+-}+angle :: Basis -> (T,T) -> T+angle b (cosx, sinx) =+   let wd      = atan2 (toDouble b sinx) (toDouble b cosx)+       wApprox = fromDoubleApprox b wd+       (cosApprox, sinApprox) = cosSin b wApprox+       (cosD,sinD) =+          (add b (mul b cosx cosApprox)+                 (mul b sinx sinApprox),+           sub b (mul b sinx cosApprox)+                 (mul b cosx sinApprox))+       sinDSmall = negativeExp b sinD+   in  add b wApprox (arctanSmall b (divide b sinDSmall cosD))+++{- |+Arcus tangens of arguments with absolute value less than @1 \/ sqrt 3@.+-}+arctanSeries :: Basis -> T -> Series+arctanSeries b xOrig =+   let x   = negativeExp b xOrig+       mx2 = neg b (mul b x x)+       xps = zipWith (divInt b) [1,3..] (iterate (mul b mx2) x)+   in  map (\xp -> (fst xp, xp)) xps++arctanSmall :: Basis -> T -> T+arctanSmall b x = series b (arctanSeries b x)++{- |+Efficient computation of Arcus tangens of an argument of the form @1\/n@.+-}+arctanStem :: Basis -> Int -> T+arctanStem b n =+   let x = (0, divIntMant b n [1])+       divN2 = divInt b n . divInt b (-n)+       {- this one can cause overflows in piConst too easily+       mn2 = - n*n+       divN2 = divInt b mn2+       -}+       xps = zipWith (divInt b) [1,3..] (iterate (trim . divN2) x)+   in  series b (map (\xp -> (fst xp, xp)) xps)+++{- |+This implementation gets the first decimal place for free+by calling the arcus tangens implementation for 'Double's.+-}+arctan :: Basis -> T -> T+arctan b x =+   let estimate = liftDoubleRough b atan x+       tanEst   = tan b estimate+       residue  = divide b (sub b x tanEst) (add b one (mul b x tanEst))+   in  addSome b [estimate, arctanSmall b residue]++{- |+A classic implementation without ''cheating''+with floating point implementations.++For @x < 1 \/ sqrt 3@+(@1 \/ sqrt 3 == tan (pi\/6)@)+use @arctan@ power series.+(@sqrt 3@ is approximately @19\/11@.)++For @x > sqrt 3@+use+@arctan x = pi\/2 - arctan (1\/x)@++For other @x@ use++@arctan x = pi\/4 - 0.5*arctan ((1-x^2)\/2*x)@+(which follows from+@arctan x + arctan y == arctan ((x+y) \/ (1-x*y))@+which in turn follows from complex multiplication+@(1:+x)*(1:+y) == ((1-x*y):+(x+y))@++If @x@ is close to @sqrt 3@ or @1 \/ sqrt 3@ the computation is quite inefficient.+-}+arctanClassic :: Basis -> T -> T+arctanClassic b x =+   let absX = absolute x+       pi2  = divInt b 2 (piConst b)+   in  select+          (divInt b 2 (sub b pi2+              (arctanSmall b+                  (divInt b 2 (sub b (reciprocal b x) x)))))+          [(lessApprox b (-5) absX (fromBaseRational b (11%19)),+               arctanSmall b x),+           (lessApprox b (-5) (fromBaseRational b (19%11)) absX,+               sub b pi2 (arctanSmall b (reciprocal b x)))]++++{- * constants -}++{- ** elementary -}++zero :: T+zero = (0,[])++one :: T+one = (0,[1])++minusOne :: T+minusOne = (0,[-1])+++{- ** transcendental -}++eConst :: Basis -> T+eConst b = expSmall b one++recipEConst :: Basis -> T+recipEConst b = expSmall b minusOne++piConst :: Basis -> T+piConst b =+   let numCompress = takeWhile (0/=)+          (iterate (flip div b) (4*(44+7+12+24)))+       stArcTan k den = scaleSimple k (arctanStem b den)+       sum' = addSome b+                 [stArcTan   44     57,+                  stArcTan    7    239,+                  stArcTan (-12)   682,+                  stArcTan   24  12943]+   in  foldl (const . compress b)+             (scaleSimple 4 sum') numCompress++++{- * auxilary functions -}++{- |+Candidate for a Utility module.+-}+nest :: Int -> (a -> a) -> a -> a+nest 0 _ x = x+nest n f x = f (nest (n-1) f x)+++flipPair :: (a,b) -> (b,a)+flipPair ~(x,y) = (y,x)+++sliceVertPair :: [a] -> [(a,a)]+sliceVertPair (x0:x1:xs) = (x0,x1) : sliceVertPair xs+sliceVertPair [] = []+sliceVertPair _ = error "odd number of elements"++++{-+Pi as a zero of trigonometric functions. -+  Is a corresponding computation that bad?+Newton converges quadratically,+  but the involved trigonometric series converge only slightly more than linearly.++-- lift cos to higher frequencies, in order to shift the zero to smaller values, which let trigonometric series converge faster++take 10 $ Numerics.Newton.zero 0.7 (\x -> (cos (2*x), -2 * sin (2*x)))++(\x -> (2 * cos x ^ 2 - 1, -4 * cos x * sin x))+(\x -> (cos x ^ 2 - sin x ^ 2, -4 * cos x * sin x))+(\x -> (tan x ^ 2 - 1, 4 * tan x))+++-- compute arctan as inverse of tan by Newton++zero 0.7 (\x -> (tan x - 1, 1 + tan x ^ 2))+zero 0.7 (\x -> (tan x - 1, 1 / cos x ^ 2))+iterate (\x -> x + (cos x - sin x) * cos x) 0.7+iterate (\x -> x + (cos x - sin x) * sqrt 0.5) 0.7+iterate (\x -> x + cos x ^ 2 - sin x * cos x) 0.7+iterate (\x -> x + 0.5 - sin x * cos x) 0.7+iterate (\x -> x + cos x ^ 2 - 0.5) 0.7+++-- compute section of tan and cot++zero 0.7 (\x -> (tan x - 1 / tan x, (1 + tan x ^ 2) * (1 + 1 / tan x ^ 2))+zero 0.7 (\x -> ((tan x ^ 2 - 1) * tan x, (1 + tan x ^ 2) ^ 2)+iterate (\x -> x - (sin x ^ 2 - cos x ^ 2) * sin x * cos x) 0.7+iterate (\x -> x - (sin x ^ 2 - cos x ^ 2) * 0.5) 0.7+iterate (\x -> x + 1/2 - sin x ^ 2) 0.7++For using the last formula,+the n-th digit of (sin x) must depend only on the n-th digit of x.+The same holds for (^2).+This means that no interim carry compensation is possible.+This will certainly force usage of Integer for digits,+otherwise the multiplication will overflow sooner or later.+-}
+ src/Number/Positional/Check.hs view
@@ -0,0 +1,241 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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++import qualified Number.Positional as Pos++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.Ring               as Ring+import qualified Algebra.Additive           as Additive+import qualified Algebra.ZeroTestable       as ZeroTestable++import qualified PreludeBase as P+import qualified Prelude     as P98++import PreludeBase as P+import NumericPrelude as NP+++{- |+The value @Cons b e m@+represents the number @b^e * (m!!0 \/ 1 + m!!1 \/ b + m!!2 \/ b^2 + ...)@.+The interpretation of exponent is chosen such that+@floor (logBase b (Cons b e m)) == e@.+That is, it is good for multiplication and logarithms.+(Because of the necessity to normalize the multiplication result,+the alternative interpretation wouldn't be more complicated.)+However for base conversions, roots, conversion to fixed point and+working with the fractional part+the interpretation+@b^e * (m!!0 \/ b + m!!1 \/ b^2 + m!!2 \/ b^3 + ...)@+would fit better.+The digits in the mantissa range from @1-base@ to @base-1@.+The representation is not unique+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}+   deriving (Show)+++{- * basic helpers -}++{- |+Shift digits towards zero by partial application of carries.+E.g. 1.8 is converted to 2.(-2)+If the digits are in the range @(1-base, base-1)@+the resulting digits are in the range @((1-base)/2-2, (base-1)/2+2)@.+The result is still not unique,+but may be useful for further processing.+-}+compress :: T -> T+compress = lift1 Pos.compress+++{- | perfect carry resolution, works only on finite numbers -}+carry :: T -> T+carry (Cons b ex xs) =+   let ys = scanr (\x (c,_) -> divMod (x+c) b) (0,undefined) xs+       digits = map snd (init ys)+   in  prependDigit (fst (head ys)) (Cons b ex digits)+++prependDigit :: Int -> T -> T+prependDigit 0 x = x+prependDigit x (Cons b ex xs) =+   Cons b (ex+1) (x:xs)++++{- * conversions -}++lift0 :: (Int -> Pos.T) -> T+lift0 op =+   uncurry (Cons defltBase) (op defltBase)++lift1 :: (Int -> 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 op (Cons xb xe xm) (Cons yb ye ym) =+   let zb = commonBasis xb yb+   in  uncurry (Cons zb) (op xb (xe, xm) (ye, ym))++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 b n =+   uncurry (Cons b) (Pos.fromBaseInteger b n)++fromBaseRational :: Int -> Rational -> T+fromBaseRational b r =+   uncurry (Cons b) (Pos.fromBaseRational b r)++++++defltBaseRoot :: Pos.Basis+defltBaseRoot = 10++defltBaseExp :: Pos.Exponent+defltBaseExp = 3+-- exp 4   let  (sqrt 0.5) fail++defltBase :: Pos.Basis+defltBase = ringPower defltBaseExp defltBaseRoot++++defltShow :: T -> String+defltShow (Cons xb xe xm) =+   if xb == defltBase+     then Pos.showBasis defltBaseRoot defltBaseExp (xe,xm)+     else error "defltShow: wrong base"+++instance Additive.C T where+   zero   = fromBaseInteger defltBase 0+   (+)    = lift2 Pos.add+   (-)    = lift2 Pos.sub+   negate = lift1 Pos.neg++instance Ring.C T where+   one           = fromBaseInteger defltBase 1+   fromInteger n = fromBaseInteger defltBase n+   (*)           = lift2 Pos.mul++{-+instance Module.C T T where+   (*>) = (*)+-}++instance Field.C T where+   (/)   = lift2 Pos.divide+   recip = lift1 Pos.reciprocal++instance Algebraic.C T where+   sqrt   = lift1 Pos.sqrtNewton+   root n = lift1 (flip Pos.root n)+   x ^/ y = lift1 (flip Pos.power y) x++instance Trans.C T where+   pi     = lift0 Pos.piConst++   exp    = lift1 Pos.exp+   log    = lift1 Pos.ln++   sin    = lift1 (\b -> snd . Pos.cosSin b)+   cos    = lift1 (\b -> fst . Pos.cosSin b)+   tan    = lift1 Pos.tan++   atan   = lift1 Pos.arctan++   {-+   sinh   = lift1 (\b -> snd . Pos.cosSinh b)+   cosh   = lift1 (\b -> snd . Pos.cosSinh b)+   -}++instance ZeroTestable.C T where+   isZero (Cons xb xe xm) =+      Pos.cmp xb (xe,xm) Pos.zero == EQ++instance Eq T where+   (Cons xb xe xm) == (Cons yb ye ym) =+      Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym) == EQ++instance Ord T where+   compare (Cons xb xe xm) (Cons yb ye ym) =+      Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym)++instance Real.C T where+   abs = lift1 (const Pos.absolute)+   -- use default implementation for signum++instance RealField.C T where+   splitFraction (Cons xb xe xm) =+      let (int, frac) = Pos.toFixedPoint xb (xe,xm)+      in  (fromInteger int, Cons xb (-1) frac)++instance RealTrans.C T where+   atan2  = lift2 (curry . Pos.angle)+++-- for complex numbers++instance Complex.Polar T where+   magnitude = Complex.defltMagnitude+   phase     = Complex.defltPhase++instance Complex.Power T where+   power     = Complex.defltPow++instance Complex.Divisible T  where+   divide    = Complex.defltDiv+++++-- legacy instances for work with GHCi+legacyInstance :: a+legacyInstance =+   error "legacy Ring.C instance for simple input of numeric literals"++instance P98.Num T where+   fromInteger = fromBaseInteger defltBase+   negate = negate --for unary minus+   (+)    = legacyInstance+   (*)    = legacyInstance+   abs    = legacyInstance+   signum = legacyInstance++instance P98.Fractional T where+   fromRational = fromBaseRational defltBase . fromRational+   (/) = legacyInstance+++{-+MathObj.PowerSeries.approx MathObj.PowerSeries.Example.exp (Number.Positional.fromBaseInteger 10 1) List.!! 30 :: Number.Positional.Check.T+-}
+ src/Number/Quaternion.hs view
@@ -0,0 +1,291 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable (?)++Quaternions+-}++module Number.Quaternion+        (+        -- * Cartesian form+        T(real,imag),+        fromReal,+        (+::),++        -- * Conversions+        toRotationMatrix,+        fromRotationMatrix,+        fromRotationMatrixDenorm,+        toComplexMatrix,+        fromComplexMatrix,++        -- * Operations+        scalarProduct,+        crossProduct,+        conjugate,+        scale,+        norm,+        normSqr,+        normalize,+        similarity,+        slerp,+        )  where++import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.VectorSpace  as VectorSpace+import qualified Algebra.Module       as Module+import qualified Algebra.Vector       as Vector+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 Algebra.Additive     as Additive+import qualified Algebra.ZeroTestable as ZeroTestable++import Algebra.ZeroTestable(isZero)+import Algebra.Module((*>))+-- import Algebra.Algebraic((^/))++import qualified Number.Complex as Complex++import Number.Complex ((+:))++-- 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.Text (showsInfixPrec, readsInfixPrec)+++{- TODO:+conversion to and from complex matrix+-}+++infix  6  +::, `Cons`++{- |+Quaternions could be defined based on Complex numbers.+However quaternions are often considered as real part and three imaginary parts.+-}+data T a+  = Cons {real :: !a           -- ^ real part+         ,imag :: !(a, a, a)   -- ^ imaginary parts+         }+  deriving (Eq)++fromReal :: Additive.C a => a -> T a+fromReal x = Cons x zero+++plusPrec :: Int+plusPrec = 6++instance (Show a) => Show (T a) where+   showsPrec prec (x `Cons` y) = showsInfixPrec "+::" plusPrec prec x y++instance (Read a) => Read (T a) where+   readsPrec prec = readsInfixPrec "+::" plusPrec prec (+::)+++-- | Construct a quaternion from real and imaginary part.+(+::) :: a -> (a,a,a) -> T a+(+::) = Cons++-- | The conjugate of a quaternion.+{-# SPECIALISE conjugate :: T Double -> T Double #-}+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 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 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 (Cons xr xi) = xr*xr + scalarProduct xi xi++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 x = scale (recip (norm x)) x++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 (xi,xj,xk) (yi,yj,yk) =+   (xj*yk - xk*yj, xk*yi - xi*yk, xi*yj - xj*yi)++{- | similarity mapping as needed for rotating 3D vectors++It holds+@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 c x = c*x/c++{-+rotate	 :: (Field.C a) =>+      (a,a,a)  {- ^ rotation axis, must be normalized -}+   -> T a+   -> T a+rotate c x = c*x/c+-}++{- |+Let @c@ be a unit quaternion, then it holds+@similarity c (0+::x) == toRotationMatrix c * x@+-}+toRotationMatrix :: (Ring.C a) => T a -> Array (Int,Int) a+toRotationMatrix (Cons r (i,j,k)) =+   let r2 = r^2+       i2 = i^2;   j2 = j^2;   k2 = k^2+       ri = 2*r*i; rj = 2*r*j; rk = 2*r*k+       jk = 2*j*k; ki = 2*k*i; ij = 2*i*j+   in  Array.listArray ((0,0),(2,2)) $ concat $+          [r2+i2-j2-k2, ij-rk,       ki+rj      ] :+          [ij+rk,       r2-i2+j2-k2, jk-ri      ] :+          [ki-rj,       jk+ri,       r2-i2-j2+k2] :+          []++fromRotationMatrix :: (Algebraic.C a) => Array (Int,Int) a -> T a+fromRotationMatrix =+   normalize . fromRotationMatrixDenorm+++checkBounds :: (Int,Int) -> Array (Int,Int) a -> Array (Int,Int) a+checkBounds (c,r) arr =+   let bnds@((c0,r0), (c1,r1)) = Array.bounds arr+   in  if c1-c0==c && r1-r0==r+         then Array.listArray ((0,0), (c1-c0, r1-r0))+                              (Array.elems arr)+         else error ("Quaternion.checkBounds: invalid matrix size "+                         ++ show bnds)+++{- |+The rotation matrix must be normalized.+(I.e. no rotation with scaling)+The computed quaternion is not normalized.+-}+fromRotationMatrixDenorm :: (Ring.C a) => Array (Int,Int) a -> T a+fromRotationMatrixDenorm mat' =+   let mat = checkBounds (2,2) mat'+       trace = sum (map (\i -> mat ! (i,i)) [0..2])+       dif (i,j) = mat!(i,j) - mat!(j,i)+   in  Cons (trace+1) (dif (2,1), dif (0,2), dif (1,0))++{- |+Map a quaternion to complex valued 2x2 matrix,+such that quaternion addition and multiplication+is mapped to matrix addition and multiplication.+The determinant of the matrix equals the squared quaternion norm ('normSqr').+Since complex numbers can be turned into real (orthogonal) matrices,+a quaternion could also be converted into a real matrix.+-}+toComplexMatrix :: (Additive.C a) =>+   T a -> Array (Int,Int) (Complex.T a)+toComplexMatrix (Cons r (i,j,k)) =+   Array.listArray ((0,0), (1,1))+      [r+:i, (-j)+:(-k), j+:(-k), r+:(-i)]+++{- |+Revert 'toComplexMatrix'.+-}+fromComplexMatrix :: (Field.C a) =>+   Array (Int,Int) (Complex.T a) -> T a+fromComplexMatrix mat =+   let xs = Array.elems (checkBounds (1,1) mat)+       [ar,br,cr,dr] = map Complex.real xs+       [ai,bi,ci,di] = map Complex.imag xs+   in  scale (1/2) (Cons (ar+dr) (ai-di, cr-br, -ci-bi))+++{- |+Spherical Linear Interpolation++Can be generalized to any transcendent Hilbert space.+In fact, we should also include the real part in the interpolation.+-}+slerp :: (Trans.C a) =>+      a   {- ^ For @0@ return vector @v@,+               for @1@ return vector @w@ -}+   -> (a,a,a)  {- ^ vector @v@, must be normalized -}+   -> (a,a,a)  {- ^ vector @w@, must be normalized -}+   -> (a,a,a)+slerp c v w =+   let scal  = scalarProduct v w /+                  sqrt (scalarProduct v v * scalarProduct w w)+       angle = Trans.acos scal+   in  scaleImag (recip (Algebraic.sqrt (1-scal^2)))+         (scaleImag (Trans.sin ((1-c)*angle)) v ++          scaleImag (Trans.sin (   c *angle)) w)++++instance (NormedEuc.Sqr a b) => NormedEuc.Sqr a (T b) where+   normSqr (Cons r i) = NormedEuc.normSqr r + NormedEuc.normSqr i++instance (Algebraic.C a, NormedEuc.Sqr a b) => NormedEuc.C a (T b) where+   norm = NormedEuc.defltNorm++++instance (ZeroTestable.C a) => ZeroTestable.C (T a)  where+   isZero (Cons r i)  = isZero r && isZero i++instance (Additive.C a) => Additive.C (T a)  where+   {-# SPECIALISE instance Additive.C (T Float) #-}+   {-# SPECIALISE instance Additive.C (T Double) #-}+   zero			=  Cons zero zero+   (Cons xr xi) + (Cons yr yi)	=  Cons (xr+yr) (xi+yi)+   (Cons xr xi) - (Cons yr yi)	=  Cons (xr-yr) (xi-yi)+   negate (Cons x y)		=  Cons (negate x) (negate y)++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)	=+       Cons (xr*yr - scalarProduct xi yi)+            (scaleImag xr yi + scaleImag yr xi ++             crossProduct xi yi)++instance (Field.C a) => Field.C (T a)  where+   {-# SPECIALISE instance Field.C (T Float) #-}+   {-# SPECIALISE instance Field.C (T Double) #-}+   recip x = scale (recip (normSqr x)) (conjugate x)+   (Cons xr xi) / y@(Cons yr yi) =+       scale (recip (normSqr y))+          (Cons (xr*yr + scalarProduct xi yi)+                (scaleImag yr xi - scaleImag xr yi - crossProduct xi yi))++instance Vector.C T where+   zero  = zero+   (<+>) = (+)+   (*>)  = scale++-- | The '(*>)' method can't replace 'scale'+--   because it requires the Algebra.Module constraint+instance (Module.C a b) => Module.C a (T b) where+   s *> (Cons r i)  = Cons (s *> r) (s *> i)++instance (VectorSpace.C a b) => VectorSpace.C a (T b)+
+ src/Number/Ratio.hs view
@@ -0,0 +1,189 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Module      :  Number.Ratio+Copyright   :  (c) Henning Thielemann, Dylan Thurston 2006++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable (?)++Ratios of mathematical objects.+-}++module Number.Ratio+	(+	  T((:%), numerator, denominator), (%),+          Rational,+          fromValue,++          scale,+          split,+          showsPrecAuto,++          toRational98,+        )  where++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Units                as Units+import qualified Algebra.Real                 as Real+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 NumericPrelude.Monad(untilM)+import Control.Monad(liftM, liftM2)++import Test.QuickCheck (Arbitrary(arbitrary,coarbitrary))++import qualified Data.Ratio as Ratio98++import qualified Prelude as P+import PreludeBase+++infixl 7 %++data  {- (PID.C a)  => -} T a = (:%) {+        numerator   :: !a,+        denominator :: !a+     } deriving (Eq)+type  Rational = T P.Integer+++fromValue :: Ring.C a => a -> T a+fromValue x = x :% one++scale :: (PID.C a) => a -> T a -> T a+scale s (x:%y) =+   let {- x and y are cancelled,+          thus we can only have common divisors in s and y -}+       (n:%d) = s%y+   in  ((n*x):%d)++{- | similar to 'Algebra.RealField.splitFraction' -}+split :: (PID.C a) => T a -> (a, T a)+split (x:%y) =+   let (q,r) = divMod x y+   in  (q, r:%y)++ratioPrec :: P.Int+ratioPrec = 7++(%) :: (PID.C a) => a -> a -> T a+x % y =+  if isZero y+    then error "NumericPrelude.% : zero denominator"+    else+      let d  = gcd x y+          y0 = div y d+          x0 = div x d+      in  (stdUnitInv y0 * x0) :% stdAssociate y0++instance (PID.C a) => Additive.C (T a) where+    zero                =  fromValue zero+    (x:%y) + (x':%y')   =  (x*y' + x'*y) % (y*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')++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+++liftOrd :: Ring.C a => (a -> a -> b) -> (T a -> T a -> b)+liftOrd f (x:%y) (x':%y') = f (x * y') (x' * y)++instance (Ord a, PID.C a) => Ord (T a) where+    (<=)     =  liftOrd (<=)+    (<)      =  liftOrd (<)+    (>=)     =  liftOrd (>=)+    (>)      =  liftOrd (>)+    compare  =  liftOrd compare++instance (Ord a, PID.C a) => Indexable.C (T a) where+    compare  =  compare++instance (ZeroTestable.C a, PID.C a) => ZeroTestable.C (T a) where+    isZero  =  isZero . numerator++instance  (Read a, PID.C a)  => Read (T a)  where+    readsPrec p  =+       readParen (p >= ratioPrec)+                 (\r -> [(x%y,u) | (x,s)   <- readsPrec ratioPrec r,+                                   ("%",t) <- lex s,+                                   (y,u)   <- readsPrec ratioPrec t ])++instance  (Show a, PID.C a)  => Show (T a)  where+    showsPrec p (x:%y)  =  showParen (p >= ratioPrec)+                               (shows x . showString " % " . shows y)++{- |+This is an alternative show method+that is more user-friendly but also potentially more ambigious.+-}++showsPrecAuto :: (Eq a, PID.C a, Show a) =>+   P.Int -> T a -> String -> String+showsPrecAuto p (x:%y) =+   if y == 1+     then showsPrec p x+     else showParen (p > ratioPrec)+             (showsPrec (ratioPrec+1) x . showString "/" .+              showsPrec (ratioPrec+1) y)+++instance (Arbitrary a, PID.C a, ZeroTestable.C a) => Arbitrary (T a) where+{-+   arbitrary = liftM2 (%) arbitrary (untilM (not . isZero) arbitrary)++This implementation leads to blocking:++*Main> Test.QuickCheck.test (\x -> x==(x::Rational))+Interrupted.+-}+   arbitrary =+      liftM2 (%) arbitrary+         (liftM (\x -> if isZero x then one else x) arbitrary)+   coarbitrary = undefined++++-- * Legacy Instances+++-- | Necessary when mixing NumericPrelude Rationals with Prelude98 Rationals++toRational98 :: (P.Integral a, PID.C a) => T a -> Ratio98.Ratio a+toRational98 x = numerator x Ratio98.% denominator x+++legacyInstance :: a+legacyInstance = error "legacy Ring instance for simple input of numeric literals"+++instance (P.Num a, PID.C a) => P.Num (T a) where+   fromInteger n = P.fromInteger n % 1+   negate = negate -- for unary minus+   (+)    = legacyInstance+   (*)    = legacyInstance+   abs    = legacyInstance+   signum = legacyInstance++instance (P.Num a, PID.C a) => P.Fractional (T a) where+--   fromRational = Field.fromRational+   fromRational x =+      fromInteger (Ratio98.numerator x) :%+      fromInteger (Ratio98.denominator x)+   (/) = legacyInstance
+ src/Number/ResidueClass.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS -fno-implicit-prelude #-}+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.Condition (toMaybe)+import Data.Maybe (fromMaybe)+++add, sub :: (Integral.C a) => a -> a -> a -> a+add m x y = mod (x+y) m+sub m x y = mod (x-y) m++neg :: (Integral.C a) => a -> a -> a+neg m x = mod (-x) m++mul :: (Integral.C a) => a -> a -> a -> a+mul m x y = mod (x*y) m+++{- |+The division may be ambiguous.+In this case an arbitrary quotient is returned.++@+0/:4 * 2/:4 == 0/:4+2/:4 * 2/:4 == 0/:4+@+-}+divideMaybe :: (PID.C a) => a -> a -> a -> Maybe a+divideMaybe m x y =+   let (d,(_,z)) = extendedGCD m y+       (q,r)     = divMod x d+   in  toMaybe (isZero r) (mod (q*z) m)++divide :: (PID.C a) => a -> a -> a -> a+divide m x y =+   fromMaybe (error "ResidueClass.divide: indivisible")+             (divideMaybe m x y)++recip :: (PID.C a) => a -> a -> a+recip m = divide m one
+ src/Number/ResidueClass/Check.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Number.ResidueClass.Check 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.ZeroTestable   as ZeroTestable++import Algebra.ZeroTestable(isZero)++import PreludeBase+import NumericPrelude (Int, Integer, mod, )+import qualified NumericPrelude+import NumericPrelude.Condition (toMaybe)+import NumericPrelude.Text (showsInfixPrec, readsInfixPrec)++infix 7 /:, `Cons`++{- |+The best solution seems to let 'modulus' be part of the type.+This could happen with a phantom type for modulus+and a @run@ function like 'Control.Monad.ST.runST'.+Then operations with non-matching moduli could be detected at compile time+and 'zero' and 'one' could be generated with the correct modulus.+An alternative trial can be found in module ResidueClassMaybe.+-}+data T a+  = Cons {modulus        :: !a+         ,representative :: !a+         }++factorPrec :: Int+factorPrec = read "7"++instance (Show a) => Show (T a) where+   showsPrec prec (Cons m r) = showsInfixPrec "/:" factorPrec prec r m++instance (Read a, Integral.C a) => Read (T a) where+   readsPrec prec = readsInfixPrec "/:" factorPrec prec (/:)+++-- | @r \/: m@ is the residue class containing @r@ with respect to the modulus @m@+(/:) :: (Integral.C a) => a -> a -> T a+(/:) r m = Cons m (mod r m)++-- | Check if two residue classes share the same modulus+isCompatible :: (Eq a) => T a -> T a -> Bool+isCompatible x y  =  modulus x == modulus y++maybeCompatible :: (Eq a) => T a -> T a -> Maybe a+maybeCompatible x y =+   let mx = modulus x+       my = modulus y+   in  toMaybe (mx==my) mx+++fromRepresentative :: (Integral.C a) => a -> a -> T a+fromRepresentative m x = Cons m (mod x m)++lift1 :: (Eq a) => (a -> a -> a) -> T a -> T a+lift1 f x =+   let m = modulus x+   in  Cons m (f m (representative x))++lift2 :: (Eq a) => (a -> a -> a -> a) -> T a -> T a -> T a+lift2 f x y =+   maybe+      (errIncompat)+      (\m -> Cons m (f (modulus x) (representative x) (representative y)))+      (maybeCompatible x y)++errIncompat :: a+errIncompat = error "Residue class: Incompatible operands"+++zero :: (Additive.C a) => a -> T a+zero m = Cons m Additive.zero++one :: (Ring.C a) => a -> T a+one  m = Cons m NumericPrelude.one++fromInteger :: (Integral.C a) => a -> Integer -> T a+fromInteger m x = fromRepresentative m (NumericPrelude.fromInteger x)++++instance  (Eq a) => Eq (T a)  where+    (==) x y  =+        maybe errIncompat+           (const (representative x == representative y))+           (maybeCompatible x y)++instance  (ZeroTestable.C a) => ZeroTestable.C (T a)  where+    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++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"++instance  (Eq a, PID.C a) => Field.C (T a)  where+    (/)			=  lift2 Res.divide+    recip               =  lift1 (flip Res.divide NumericPrelude.one)+    fromRational'	=  error "no conversion from rational to residue class"
+ src/Number/ResidueClass/Func.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 PreludeBase+import NumericPrelude hiding (zero, one, )++import qualified Prelude        as P+import qualified NumericPrelude as NP++{- |+Here a residue class is a representative+and the modulus is an argument.+You cannot show a value of type 'T',+you can only show it with respect to a concrete modulus.+Values cannot be compared,+because the comparison result depends on the modulus.+-}+newtype T a = Cons (a -> a)++concrete :: a -> T a -> a+concrete m (Cons r) = r m++fromRepresentative :: (Integral.C a) => a -> T a+fromRepresentative = Cons . mod++lift0 :: (a -> a) -> T a+lift0 = Cons++lift1 :: (a -> a -> a) -> T a -> T a+lift1 f (Cons x) = Cons $ \m -> f m (x m)++lift2 :: (a -> a -> a -> a) -> T a -> T a -> T a+lift2 f (Cons x) (Cons y) = Cons $ \m -> f m (x m) (y m)+++zero :: (Additive.C a) => T a+zero = Cons $ const Additive.zero++one :: (Ring.C a) => T a+one  = Cons $ const NP.one++fromInteger :: (Integral.C a) => Integer -> T a+fromInteger = fromRepresentative . NP.fromInteger++equal :: Eq a => a -> T a -> T a -> Bool+equal m (Cons x) (Cons y)  =  x m == y m+++instance  (Integral.C a) => Additive.C (T a)  where+    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++instance  (PID.C a) => Field.C (T a)  where+    (/)			=  lift2 Res.divide+    recip               =  (NP.one /)+    fromRational'	=  error "no conversion from rational to residue class"+++{-+NumericPrelude.fromInteger seems to be not available at GHCi's prompt sometimes.+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"++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++instance Eq (T a) where+   (==) = error "ResidueClass.Func: (==) not implemented"++instance Show (T a) where+   show = error "ResidueClass.Func: 'show' not implemented"
+ src/Number/ResidueClass/Maybe.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Number.ResidueClass.Maybe where++import qualified Number.ResidueClass as Res++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 Algebra.ZeroTestable(isZero)++import PreludeBase+import NumericPrelude++infix 7 /:, `Cons`+++{- |+Here we try to provide implementations for 'zero' and 'one'+by making the modulus optional.+We have to provide non-modulus operations for the cases+where both operands have Nothing modulus.+This is problematic since operations like '(\/)'+depend essentially on the modulus.++A working version with disabled 'zero' and 'one' can be found ResidueClass.+-}+data T a+  = Cons {modulus        :: !(Maybe a)  -- ^ the modulus can be Nothing to denote a generic constant like 'zero' and 'one' which could not be bound to a specific modulus so far+         ,representative :: !a+         }+  deriving (Show, Read)+++-- | @r \/: m@ is the residue class containing @r@ with respect to the modulus @m@+(/:) :: (Integral.C a) => a -> a -> T a+(/:) r m = Cons (Just m) (mod r m)+++matchMaybe :: Maybe a -> Maybe a -> Maybe a+matchMaybe Nothing y = y+matchMaybe x       _ = x++isCompatibleMaybe :: (Eq a) => Maybe a -> Maybe a -> Bool+isCompatibleMaybe Nothing _ = True+isCompatibleMaybe _ Nothing = True+isCompatibleMaybe (Just x) (Just y) = x == y++-- | Check if two residue classes share the same modulus+isCompatible :: (Eq a) => T a -> T a -> Bool+isCompatible x y  =  isCompatibleMaybe (modulus x) (modulus y)+++lift2 :: (Eq a) => (a -> a -> a -> a) -> (a -> a -> a) -> (T a -> T a -> T a)+lift2 f g x y =+  if isCompatible x y+    then let m = matchMaybe (modulus x) (modulus y)+         in  Cons m+                  (maybe g f m (representative x) (representative y))+    else error "ResidueClass: Incompatible operands"+++instance  (Eq a, ZeroTestable.C a, Integral.C a) => Eq (T a)  where+    (==) x y =+      if isCompatible x y+        then maybe (==)+                   (\m x' y' -> isZero (mod (x'-y') m))+                   (matchMaybe (modulus x) (modulus y))+                   (representative x) (representative y)+        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)++instance  (Eq a, Integral.C a) => Ring.C (T a)  where+    one			=  Cons Nothing one+    (*)			=  lift2 Res.mul (*)+    fromInteger		=  Cons Nothing . fromInteger
+ src/Number/ResidueClass/Reader.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Number.ResidueClass.Reader where++import qualified Number.ResidueClass as Res++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import PreludeBase+import NumericPrelude++import Control.Monad (liftM2, liftM4)+-- import Control.Monad.Reader (MonadReader)++import qualified Prelude        as P+import qualified NumericPrelude as NP+++{- |+T is a Reader monad but does not need functional dependencies+like that from the Monad Template Library.+-}+newtype T a b = Cons {toFunc :: a -> b}++concrete :: a -> T a b -> b+concrete m (Cons r) = r m++fromRepresentative :: (Integral.C a) => a -> T a a+fromRepresentative = Cons . mod+++getZero :: (Additive.C a) => T a a+getZero = Cons $ const Additive.zero++getOne :: (Ring.C a) => T a a+getOne  = Cons $ const NP.one++fromInteger :: (Integral.C a) => Integer -> T a a+fromInteger = fromRepresentative . NP.fromInteger+++instance Monad (T a) where+   (Cons x) >>= y  =  Cons (\r -> toFunc (y (x r)) r)+   return = Cons . const++++getAdd :: Integral.C a => T a (a -> a -> a)+getAdd = Cons Res.add++getSub :: Integral.C a => T a (a -> a -> a)+getSub = Cons Res.sub++getNeg :: Integral.C a => T a (a -> a)+getNeg = Cons Res.neg++getAdditiveVars :: Integral.C a => T a (a, a -> a -> a, a -> a -> a, a -> a)+getAdditiveVars = liftM4 (,,,) getZero getAdd getSub getNeg++++getMul :: Integral.C a => T a (a -> a -> a)+getMul = Cons Res.mul++getRingVars :: Integral.C a => T a (a, a -> a -> a)+getRingVars = liftM2 (,) getOne getMul++++getDivide :: PID.C a => T a (a -> a -> a)+getDivide = Cons Res.divide++getRecip :: PID.C a => T a (a -> a)+getRecip = Cons Res.recip++getFieldVars :: PID.C a => T a (a -> a -> a, a -> a)+getFieldVars = liftM2 (,) getDivide getRecip++monadExample :: PID.C a => T a [a]+monadExample =+   do (zero',(+~),(-~),negate') <- getAdditiveVars+      (one',(*~)) <- getRingVars+      ((/~),recip') <- getFieldVars+      let three = one'+one'+one'  -- is easier if only NP.fromInteger is visible+      let seven = three+three+one'+      return [zero'*~three, one'/~three, recip' three,+              three *~ seven, one' +~ three +~ seven,+              zero' -~ three, negate' three +~ seven]++runExample :: [Integer]+runExample =+   let three = one+one+one+       eleven = three+three+three + one+one+   in  concrete eleven monadExample
+ src/Number/SI.hs view
@@ -0,0 +1,260 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+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.+-}++module Number.SI where++import qualified Number.SI.Unit       as SIUnit+import           Number.SI.Unit (Dimension, bytesize)++import qualified Number.Physical      as Value+import qualified Number.Physical.Unit as Unit+import qualified Number.Physical.Show as PVShow+import qualified Number.Physical.Read as PVRead+import qualified Number.Physical.UnitDatabase as UnitDatabase++import           Algebra.OccasionallyScalar  as OccScalar+import qualified Algebra.NormedSpace.Maximum as NormedMax++import qualified Algebra.VectorSpace         as VectorSpace+import qualified Algebra.Module              as Module+import qualified Algebra.Vector              as Vector+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 Algebra.ZeroTestable        as ZeroTestable++import Algebra.Algebraic (sqrt, (^/))++import qualified Prelude as P++import NumericPrelude+import PreludeBase+++newtype T a v = Cons (PValue v)+{- -fglasgow-exts allow even this+   deriving (Monad, Functor)+-}++type PValue v = Value.T Dimension v++{-+import Control.Monad++instance Functor (SIValue.T a) where+  fmap f (SIValue.Cons x) = SIValue.Cons (f x)++instance Monad (SIValue.T a) where+  (>>=) (SIValue.Cons x) f = f x+  return = SIValue.Cons+-}++{- I hoped it would be possible to replace these functions+   by fmap and monadic liftM, liftM2, return -+   but SIValue.Cons lifts from the base type 'v' to 'SIValue.T a v'+   rather than the type 'PValue v' to 'SIValue.T a v'.++   I.e.+     fmap :: (v -> v) -> SIValue.T a v -> SIValue.T a v+-}+lift :: (PValue v0 -> PValue v1) ->+            (T a v0 -> T a v1)+lift f (Cons x) = (Cons (f x))++lift2 :: (PValue v0 -> PValue v1 -> PValue v2) ->+            (T a v0 -> T a v1 -> T a v2)+lift2 f (Cons x) (Cons y) = (Cons (f x y))++liftGen :: (PValue v -> x) -> (T a v -> x)+liftGen f (Cons x) = f x++lift2Gen :: (PValue v0 -> PValue v1 -> x) ->+               (T a v0 -> T a v1 -> x)+lift2Gen f (Cons x) (Cons y) = f x y+++{- There is almost nothing new to implement for SIValues.+   We have to lift existing functions to SIValues mainly. -}++scale :: Ring.C v => v -> T a v -> T a v+scale = lift . Value.scale++fromScalarSingle :: v -> T a v+fromScalarSingle = Cons . Value.fromScalarSingle+++instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where+  isZero = liftGen isZero++instance Eq v => Eq (T a v) where+  (==)  =  lift2Gen (==)++instance (Show v, Ord a, Trans.C a, NormedMax.C a v) =>+    Show (T a v) where+  showsPrec prec x =+    showParen (prec > PVShow.mulPrec)+       (liftGen (PVShow.showNat+                  (SIUnit.databaseShow :: UnitDatabase.T Dimension a)) x ++)++instance (Read v, Ord a, Trans.C a, VectorSpace.C a v) =>+    Read (T a v) where+  readsPrec prec str =+    map (\(x,s) -> (Cons x, s))+        (PVRead.readsNat (SIUnit.databaseRead :: UnitDatabase.T Dimension a) prec str)++instance (Additive.C v) => Additive.C (T a v) where+  zero   = Cons zero+  (+)    = lift2 (+)+  (-)    = lift2 (-)+  negate = lift negate++instance (Ring.C v) => Ring.C (T a v) where+  (*) = lift2 (*)+  fromInteger = Cons . fromInteger++instance (Ord v) => Ord (T a v) where+  max     = lift2    max+  min     = lift2    min+  compare = lift2Gen compare+  (<)     = lift2Gen (<)+  (>)     = lift2Gen (>)+  (<=)    = lift2Gen (<=)+  (>=)    = lift2Gen (>=)++instance (Real.C v) => Real.C (T a v) where+  abs    = lift abs+  signum = lift signum++instance (Field.C v) => Field.C (T a v) where+  (/) = lift2 (/)+  fromRational' = Cons . fromRational'++instance (Algebraic.C v) => Algebraic.C (T a v) where+  sqrt    = lift  sqrt+  x ^/ y  = lift  (^/ y) x++instance (Trans.C v) => Trans.C (T a v) where+  pi      = Cons pi+  log     = lift  log+  exp     = lift  exp+  logBase = lift2 logBase+  (**)    = lift2 (**)+  cos     = lift  cos+  tan     = lift  tan+  sin     = lift  sin+  acos    = lift  acos+  atan    = lift  atan+  asin    = lift  asin+  cosh    = lift  cosh+  tanh    = lift  tanh+  sinh    = lift  sinh+  acosh   = lift  acosh+  atanh   = lift  atanh+  asinh   = lift  asinh+++instance Vector.C (T a) where+  zero  = zero+  (<+>) = (+)+  (*>)  = scale++instance (Module.C a v) => Module.C a (T b v) where+  (*>) x = lift (x Module.*>)++instance (VectorSpace.C a v) => VectorSpace.C a (T b v)++instance (Trans.C a, Ord a, OccScalar.C a v,+          Show v, NormedMax.C a v)+      => OccScalar.C a (T a v) where+   toScalar      = toScalarShow+   toMaybeScalar = liftGen toMaybeScalar+   fromScalar    = Cons . fromScalar++++quantity :: (Field.C a, Field.C v) => Unit.T Dimension -> v -> T a v+quantity xu = Cons . Value.Cons xu++hertz, second, minute, hour, day, year,+ meter, liter, gramm, tonne,+ newton, pascal, bar, joule, watt,+ kelvin,+ coulomb, ampere, volt, ohm, farad,+ bit, byte, baud,+ inch, foot, yard, astronomicUnit, parsec,+ mach, speedOfLight, electronVolt,+ calorien, horsePower, accelerationOfEarthGravity ::+    (Field.C a, Field.C v) => T a v++hertz   = quantity SIUnit.frequency   1e+0+second  = quantity SIUnit.time        1e+0+minute  = quantity SIUnit.time        SIUnit.secondsPerMinute+hour    = quantity SIUnit.time        SIUnit.secondsPerHour+day     = quantity SIUnit.time        SIUnit.secondsPerDay+year    = quantity SIUnit.time        SIUnit.secondsPerYear+meter   = quantity SIUnit.length      1e+0+liter   = quantity SIUnit.volume      1e-3+gramm   = quantity SIUnit.mass        1e-3+tonne   = quantity SIUnit.mass        1e+3+newton  = quantity SIUnit.force       1e+0+pascal  = quantity SIUnit.pressure    1e+0+bar     = quantity SIUnit.pressure    1e+5+joule   = quantity SIUnit.energy      1e+0+watt    = quantity SIUnit.power       1e+0+coulomb = quantity SIUnit.charge      1e+0+ampere  = quantity SIUnit.current     1e+0+volt    = quantity SIUnit.voltage     1e+0+ohm     = quantity SIUnit.resistance  1e+0+farad   = quantity SIUnit.capacitance 1e+0+kelvin  = quantity SIUnit.temperature 1e+0+bit     = quantity SIUnit.information 1e+0+byte    = quantity SIUnit.information bytesize+baud    = quantity SIUnit.dataRate    1e+0++inch           = quantity SIUnit.length SIUnit.meterPerInch+foot           = quantity SIUnit.length SIUnit.meterPerFoot+yard           = quantity SIUnit.length SIUnit.meterPerYard+astronomicUnit = quantity SIUnit.length SIUnit.meterPerAstronomicUnit+parsec         = quantity SIUnit.length SIUnit.meterPerParsec++accelerationOfEarthGravity+             = quantity SIUnit.acceleration SIUnit.accelerationOfEarthGravity+mach         = quantity SIUnit.speed        SIUnit.mach+speedOfLight = quantity SIUnit.speed        SIUnit.speedOfLight+electronVolt = quantity SIUnit.energy       SIUnit.electronVolt+calorien     = quantity SIUnit.energy       SIUnit.calorien+horsePower   = quantity SIUnit.power        SIUnit.horsePower++++-- 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 (Ord a, Trans.C a, NormedMax.C a v, P.Num v, Field.C v) =>+      P.Fractional (T a v) where+   fromRational = fromRational+   (/) = legacyInstance
+ src/Number/SI/Unit.hs view
@@ -0,0 +1,293 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2003+License     :  GPL++Maintainer  :  numericprelude@henning-thielemann.de+Stability   :  provisional+Portability :  portable++Special physical units: SI unit system+-}++module Number.SI.Unit where++import qualified Algebra.Transcendental      as Trans+import qualified Algebra.Field               as Field++import qualified Number.Physical.Unit         as Unit+import qualified Number.Physical.UnitDatabase as UnitDatabase+import Number.Physical.UnitDatabase(initScale, initUnitSet)+import Data.Maybe(catMaybes)++import PreludeBase hiding (length)+import NumericPrelude hiding (one)++data Dimension =+   Length | Time | Mass | Charge |+   Angle | Temperature | Information+      deriving (Eq, Ord, Enum, Show)+++-- | Some common quantity classes.+angle, angularSpeed, -- needs explicit signature because it does not occur in the database+ length, distance, area, volume, time,+ frequency, speed, acceleration, mass,+ force, pressure, energy, power,+ charge, current, voltage, resistance,+ capacitance, temperature,+ information, dataRate+  :: Unit.T Dimension++length       = Unit.fromVector [ 1, 0, 0, 0, 0, 0, 0]+-- synonym for 'length' which is distinct from List.length+distance     = Unit.fromVector [ 1, 0, 0, 0, 0, 0, 0]+area         = Unit.fromVector [ 2, 0, 0, 0, 0, 0, 0]+volume       = Unit.fromVector [ 3, 0, 0, 0, 0, 0, 0]+time         = Unit.fromVector [ 0, 1, 0, 0, 0, 0, 0]+frequency    = Unit.fromVector [ 0,-1, 0, 0, 0, 0, 0]+speed        = Unit.fromVector [ 1,-1, 0, 0, 0, 0, 0]+acceleration = Unit.fromVector [ 1,-2, 0, 0, 0, 0, 0]+mass         = Unit.fromVector [ 0, 0, 1, 0, 0, 0, 0]+force        = Unit.fromVector [ 1,-2, 1, 0, 0, 0, 0]+pressure     = Unit.fromVector [-1,-2, 1, 0, 0, 0, 0]+energy       = Unit.fromVector [ 2,-2, 1, 0, 0, 0, 0]+power        = Unit.fromVector [ 2,-3, 1, 0, 0, 0, 0]+charge       = Unit.fromVector [ 0, 0, 0, 1, 0, 0, 0]+current      = Unit.fromVector [ 0,-1, 0, 1, 0, 0, 0]+voltage      = Unit.fromVector [ 2,-2, 1,-1, 0, 0, 0]+resistance   = Unit.fromVector [ 2,-1, 1,-2, 0, 0, 0]+capacitance  = Unit.fromVector [-2, 2,-1, 2, 0, 0, 0]+angle        = Unit.fromVector [ 0, 0, 0, 0, 1, 0, 0]+angularSpeed = Unit.fromVector [ 0,-1, 0, 0, 1, 0, 0]+temperature  = Unit.fromVector [ 0, 0, 0, 0, 0, 1, 0]+information  = Unit.fromVector [ 0, 0, 0, 0, 0, 0, 1]+dataRate     = Unit.fromVector [ 0,-1, 0, 0, 0, 0, 1]+++percent, fourth, half, threeFourth   :: Field.C a => a++secondsPerMinute, secondsPerHour, secondsPerDay, secondsPerYear, + meterPerInch, meterPerFoot, meterPerYard,+ meterPerAstronomicUnit, meterPerParsec, + accelerationOfEarthGravity,+ k2, deg180, grad200, bytesize       :: Field.C a => a++radPerDeg, radPerGrad                :: Trans.C a => a++mach, speedOfLight, electronVolt,+ calorien, horsePower                :: Field.C a => a++yocto, zepto, atto, femto, pico,+ nano, micro, milli, centi, deci,+ one, deca, hecto, kilo, mega,+ giga, tera, peta, exa, zetta, yotta :: Field.C a => a++-- | Common constants+percent      = 0.01+fourth       = 0.25+half         = 0.50+threeFourth  = 0.75++-- | Conversion factors+secondsPerMinute = 60+secondsPerHour   = 60*secondsPerMinute+secondsPerDay    = 24*secondsPerHour  -- 86400.0+secondsPerYear   = 365.2422*secondsPerDay++meterPerInch           = 0.0254+meterPerFoot           = 0.3048+meterPerYard           = 0.9144+meterPerAstronomicUnit = 149.6e6+meterPerParsec         = 30.857e12++k2           = 1024+deg180       = 180+grad200      = 200+radPerDeg    = pi/deg180;+radPerGrad   = pi/grad200;+bytesize     = 8++++-- | Physical constants+accelerationOfEarthGravity = 9.80665+mach                       = 332.0+speedOfLight               = 299792458.0+electronVolt               = 1.602e-19+calorien                   = 4.19+horsePower                 = 736.0++-- | Prefixes used for SI units+yocto = 1.0e-24+zepto = 1.0e-21+atto  = 1.0e-18+femto = 1.0e-15+pico  = 1.0e-12+nano  = 1.0e-9+micro = 1.0e-6+milli = 1.0e-3+centi = 1.0e-2+deci  = 1.0e-1+one   = 1.0e0+deca  = 1.0e1+hecto = 1.0e2+kilo  = 1.0e3+mega  = 1.0e6+giga  = 1.0e9+tera  = 1.0e12+peta  = 1.0e15+exa   = 1.0e18+zetta = 1.0e21+yotta = 1.0e24++++{- | UnitDatabase.T of units and their common scalings -}+databaseRead, databaseShow :: Trans.C a => UnitDatabase.T Dimension a+databaseRead = map UnitDatabase.createUnitSet database+databaseShow =+   map UnitDatabase.createUnitSet $+      catMaybes $ map UnitDatabase.showableUnit database++database :: Trans.C a => [UnitDatabase.InitUnitSet Dimension a]+database = [+    (initUnitSet Unit.scalar False [+      (initScale "pi"    pi                        False False),+      (initScale "e"     (exp 1)                   False False),+      (initScale "i"     (sqrt (-1))               False False),+      (initScale "%"     percent                   False False),+      (initScale "\188"  fourth                    False False),+      (initScale "\189"  half                      False False),+      (initScale "\190"  threeFourth               False False)+    ]),+    (initUnitSet angle False [+      (initScale "''"    (radPerDeg/secondsPerHour)   True  False),+      (initScale "'"     (radPerDeg/secondsPerMinute) True  False),+      (initScale "grad"  radPerGrad                False False),+      (initScale "\176"  radPerDeg                 True  True ),+      (initScale "rad"   one                       False False)+    ]),+    (initUnitSet frequency True [+      (initScale "bpm"   (one/secondsPerMinute)    False False),+      (initScale "Hz"    one                       True  True ),+      (initScale "kHz"   kilo                      True  False),+      (initScale "MHz"   mega                      True  False),+      (initScale "GHz"   giga                      True  False)+    ]),+    (initUnitSet time False [+      (initScale "ns"    nano                      True  False),+      (initScale "\181s" micro                     True  False),+      (initScale "ms"    milli                     True  False),+      (initScale "s"     one                       True  True ),+      (initScale "min"   secondsPerMinute          True  False),+      (initScale "h"     secondsPerHour            True  False),+      (initScale "d"     secondsPerDay             True  False),+      (initScale "a"     secondsPerYear            True  False)+    ]),+--    (initUnitSet distance False [+    (initUnitSet length False [+      (initScale "nm"    nano                      True  False),+      (initScale "\181m" micro                     True  False),+      (initScale "mm"    milli                     True  False),+      (initScale "cm"    centi                     True  False),+      (initScale "dm"    deci                      True  False),+      (initScale "m"     one                       True  True ),+      (initScale "km"    kilo                      True  False)+    ]),+    (initUnitSet area False [+      (initScale "ha"    (hecto*hecto)             False False)+    ]),+    (initUnitSet volume False [+      (initScale "ml"    (milli*milli)             False False),+      (initScale "cl"    (milli*centi)             False False),+      (initScale "l"     milli                     False False)+    ]),+    (initUnitSet speed False [+      (initScale "mach"  mach                      False False),+      (initScale "c"     speedOfLight              False False)+    ]),+    (initUnitSet acceleration False [+      (initScale "G"     accelerationOfEarthGravity False False)+    ]),+    (initUnitSet mass False [+      (initScale "\181g" nano                      True  False),+      (initScale "mg"    micro                     True  False),+      (initScale "g"     milli                     True  False),+      (initScale "kg"    one                       True  True ),+      (initScale "dt"    hecto                     True  False),+      (initScale "t"     kilo                      True  False),+      (initScale "kt"    mega                      True  False)+    ]),+    (initUnitSet force False [+      (initScale "N"     one                       True  True ),+      (initScale "kp"    accelerationOfEarthGravity False False),+      (initScale "kN"    kilo                      True  False)+    ]),+    (initUnitSet pressure False [+      (initScale "Pa"    one                       True  True ),+      (initScale "mbar"  hecto                     False False),+      (initScale "kPa"   kilo                      True  False),+      (initScale "bar"   (hecto*kilo)              False False)+    ]),+    (initUnitSet energy False [+      (initScale "eV"    electronVolt              False False),+      (initScale "J"     one                       True  True ),+      (initScale "cal"   calorien                  False False),+      (initScale "kJ"    kilo                      True  False),+      (initScale "kcal"  (kilo*calorien)           False False),+      (initScale "MJ"    mega                      True  False)+    ]),+    (initUnitSet power False [+      (initScale "mW"    milli                     True  False),+      (initScale "W"     one                       True  True ),+      (initScale "HP"    horsePower                False False),+      (initScale "kW"    kilo                      True  False),+      (initScale "MW"    mega                      True  False)+    ]),+    (initUnitSet charge False [+      (initScale "C"     one                       True  True )+    ]),+    (initUnitSet current False [+      (initScale "\181A" micro                     True  False),+      (initScale "mA"    milli                     True  False),+      (initScale "A"     one                       True  True )+    ]),+    (initUnitSet voltage False [+      (initScale "mV"    milli                     True  False),+      (initScale "V"     one                       True  True ),+      (initScale "kV"    kilo                      True  False),+      (initScale "MV"    mega                      True  False),+      (initScale "GV"    giga                      True  False)+    ]),+    (initUnitSet resistance False [+      (initScale "Ohm"   one                       True  True ),+      (initScale "kOhm"  kilo                      True  False),+      (initScale "MOhm"  mega                      True  False)+    ]),+    (initUnitSet capacitance False [+      (initScale "pF"    pico                      True  False),+      (initScale "nF"    nano                      True  False),+      (initScale "\181F" micro                     True  False),+      (initScale "mF"    milli                     True  False),+      (initScale "F"     one                       True  True )+    ]),+    (initUnitSet temperature False [+      (initScale "K"     one                       True  True )+    ]),+    (initUnitSet information False [+      (initScale "bit"   one                       True  True ),+      (initScale "B"     bytesize                  True  False),+      (initScale "kB"    (kilo*bytesize)           False False),+      (initScale "KB"    (k2*bytesize)             True  False),+      (initScale "MB"    (k2*k2*bytesize)          True  False),+      (initScale "GB"    (k2*k2*k2*bytesize)       True  False)+    ]),+    (initUnitSet dataRate True [+      (initScale "baud"  one                       True  True ),+      (initScale "kbaud" kilo                      False False),+      (initScale "Kbaud" k2                        True  False),+      (initScale "Mbaud" (k2*k2)                   True  False),+      (initScale "Gbaud" (k2*k2*k2)                True  False)+    ])+  ]
+ src/NumericPrelude.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -fno-implicit-prelude #-}+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,+    reduceRepeated,+    {- 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, )++import Prelude (Int, Integer, Float, Double)+import NumericPrelude.List (reduceRepeated)
+ src/NumericPrelude/Condition.hs view
@@ -0,0 +1,46 @@+module NumericPrelude.Condition where++{- some routines that are copied from Henning's Useful.hs -}++{- |+Returns 'Just' if the precondition is fulfilled.+-}+toMaybe :: Bool -> a -> Maybe a+toMaybe False _ = Nothing+toMaybe True  x = Just x++{- |+A purely functional implementation of @if@.+Very useful in connection with 'zipWith3'.+-}+if' ::+     Bool  {-^ condition -}+  -> a     {-^ then -}+  -> a     {-^ else -}+  -> a+if' True  x _ = x+if' False _ y = y++{- |+From a list of expressions choose the one,+whose condition is true.++>   select "zero"+>          [(x>0, "positive"),+>           (x<0, "negative")]+-}+select :: a -> [(Bool, a)] -> a+select = foldr (uncurry if')+++-- precedence below (||) and (&&)+infix 1 `implies`++{- |+Logical operator for implication.++Funnily because of the ordering of 'Bool' it holds @implies == (<=)@.+-}+implies :: Bool -> Bool -> Bool+implies prerequisite conclusion =+   not prerequisite || conclusion
+ src/NumericPrelude/List.hs view
@@ -0,0 +1,292 @@+module NumericPrelude.List where++import Data.List (unfoldr, genericReplicate)+import NumericPrelude.Condition (toMaybe)++{- * Slice lists -}+++{-| keep every k-th value from the list++   Since these implementations check for the end of lists,+   they may fail in fixpoint computations on infinite lists. -}+sieve, sieve', sieve'', sieve''' :: Int -> [a] -> [a]+sieve k =+   unfoldr (\xs -> toMaybe (not (null xs)) (head xs, drop k xs))++sieve' k = map head . sliceVert k++-- this one works only on finite lists+sieve'' k x = map (x!!) [0,k..(length x-1)]++sieve''' k = map head . takeWhile (not . null) . iterate (drop k)++{- sliceHoriz is faster than sliceHoriz' but consumes slightly more memory+   (although it needs no swapping) -}+sliceHoriz, sliceHoriz' :: Int -> [a] -> [[a]]+sliceHoriz n =+   map (sieve n) . take n . iterate (drop 1)++sliceHoriz' n =+   foldr (\x ys -> let y = last ys in takeMatch ys ((x:y):ys)) (replicate n [])+++sliceVert, sliceVert' :: Int -> [a] -> [[a]]+sliceVert n =+   map (take n) . takeWhile (not . null) . iterate (drop n)+      {- takeWhile must be performed before (map take)+         in order to handle (n==0) correctly -}++sliceVert' n =+   unfoldr (\x -> toMaybe (not (null x)) (splitAt n x))+++{- * Use lists as counters -}++{- | Make a list as long as another one -}+takeMatch :: [b] -> [a] -> [a]+takeMatch = flip (zipWith const)++splitAtMatch :: [b] -> [a] -> ([a],[a])+splitAtMatch (_:ns) (x:xs) =+   let (as,bs) = splitAtMatch ns xs+   in  (x:as,bs)+splitAtMatch _ [] = ([],[])+splitAtMatch [] xs = ([],xs)++replicateMatch :: [a] -> b -> [b]+replicateMatch xs y =+   takeMatch xs (repeat y)++{- |+Compare the length of two lists over different types.+For finite lists it is equivalent to (compare (length xs) (length ys))+but more efficient.+-}+compareLength :: [a] -> [b] -> Ordering+compareLength (_:xs) (_:ys) = compareLength xs ys+compareLength []     []     = EQ+compareLength (_:_)  []     = GT+compareLength []     (_:_)  = LT++++++{- * Zip lists -}++{- | zip two lists using an arbitrary function, the shorter list is padded -}+zipWithPad :: a               {-^ padding value -}+           -> (a -> a -> b)   {-^ function applied to corresponding elements of the lists -}+           -> [a]+           -> [a]+           -> [b]+zipWithPad z f =+   let aux l []          = map (\x -> f x z) l+       aux [] l          = map (\y -> f z y) l+       aux (x:xs) (y:ys) = f x y : aux xs ys+   in  aux++zipWithOverlap :: (a -> c) -> (b -> c) -> (a -> b -> c) -> [a] -> [b] -> [c]+zipWithOverlap fa fb fab =+   let aux (x:xs) (y:ys) = fab x y : aux xs ys+       aux xs [] = map fa xs+       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+   :: (a -> b -> c)   {-^ function applied to corresponding elements of the lists -}+   -> [a]+   -> [b]+   -> [c]+zipWithMatch f =+   let aux (x:xs) (y:ys) = f x y : aux xs ys+       aux []     []     = []+       aux _      _      = error "zipWith: lists must have the same length"+   in  aux++zipNeighborsWith :: (a -> a -> a) -> [a] -> [a]+zipNeighborsWith f xs = zipWith f xs (drop 1 xs)++++{- * Lists of lists -}++{- |+Transform++@+ [[00,01,02,...],          [[00],+  [10,11,12,...],   -->     [10,01],+  [20,21,22,...],           [20,11,02],+  ...]                      ...]+@++With @concat . shear@ you can perform a Cantor diagonalization,+that is an enumeration of all elements of the sub-lists+where each element is reachable within a finite number of steps.+It is also useful for polynomial multiplication (convolution).+-}+shear :: [[a]] -> [[a]]+shear xs@(_:_) =+   let (y:ys,zs) = unzip (map (splitAt 1) xs)+       zipConc (a:as) (b:bs) = (a++b) : zipConc as bs+       zipConc [] bs = bs+       zipConc as [] = as+   in  y : zipConc ys (shear (dropWhileRev null zs))+              {- Dropping trailing empty lists is necessary,+                 otherwise finite lists are filled with empty lists. -}+shear [] = []++{- |+Transform++@+ [[00,01,02,...],          [[00],+  [10,11,12,...],   -->     [01,10],+  [20,21,22,...],           [02,11,20],+  ...]                      ...]+@++It's like 'shear' but the order of elements in the sub list is reversed.+Its implementation seems to be more efficient than that of 'shear'.+If the order does not matter, better choose 'shearTranspose'.+-}+shearTranspose :: [[a]] -> [[a]]+shearTranspose =+   let -- zipCons is like zipWith (:) keep lists which are too long+       zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys+       zipCons [] ys = ys+       zipCons xs [] = map (:[]) xs+       aux (x:xs) yss = [x] : zipCons xs yss+       aux [] yss = []:yss+   in  foldr aux []+++{- |+Operate on each combination of elements of the first and the second list.+In contrast to the list instance of 'Monad.liftM2'+in holds the results in a list of lists.+It holds+@concat (outerProduct f xs ys)  ==  liftM2 f xs ys@+-}+outerProduct :: (a -> b -> c) -> [a] -> [b] -> [[c]]+outerProduct f xs ys = map (flip map ys . f) xs++++{- * Various -}++partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])+partitionMaybe f =+   foldr (\x ~(y,z) -> case f x of+             Just x' -> (x' : y, z)+             Nothing -> (y, x : z)) ([],[])++{- |+It holds @splitLast xs == (init xs, last xs)@,+but 'splitLast' is more efficient+if the last element is accessed after the initial ones,+because it avoids memoizing list.+-}+splitLast :: [a] -> ([a], a)+splitLast [] = error "splitLast: empty list"+splitLast [x] = ([], x)+splitLast (x:xs) =+   let (xs', lastx) = splitLast xs in (x:xs', lastx)++propSplitLast :: Eq a => [a] -> Bool+propSplitLast xs =+   splitLast xs  ==  (init xs, last xs)++{- |+Remove the longest suffix of elements satisfying p.+In contrast to 'reverse . dropWhile p . reverse'+this works for infinite lists, too.+-}+dropWhileRev :: (a -> Bool) -> [a] -> [a]+dropWhileRev p =+   foldr (\x xs -> if p x && null xs then [] else x:xs) []+++{- |+Apply a function to the last element of a list.+If the list is empty, nothing changes.+-}+mapLast :: (a -> a) -> [a] -> [a]+mapLast f =+   let recurse []     = [] -- behaviour as needed in powerBasis+              -- error "mapLast: empty list"+       recurse (x:[]) = f x : []+       recurse (x:xs) = x : recurse xs+   in  recurse++padLeft :: a -> Int -> [a] -> [a]+padLeft  c n xs = replicate (n - length xs) c ++ xs+++padRight :: a -> Int -> [a] -> [a]+padRight c n xs = xs ++ replicate (n - length xs) c+++{- |+@reduceRepeated@ is an auxiliary function that,+for an associative operation @op@,+computes the same value as++  @reduceRepeated op a0 a n = foldr op a0 (genericReplicate n a)@++but applies "op" O(log n) times and works for large n.+-}++reduceRepeated, reduceRepeatedSlow ::+   (a -> a -> a) -> a -> a -> Integer -> a+reduceRepeated _  a0 _ 0 = a0+reduceRepeated op a0 a n =+   if even n+     then reduceRepeated op a0 (op a a) (div n 2)+     else reduceRepeated op (op a0 a) (op a a) (div n 2)++reduceRepeatedSlow op a0 a n =+   foldr op a0 (genericReplicate n a)+++{- |+For an associative operation @op@ this computes+   @iterateAssoc op a = iterate (op a) a@+but it is even faster than @map (reduceRepeated op a a) [0..]@+since it shares temporary results.++The idea is:+From the list @map (reduceRepeated op a a) [0,(2*n)..]@+we compute the list @map (reduceRepeated op a a) [0,n..]@,+and iterate that until @n==1@.+-}+iterateAssoc, iterateLeaky :: (a -> a -> a) -> a -> [a]+iterateAssoc op a =+   foldr (\pow xs -> pow : concatMap (\x -> [x, op x pow]) xs)+         undefined (iterate (\x -> op x x) a)++{- |+This is equal to 'iterateAssoc'.+The idea is the following:+The list we search is the fixpoint of the function:+"Square all elements of the list,+then spread it and fill the holes with successive numbers+of their left neighbour."+This also preserves log n applications per value.+However it has a space leak,+because for the value with index @n@+all elements starting at @div n 2@ must be kept.+-}+iterateLeaky op x =+   let merge (a:as) b = a : merge b as+       merge _ _ = error "iterateLeaky: an empty list cannot occur"+       sqrs = map (\y -> op y y) z+       z = x : merge sqrs (map (op x) sqrs)+   in  z
+ src/NumericPrelude/Monad.hs view
@@ -0,0 +1,9 @@+module NumericPrelude.Monad where++{- | repeat action until result fulfills condition -}+untilM :: (Monad m) => (a -> Bool) -> m a -> m a+untilM p m =+   do x <- m+      if p x+        then return x+        else untilM p m
+ src/NumericPrelude/Text.hs view
@@ -0,0 +1,30 @@+module NumericPrelude.Text where++{-* Formatting and parsing. -}++{-| Show a value using an infix operator. -}+showsInfixPrec :: (Show a, Show b) =>+                  String -> Int -> Int -> a -> b -> ShowS+showsInfixPrec opStr opPrec prec x y =+   showParen+     (prec >= opPrec)+     (showsPrec opPrec x . showString " " .+      showString opStr . showString " " .+      showsPrec opPrec y)++{-| Parse a string containing an infix operator. -}+readsInfixPrec :: (Read a, Read b) =>+                  String -> Int -> Int -> (a -> b -> c) -> ReadS c+readsInfixPrec opStr opPrec prec cons =+   readParen+     (prec >= opPrec)+     ((\s -> [(const . cons, s)]) .>+      readsPrec opPrec .>+      (filter ((opStr==).fst) . lex) .>+      readsPrec opPrec)++{-| Compose two parsers sequentially. -}+infixl 9 .>+(.>) :: ReadS (b->c) -> ReadS b -> ReadS c+(.>) ra rb =+   concatMap (\(f,rest) -> map (\(b, rest') -> (f b, rest')) (rb rest)) . ra
+ src/PreludeBase.hs view
@@ -0,0 +1,12 @@+{- |+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/Test.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS -fno-implicit-prelude #-}+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/MathObj/PartialFraction.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+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 NumericPrelude.Monad (untilM)+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)+   coarbitrary = undefined++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) :+      []+++{- * Properties for Polynomials -}++newtype IrredPoly = IrredPoly {polyFromIrredPoly :: Poly.T Rational}++type RatPolynomial = Poly.T Rational+type PolyFraction = ([IrredPoly],RatPolynomial)++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 <- untilM (not. isZero) QC.arbitrary+         return (IrredPoly (unit Vector.*> poly))+   coarbitrary = undefined++instance Show IrredPoly where+   show = show . polyFromIrredPoly+++fractionConvPoly :: [IrredPoly] -> RatPolynomial -> Bool+fractionConvPoly =+   fractionConv . map polyFromIrredPoly++fractionConvAltPoly :: [IrredPoly] -> RatPolynomial -> Bool+fractionConvAltPoly =+   fractionConvAlt . map polyFromIrredPoly++fromIrredPolys :: PolyFraction -> PartialFraction.T RatPolynomial+fromIrredPolys (xs,y) =+   PartialFraction.fromFactoredFraction (map polyFromIrredPoly xs) y+++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)++++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) :+      []+++tests :: HUnit.Test+tests =+   HUnit.TestLabel "partial fraction" $+   HUnit.TestList $+      intTests :+--      polyTests :+      []
+ test/Test/MathObj/Polynomial.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+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, (==>))+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)+++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)+++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",         quickCheck (\x -> Laws.identity (+) zero (x :: Poly.T Integer))) :+      ("addition, commutative",  quickCheck (\x -> Laws.commutative (+) (x :: Poly.T Integer))) :+      ("addition, associative",  quickCheck (\x -> Laws.associative (+) (x :: Poly.T Integer))) :+      ("multiplication, one",          quickCheck (\x -> Laws.identity (*) one (x :: Poly.T Integer))) :+      ("multiplication, commutative",  quickCheck (\x -> Laws.commutative (*) (x :: Poly.T Integer))) :+      ("multiplication, associative",  quickCheck (\x -> Laws.associative (*) (x :: Poly.T Integer))) :+      ("multiplication and addition, distributive",   quickCheck (\x -> Laws.leftDistributive (*) (+) (x :: Poly.T Integer))) :+      ("division",       quickCheck (\x -> Integral.propInverse (x :: Poly.T Rational))) :+      []
+ test/Test/MathObj/PowerSeries.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+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]))+++++powerMult :: Rational -> Rational -> Bool+powerMult exp0 exp1 =+   PS.mul (PSE.pow exp0) (PSE.pow exp1)  ==  PSE.pow (exp0+exp1)++powerExplODE :: Rational -> Bool+powerExplODE expon =+   PSE.powODE expon == PSE.powExpl expon+++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/Test/NumericPrelude/List.hs view
@@ -0,0 +1,85 @@+module Test.NumericPrelude.List where++import qualified NumericPrelude.List as NList+import qualified Data.List as List+import Control.Monad (liftM2)++import Test.NumericPrelude.Utility (equalLists, equalInfLists, testUnit)+import Test.QuickCheck (Property, quickCheck, (==>))+import qualified Test.HUnit as HUnit++++sieve :: Eq a => Int -> [a] -> Property+sieve n x =+   n>0 ==>+      equalLists [NList.sieve    n x,+                  NList.sieve'   n x,+                  NList.sieve''  n x,+                  NList.sieve''' n x]+++sliceHoriz :: Eq a => Int -> [a] -> Property+sliceHoriz n x =+   n>0 ==>+      NList.sliceHoriz n x == NList.sliceHoriz' n x+++sliceVert :: Eq a => Int -> [a] -> Property+sliceVert n x =+   n>0 ==>+      NList.sliceVert n x == NList.sliceVert' n x++slice :: Eq a => Int -> [a] -> Property+slice n x =+   0<n && n <= length x  ==>+      -- problems: NList.sliceHoriz 4 [] == [[],[],[],[]]+      NList.sliceHoriz n x == List.transpose (NList.sliceVert  n x)  &&+      NList.sliceVert  n x == List.transpose (NList.sliceHoriz n x)+++++shear :: Eq a => [[a]] -> Bool+shear xs =+   NList.shearTranspose xs  ==  map reverse (NList.shear xs)++++outerProduct :: (Eq a, Eq b) => [a] -> [b] -> Bool+outerProduct xs ys =+   equalLists [concat (NList.outerProduct (,) xs ys),  liftM2 (,) xs ys]++++reduceRepeated :: Eq a =>+   (a -> a -> a) -> a -> a -> Integer -> Property+reduceRepeated op a0 a n =+   n>0 ==>+      NList.reduceRepeated op a0 a n == NList.reduceRepeatedSlow op a0 a n+++iterate' :: Eq a => (a -> a -> a) -> a -> Bool+iterate' op a =+   let xs = List.iterate (op a) a+       ys = NList.iterateAssoc op a+       zs = NList.iterateLeaky op a+   in  equalInfLists 1000 [xs, ys, zs]+++++tests :: HUnit.Test+tests =+   HUnit.TestLabel "list" $+   HUnit.TestList $+   map testUnit $+      ("sieve",          quickCheck (sieve              :: Int -> [Integer] -> Property)) :+      ("sliceHoriz",     quickCheck (sliceHoriz         :: Int -> [Integer] -> Property)) :+      ("sliceVert",      quickCheck (sliceVert          :: Int -> [Integer] -> Property)) :+      ("slice",          quickCheck (slice              :: Int -> [Integer] -> Property)) :+      ("shear",          quickCheck (shear              :: [[Integer]] -> Bool)) :+      ("outerProduct",   quickCheck (outerProduct       :: [Integer] -> [Int] -> Bool)) :+      ("reduceRepeated", quickCheck (reduceRepeated (+) :: Integer -> Integer -> Integer -> Property)) :+      ("iterate",        quickCheck (iterate'       (+) :: Integer -> Bool)) :+      []
+ test/Test/NumericPrelude/Utility.hs view
@@ -0,0 +1,19 @@+module Test.NumericPrelude.Utility where++import qualified Data.List as List+import qualified Test.HUnit as HUnit+++testUnit :: (String, IO ()) -> HUnit.Test+testUnit (label, check) =+   HUnit.TestLabel label (HUnit.TestCase check)+++equalLists :: Eq a => [[a]] -> Bool+equalLists xs =+   let equalElems ys =+          and (zipWith (==) ys (tail 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)
+ test/Test/Run.hs view
@@ -0,0 +1,18 @@+module Main where++import qualified Test.NumericPrelude.List as NList+import qualified Test.MathObj.PartialFraction as PartialFraction+import qualified Test.MathObj.Polynomial  as Polynomial+import qualified Test.MathObj.PowerSeries as PowerSeries+import qualified Test.HUnit.Text as HUnitText+import qualified Test.HUnit as HUnit++main :: IO ()+main =+   do HUnitText.runTestTT (HUnit.TestList $+         NList.tests :+         PartialFraction.tests :+         Polynomial.tests :+         PowerSeries.tests :+         [])+      return ()