diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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` diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple (defaultMain) + +> main :: IO () +> main = defaultMain diff --git a/docs/NOTES b/docs/NOTES new file mode 100644 --- /dev/null +++ b/docs/NOTES @@ -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 + http://www.haskell.org/pipermail/haskell-cafe/2002-February/002660.html + + jan.skibinski@sympatico.ca + indexless linear algebra + + blaetterrascheln@web.de + Christian Sievers + Remi Turk , rturk@science.uva.nl + Ronny Wichers Schreur + floorSqrt + + William Lee Irwin III + ContFrac, continued fractions + + Juergen Bokowski + 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 + + + + + diff --git a/docs/README b/docs/README new file mode 100644 --- /dev/null +++ b/docs/README @@ -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]])] diff --git a/numeric-prelude.cabal b/numeric-prelude.cabal new file mode 100644 --- /dev/null +++ b/numeric-prelude.cabal @@ -0,0 +1,232 @@ +Name: numeric-prelude +Version: 0.0.2 +License: GPL +License-File: LICENSE +Author: Dylan Thurston , Henning Thielemann , Mikael Johansson +Maintainer: Henning Thielemann +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 diff --git a/src/Algebra/Additive.hs b/src/Algebra/Additive.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Additive.hs @@ -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 diff --git a/src/Algebra/Algebraic.hs b/src/Algebra/Algebraic.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Algebraic.hs @@ -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 diff --git a/src/Algebra/Differential.hs b/src/Algebra/Differential.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Differential.hs @@ -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 diff --git a/src/Algebra/DimensionTerm.hs b/src/Algebra/DimensionTerm.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/DimensionTerm.hs @@ -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 diff --git a/src/Algebra/DivisibleSpace.hs b/src/Algebra/DivisibleSpace.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/DivisibleSpace.hs @@ -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 + diff --git a/src/Algebra/Field.hs b/src/Algebra/Field.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Field.hs @@ -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./) diff --git a/src/Algebra/Indexable.hs b/src/Algebra/Indexable.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Indexable.hs @@ -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 diff --git a/src/Algebra/IntegralDomain.hs b/src/Algebra/IntegralDomain.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/IntegralDomain.hs @@ -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 diff --git a/src/Algebra/Lattice.hs b/src/Algebra/Lattice.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Lattice.hs @@ -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 diff --git a/src/Algebra/Laws.hs b/src/Algebra/Laws.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Laws.hs @@ -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 diff --git a/src/Algebra/Module.hs b/src/Algebra/Module.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Module.hs @@ -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) (+) (+) diff --git a/src/Algebra/ModuleBasis.hs b/src/Algebra/ModuleBasis.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/ModuleBasis.hs @@ -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]) diff --git a/src/Algebra/Monoid.hs b/src/Algebra/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Monoid.hs @@ -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 diff --git a/src/Algebra/NonNegative.hs b/src/Algebra/NonNegative.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/NonNegative.hs @@ -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 diff --git a/src/Algebra/NormedSpace/Euclidean.hs b/src/Algebra/NormedSpace/Euclidean.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/NormedSpace/Euclidean.hs @@ -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 diff --git a/src/Algebra/NormedSpace/Maximum.hs b/src/Algebra/NormedSpace/Maximum.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/NormedSpace/Maximum.hs @@ -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 diff --git a/src/Algebra/NormedSpace/Sum.hs b/src/Algebra/NormedSpace/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/NormedSpace/Sum.hs @@ -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 diff --git a/src/Algebra/OccasionallyScalar.hs b/src/Algebra/OccasionallyScalar.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/OccasionallyScalar.hs @@ -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) +-} diff --git a/src/Algebra/PrincipalIdealDomain.hs b/src/Algebra/PrincipalIdealDomain.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/PrincipalIdealDomain.hs @@ -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) diff --git a/src/Algebra/Real.hs b/src/Algebra/Real.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Real.hs @@ -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 diff --git a/src/Algebra/RealField.hs b/src/Algebra/RealField.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/RealField.hs @@ -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 + diff --git a/src/Algebra/RealIntegral.hs b/src/Algebra/RealIntegral.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/RealIntegral.hs @@ -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 +, + +-} +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 diff --git a/src/Algebra/RealTranscendental.hs b/src/Algebra/RealTranscendental.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/RealTranscendental.hs @@ -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 diff --git a/src/Algebra/RightModule.hs b/src/Algebra/RightModule.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/RightModule.hs @@ -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 diff --git a/src/Algebra/Ring.hs b/src/Algebra/Ring.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Ring.hs @@ -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.*) diff --git a/src/Algebra/ToInteger.hs b/src/Algebra/ToInteger.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/ToInteger.hs @@ -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 + +-} +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 diff --git a/src/Algebra/ToRational.hs b/src/Algebra/ToRational.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/ToRational.hs @@ -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 diff --git a/src/Algebra/Transcendental.hs b/src/Algebra/Transcendental.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Transcendental.hs @@ -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 + diff --git a/src/Algebra/Units.hs b/src/Algebra/Units.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Units.hs @@ -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 (*) (*) + diff --git a/src/Algebra/Vector.hs b/src/Algebra/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/Vector.hs @@ -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 diff --git a/src/Algebra/VectorSpace.hs b/src/Algebra/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/VectorSpace.hs @@ -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) diff --git a/src/Algebra/ZeroTestable.hs b/src/Algebra/ZeroTestable.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/ZeroTestable.hs @@ -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 diff --git a/src/MathObj/Algebra.hs b/src/MathObj/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Algebra.hs @@ -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) diff --git a/src/MathObj/DiscreteMap.hs b/src/MathObj/DiscreteMap.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/DiscreteMap.hs @@ -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 diff --git a/src/MathObj/LaurentPolynomial.hs b/src/MathObj/LaurentPolynomial.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/LaurentPolynomial.hs @@ -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 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)) diff --git a/src/MathObj/Matrix.hs b/src/MathObj/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Matrix.hs @@ -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 +-} diff --git a/src/MathObj/PartialFraction.hs b/src/MathObj/PartialFraction.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PartialFraction.hs @@ -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) + diff --git a/src/MathObj/Permutation.hs b/src/MathObj/Permutation.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Permutation.hs @@ -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 diff --git a/src/MathObj/Permutation/CycleList.hs b/src/MathObj/Permutation/CycleList.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Permutation/CycleList.hs @@ -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 diff --git a/src/MathObj/Permutation/CycleList/Check.hs b/src/MathObj/Permutation/CycleList/Check.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Permutation/CycleList/Check.hs @@ -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" diff --git a/src/MathObj/Permutation/Table.hs b/src/MathObj/Permutation/Table.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Permutation/Table.hs @@ -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)] diff --git a/src/MathObj/Polynomial.hs b/src/MathObj/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Polynomial.hs @@ -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 diff --git a/src/MathObj/PowerSeries.hs b/src/MathObj/PowerSeries.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSeries.hs @@ -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) diff --git a/src/MathObj/PowerSeries/DifferentialEquation.hs b/src/MathObj/PowerSeries/DifferentialEquation.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSeries/DifferentialEquation.hs @@ -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]) diff --git a/src/MathObj/PowerSeries/Example.hs b/src/MathObj/PowerSeries/Example.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSeries/Example.hs @@ -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 diff --git a/src/MathObj/PowerSeries/Mean.hs b/src/MathObj/PowerSeries/Mean.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSeries/Mean.hs @@ -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 diff --git a/src/MathObj/PowerSeries2.hs b/src/MathObj/PowerSeries2.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSeries2.hs @@ -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 diff --git a/src/MathObj/PowerSum.hs b/src/MathObj/PowerSum.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/PowerSum.hs @@ -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 diff --git a/src/MathObj/RootSet.hs b/src/MathObj/RootSet.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/RootSet.hs @@ -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) diff --git a/src/MyPrelude.hs b/src/MyPrelude.hs new file mode 100644 --- /dev/null +++ b/src/MyPrelude.hs @@ -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) diff --git a/src/Number/Complex.hs b/src/Number/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Number/Complex.hs @@ -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 diff --git a/src/Number/DimensionTerm.hs b/src/Number/DimensionTerm.hs new file mode 100644 --- /dev/null +++ b/src/Number/DimensionTerm.hs @@ -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 diff --git a/src/Number/DimensionTerm/SI.hs b/src/Number/DimensionTerm/SI.hs new file mode 100644 --- /dev/null +++ b/src/Number/DimensionTerm/SI.hs @@ -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 +-} diff --git a/src/Number/FixedPoint.hs b/src/Number/FixedPoint.hs new file mode 100644 --- /dev/null +++ b/src/Number/FixedPoint.hs @@ -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) diff --git a/src/Number/FixedPoint/Check.hs b/src/Number/FixedPoint/Check.hs new file mode 100644 --- /dev/null +++ b/src/Number/FixedPoint/Check.hs @@ -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 diff --git a/src/Number/NonNegative.hs b/src/Number/NonNegative.hs new file mode 100644 --- /dev/null +++ b/src/Number/NonNegative.hs @@ -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 -} diff --git a/src/Number/OccasionallyScalarExpression.hs b/src/Number/OccasionallyScalarExpression.hs new file mode 100644 --- /dev/null +++ b/src/Number/OccasionallyScalarExpression.hs @@ -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 +-} diff --git a/src/Number/PartiallyTranscendental.hs b/src/Number/PartiallyTranscendental.hs new file mode 100644 --- /dev/null +++ b/src/Number/PartiallyTranscendental.hs @@ -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 diff --git a/src/Number/Peano.hs b/src/Number/Peano.hs new file mode 100644 --- /dev/null +++ b/src/Number/Peano.hs @@ -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. + +-} +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 diff --git a/src/Number/Physical.hs b/src/Number/Physical.hs new file mode 100644 --- /dev/null +++ b/src/Number/Physical.hs @@ -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 diff --git a/src/Number/Physical/Read.hs b/src/Number/Physical/Read.hs new file mode 100644 --- /dev/null +++ b/src/Number/Physical/Read.hs @@ -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) diff --git a/src/Number/Physical/Show.hs b/src/Number/Physical/Show.hs new file mode 100644 --- /dev/null +++ b/src/Number/Physical/Show.hs @@ -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))) diff --git a/src/Number/Physical/Unit.hs b/src/Number/Physical/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Number/Physical/Unit.hs @@ -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 +-} diff --git a/src/Number/Physical/UnitDatabase.hs b/src/Number/Physical/UnitDatabase.hs new file mode 100644 --- /dev/null +++ b/src/Number/Physical/UnitDatabase.hs @@ -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 [(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) diff --git a/src/Number/Positional.hs b/src/Number/Positional.hs new file mode 100644 --- /dev/null +++ b/src/Number/Positional.hs @@ -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 . +-} +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 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 (( 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. +-} diff --git a/src/Number/Positional/Check.hs b/src/Number/Positional/Check.hs new file mode 100644 --- /dev/null +++ b/src/Number/Positional/Check.hs @@ -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 +-} diff --git a/src/Number/Quaternion.hs b/src/Number/Quaternion.hs new file mode 100644 --- /dev/null +++ b/src/Number/Quaternion.hs @@ -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) + diff --git a/src/Number/Ratio.hs b/src/Number/Ratio.hs new file mode 100644 --- /dev/null +++ b/src/Number/Ratio.hs @@ -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 diff --git a/src/Number/ResidueClass.hs b/src/Number/ResidueClass.hs new file mode 100644 --- /dev/null +++ b/src/Number/ResidueClass.hs @@ -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 diff --git a/src/Number/ResidueClass/Check.hs b/src/Number/ResidueClass/Check.hs new file mode 100644 --- /dev/null +++ b/src/Number/ResidueClass/Check.hs @@ -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" diff --git a/src/Number/ResidueClass/Func.hs b/src/Number/ResidueClass/Func.hs new file mode 100644 --- /dev/null +++ b/src/Number/ResidueClass/Func.hs @@ -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" diff --git a/src/Number/ResidueClass/Maybe.hs b/src/Number/ResidueClass/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Number/ResidueClass/Maybe.hs @@ -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 diff --git a/src/Number/ResidueClass/Reader.hs b/src/Number/ResidueClass/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Number/ResidueClass/Reader.hs @@ -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 diff --git a/src/Number/SI.hs b/src/Number/SI.hs new file mode 100644 --- /dev/null +++ b/src/Number/SI.hs @@ -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 diff --git a/src/Number/SI/Unit.hs b/src/Number/SI/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Number/SI/Unit.hs @@ -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) + ]) + ] diff --git a/src/NumericPrelude.hs b/src/NumericPrelude.hs new file mode 100644 --- /dev/null +++ b/src/NumericPrelude.hs @@ -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) diff --git a/src/NumericPrelude/Condition.hs b/src/NumericPrelude/Condition.hs new file mode 100644 --- /dev/null +++ b/src/NumericPrelude/Condition.hs @@ -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 diff --git a/src/NumericPrelude/List.hs b/src/NumericPrelude/List.hs new file mode 100644 --- /dev/null +++ b/src/NumericPrelude/List.hs @@ -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 diff --git a/src/NumericPrelude/Monad.hs b/src/NumericPrelude/Monad.hs new file mode 100644 --- /dev/null +++ b/src/NumericPrelude/Monad.hs @@ -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 diff --git a/src/NumericPrelude/Text.hs b/src/NumericPrelude/Text.hs new file mode 100644 --- /dev/null +++ b/src/NumericPrelude/Text.hs @@ -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 diff --git a/src/PreludeBase.hs b/src/PreludeBase.hs new file mode 100644 --- /dev/null +++ b/src/PreludeBase.hs @@ -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) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 diff --git a/test/Test/MathObj/PartialFraction.hs b/test/Test/MathObj/PartialFraction.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/PartialFraction.hs @@ -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 : + [] diff --git a/test/Test/MathObj/Polynomial.hs b/test/Test/MathObj/Polynomial.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/Polynomial.hs @@ -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))) : + [] diff --git a/test/Test/MathObj/PowerSeries.hs b/test/Test/MathObj/PowerSeries.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/PowerSeries.hs @@ -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)) : + [] +-} + ] diff --git a/test/Test/NumericPrelude/List.hs b/test/Test/NumericPrelude/List.hs new file mode 100644 --- /dev/null +++ b/test/Test/NumericPrelude/List.hs @@ -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 + -- 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)) : + [] diff --git a/test/Test/NumericPrelude/Utility.hs b/test/Test/NumericPrelude/Utility.hs new file mode 100644 --- /dev/null +++ b/test/Test/NumericPrelude/Utility.hs @@ -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) diff --git a/test/Test/Run.hs b/test/Test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Test/Run.hs @@ -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 ()