diff --git a/CREDITS.txt b/CREDITS.txt new file mode 100644 --- /dev/null +++ b/CREDITS.txt @@ -0,0 +1,7 @@ +AUTHORS + +Bastiaan Heeren, Alex gerdes, Johan Jeuring + +CREDITS + +Harrie Passier, Arthur van Leeuwen, Josje Lodder diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/ideas.cabal b/ideas.cabal new file mode 100644 --- /dev/null +++ b/ideas.cabal @@ -0,0 +1,173 @@ +name: ideas +version: 0.5.8 +synopsis: Feedback services for intelligent tutoring systems +homepage: http://ideas.cs.uu.nl/ +description: + + ideas provides feedback services to intelligent tutoring systems such as + the digital mathematical environment of the Freudenthal Institute, MathDox, + and Activemath. + +category: Education +copyright: (c) 2009 +license: GPL +license-file: LICENSE.txt +author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring +maintainer: bastiaan.heeren@ou.nl +stability: provisional +extra-source-files: CREDITS.txt +build-type: Simple +cabal-version: >= 1.2.1 +tested-with: GHC == 6.10.1 + +-------------------------------------------------------------------------------- + +Executable ideas + Main-is: Service/Main.hs + ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports + hs-source-dirs: src + other-modules: + Common.Apply , + Common.Context , + Common.Derivation , + Common.Exercise , + Common.Grammar , + Common.Rewriting , + Common.Rewriting.AC , + Common.Rewriting.Confluence , + Common.Rewriting.Difference , + Common.Rewriting.MetaVar , + Common.Rewriting.RewriteRule , + Common.Rewriting.Substitution , + Common.Rewriting.Unification , + Common.Strategy , + Common.Transformation , + Common.Traversable , + Common.Uniplate , + Common.Utils , + Common.View , + Domain.LinearAlgebra , + Domain.LinearAlgebra.Checks , + Domain.LinearAlgebra.EquationsRules , + Domain.LinearAlgebra.Exercises , + Domain.LinearAlgebra.GramSchmidtRules , + Domain.LinearAlgebra.LinearSystem , + Domain.LinearAlgebra.LinearView , + Domain.LinearAlgebra.Matrix , + Domain.LinearAlgebra.MatrixRules , + Domain.LinearAlgebra.Parser , + Domain.LinearAlgebra.Strategies , + Domain.LinearAlgebra.Symbols , + Domain.LinearAlgebra.Vector , + Domain.Logic , + Domain.Logic.BuggyRules , + Domain.Logic.Exercises , + Domain.Logic.FeedbackText , + Domain.Logic.Formula , + Domain.Logic.GeneralizedRules , + Domain.Logic.Generator , + Domain.Logic.Parser , + Domain.Logic.Rules , + Domain.Logic.Strategies , + Domain.Math.Approximation , + Domain.Math.Data.Equation , + Domain.Math.Data.OrList , + Domain.Math.Data.Polynomial , + Domain.Math.Data.PrimeFactors , + Domain.Math.Data.SquareRoot , + Domain.Math.DerivativeExercise , + Domain.Math.DerivativeRules , + Domain.Math.Equation.CoverUpExercise , + Domain.Math.Equation.CoverUpRules , + Domain.Math.Equation.Views , + Domain.Math.Examples.DWO1 , + Domain.Math.Examples.DWO2 , + Domain.Math.Expr , + Domain.Math.Expr.Conversion , + Domain.Math.Expr.Data , + Domain.Math.Expr.Parser , + Domain.Math.Expr.Symbolic , + Domain.Math.Expr.Symbols , + Domain.Math.Expr.Views , + Domain.Math.Numeric.Exercises , + Domain.Math.Numeric.Generators , + Domain.Math.Numeric.Laws , + Domain.Math.Numeric.Rules , + Domain.Math.Numeric.Strategies , + Domain.Math.Numeric.Views , + Domain.Math.Polynomial.BuggyRules , + Domain.Math.Polynomial.CleanUp , + Domain.Math.Polynomial.Exercises , + Domain.Math.Polynomial.Generators , + Domain.Math.Polynomial.Rules , + Domain.Math.Polynomial.Strategies , + Domain.Math.Polynomial.Views , + Domain.Math.Power.Views , + Domain.Math.Simplification , + Domain.Math.SquareRoot.Views , + Domain.Math.Strategy.BrokenEquations , + Domain.Math.Strategy.Modulus , + Domain.Math.Strategy.SquareRootEquations , + Domain.Math.Strategy.SquareRootSimplification , + Domain.Programming , + Domain.RelationAlgebra , + Domain.RelationAlgebra.Equivalence , + Domain.RelationAlgebra.Exercises , + Domain.RelationAlgebra.Formula , + Domain.RelationAlgebra.Generator , + Domain.RelationAlgebra.Parser , + Domain.RelationAlgebra.Rules , + Domain.RelationAlgebra.Strategies , + Service.ExerciseList , + Service.FeedbackText , + Service.LoggingDatabase , + Service.Main , + Service.ModeJSON , + Service.ModeXML , + Service.Options , + Service.ProblemDecomposition , + Service.Request , + Service.Revision , + Service.SearchSpace , + Service.ServiceList , + Service.TypedAbstractService , + Service.Types , + Text.HTML , + Text.JSON , + Text.OpenMath.ContentDictionary , + Text.OpenMath.Dictionary.Arith1 , + Text.OpenMath.Dictionary.Calculus1 , + Text.OpenMath.Dictionary.Fns1 , + Text.OpenMath.Dictionary.Linalg2 , + Text.OpenMath.Dictionary.List1 , + Text.OpenMath.Dictionary.Logic1 , + Text.OpenMath.Dictionary.Nums1 , + Text.OpenMath.Dictionary.Relation1 , + Text.OpenMath.Dictionary.Transc1 , + Text.OpenMath.MakeSymbols , + Text.OpenMath.Object , + Text.OpenMath.Reply , + Text.OpenMath.Request , + Text.OpenMath.Symbol , + Text.Parsing , + Text.UTF8 , + Text.XML , + Text.XML.Document , + Text.XML.Interface , + Text.XML.ParseLib , + Text.XML.Parser , + Text.XML.TestSuite , + Text.XML.Unicode + build-depends: base >= 3.0 && < 4.0, + time, + mtl, + cgi, + containers, + QuickCheck, + random, + uulib, + filepath, + parsec + +-------------------------------------------------------------------------------- + diff --git a/src/Common/Apply.hs b/src/Common/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Common/Apply.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines the type class Apply and some related utility functions. +-- +----------------------------------------------------------------------------- +module Common.Apply where + +import Common.Utils (safeHead) +import Control.Monad (join) +import Data.Maybe (isJust, fromMaybe) + + +-- | A type class for functors that can be applied to a value. Transformation, Rule, and +-- Strategy are all instances of this type class. Minimal complete definition: only one of +-- the two member functions should be defined. +class Apply t where + apply :: t a -> a -> Maybe a -- ^ Returns zero or one results + applyAll :: t a -> a -> [a] -- ^ Returns zero or more results + -- default definitions + apply ta = safeHead . applyAll ta + applyAll ta = maybe [] return . apply ta + +-- | Checks whether the functor is applicable (at least one result) +applicable :: Apply t => t a -> a -> Bool +applicable ta = isJust . apply ta + +-- | If not applicable, return the current value (as default) +applyD :: Apply t => t a -> a -> a +applyD ta a = fromMaybe a (apply ta a) + +-- | Same as apply, except that the result (at most one) is returned in some monad +applyM :: (Apply t, Monad m) => t a -> a -> m a +applyM ta = maybe (fail "applyM") return . apply ta + +-- | Apply a list of steps, and return at most one result +applyList :: Apply t => [t a] -> a -> Maybe a +applyList xs a = foldl (\ma t -> join $ fmap (apply t) ma) (Just a) xs + +-- | Apply a list of steps, and return all results +applyListAll :: Apply t => [t a] -> a -> [a] +applyListAll xs a = foldl (\ma t -> concatMap (applyAll t) ma) [a] xs + +-- | Apply a list of steps, and if there is no result, return the current value (as default) +applyListD :: Apply t => [t a] -> a -> a +applyListD xs a = foldl (\a t -> applyD t a) a xs + +-- Apply a list of steps, and return the result (at most one) in some monad +applyListM :: (Apply t, Monad m) => [t a] -> a -> m a +applyListM xs a = foldl (\ma t -> ma >>= applyM t) (return a) xs diff --git a/src/Common/Context.hs b/src/Common/Context.hs new file mode 100644 --- /dev/null +++ b/src/Common/Context.hs @@ -0,0 +1,198 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A context for a term that maintains a current focus and an environment of +-- key-value pairs. A context is both showable and parsable. +-- +----------------------------------------------------------------------------- +module Common.Context + ( -- * Abstract data type + Context, inContext, fromContext, showContext, parseContext + -- * Variable environment + , Var(..), intVar, integerVar, boolVar, get, set, change + -- * Location (current focus) + , Location, location, setLocation, changeLocation + , currentFocus, changeFocus, locationDown, locationUp + , makeLocation, fromLocation + -- * Lifting + , liftToContext, ignoreContext + ) where + +import Common.Transformation +import Common.Uniplate +import Common.Utils +import Control.Monad +import Data.Char +import Data.Dynamic +import Data.List +import Test.QuickCheck +import qualified Data.Map as M + + +---------------------------------------------------------- +-- Abstract data type + +-- | Abstract data type for a context: a context stores an envrionent (key-value pairs) and +-- a current focus (list of integers) +data Context a = C Location Environment a + +instance Eq a => Eq (Context a) where + x == y = fromContext x == fromContext y + +instance Ord a => Ord (Context a) where + x `compare` y = fromContext x `compare` fromContext y + +instance Show a => Show (Context a) where + show c = showContext c ++ ";" ++ show (fromContext c) + +instance Functor Context where + fmap f (C loc env a) = C loc env (f a) + +instance Arbitrary a => Arbitrary (Context a) where + arbitrary = liftM inContext arbitrary + coarbitrary = coarbitrary . fromContext + +-- | Put a value into a (default) context +inContext :: a -> Context a +inContext = C (L []) M.empty + +-- | Retrieve a value from its context +fromContext :: Context a -> a +fromContext (C _ _ a) = a + +---------------------------------------------------------- +-- A simple parser and pretty-printer for contexts + +-- | Shows the context (without the embedded value) +showContext :: Context a -> String +showContext (C loc env _) = show loc ++ ";" ++ showEnv env + +-- local helper function +showEnv :: Environment -> String +showEnv = concat . intersperse "," . map f . M.toList + where f (k, (_, v)) = k ++ "=" ++ v + +-- | Parses a context: on a successful parse, the unit value is returned +-- in the parsed context +parseContext :: String -> Maybe (Context ()) +parseContext s + | all isSpace s = + return (C (L []) M.empty ()) + | otherwise = do + (locString, envString) <- splitAtElem ';' s + loc <- case reads locString of + [(l, xs)] | all isSpace xs -> return l + _ -> Nothing + env <- if all isSpace envString then return M.empty else do + pairs <- mapM (splitAtElem '=') (splitsWithElem ',' envString) + let f (k, v) = (k, (Nothing, v)) + return $ M.fromList $ map f pairs + return (C loc env ()) + +---------------------------------------------------------- +-- Manipulating the variable environment + +-- local type synonym: can probably be simplified +type Environment = M.Map String (Maybe Dynamic, String) + +-- | A variable has a name (for showing) and a default value (for initializing) +data Var a = String := a -- ^ Constructs a new variable + +-- | Make a new variable of type Int (initialized with 0) +intVar :: String -> Var Int +intVar = (:= 0) + +-- | Make a new variable of type Integer (initialized with 0) +integerVar :: String -> Var Integer +integerVar = (:= 0) + +-- | Make a new variable of type Bool (initialized with True) +boolVar :: String -> Var Bool +boolVar = (:= True) + +-- | Returns the value of a variable stored in a context +get :: (Read a, Typeable a) => Var a -> Context b -> a +get (s := a) (C _ env _) = + case M.lookup s env of + Nothing -> a -- return default value + Just (Just d, _) -> fromDyn d a -- use the stored dynamic (default value as backup) + Just (Nothing, s) -> + case reads s of -- parse the pretty-printed value (default value as backup) + [(b, rest)] | all isSpace rest -> b + _ -> a + +-- | Replaces the value of a variable stored in a context +set :: (Show a, Typeable a) => Var a -> a -> Context b -> Context b +set (s := _) a (C loc env b) = C loc (M.insert s (Just (toDyn a), show a) env) b + +-- | Updates the value of a variable stored in a context +change :: (Show a, Read a, Typeable a) => Var a -> (a -> a) -> Context b -> Context b +change v f c = set v (f (get v c)) c + +---------------------------------------------------------- +-- Location (current focus) + +-- | Type synonym for the current location (focus) +newtype Location = L [Int] deriving (Eq, Ord) + +instance Show Location where + show (L is) = show is + +instance Read Location where + readsPrec n s = [ (L is, rest) | (is, rest) <- readsPrec n s ] + +-- | Returns the current location of a context +location :: Context a -> Location +location (C loc _ _) = loc + +-- | Replaces the current location of a context +setLocation :: Location -> Context a -> Context a +setLocation loc (C _ env a) = C loc env a + +-- | Updates the current location of a context +changeLocation :: (Location -> Location) -> Context a -> Context a +changeLocation f c = setLocation (f (location c)) c + +-- | Returns the term which has the current focus: Nothing indicates that the current +-- focus is invalid +currentFocus :: Uniplate a => Context a -> Maybe a +currentFocus c = getTermAt (fromLocation $ location c) (fromContext c) + +-- | Changes the term which has the current focus. In case the focus is invalid, then +-- this function has no effect. +changeFocus :: Uniplate a => (a -> a) -> Context a -> Context a +changeFocus f c = fmap (applyAt (fromLocation $ location c) f) c + +-- | Go down to a certain child +locationDown :: Int -> Location -> Location +locationDown i (L is) = L (is ++ [i]) + +-- | Go up: Nothing indicates that we were already at the top +locationUp :: Location -> Maybe Location +locationUp (L is) + | null is = Nothing + | otherwise = Just (L (init is)) + +makeLocation :: [Int] -> Location +makeLocation = L + +fromLocation :: Location -> [Int] +fromLocation (L is) = is + +---------------------------------------------------------- +-- Lifting rewrite rules + +-- | Lift a rule to operate on a term in a context +liftToContext :: (Lift f, Uniplate a) => f a -> f (Context a) +liftToContext = lift $ makeLiftPair currentFocus (changeFocus . const) + +-- | Lift a rule to operate on a term in a context by ignoring the context +ignoreContext :: Lift f => f a -> f (Context a) +ignoreContext = lift $ makeLiftPair (return . fromContext) (fmap . const) diff --git a/src/Common/Derivation.hs b/src/Common/Derivation.hs new file mode 100644 --- /dev/null +++ b/src/Common/Derivation.hs @@ -0,0 +1,180 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Datatype for representing derivations as a tree. The datatype stores all +-- intermediate results as well as annotations for the steps. +-- +----------------------------------------------------------------------------- +module Common.Derivation + ( -- * Data types + DerivationTree, Derivations, Derivation + -- * Constructors + , singleNode, addBranch, addBranches + -- * Query + , root, endpoint, branches, annotations, subtrees + , results, lengthMax + -- * Adapters + , restrictHeight, restrictWidth, commit + , mergeSteps, cutOnStep + -- * Query a derivation + , isEmpty, derivationLength, terms, steps, filterDerivation + -- * Conversions + , derivation, derivations + ) where + +import Common.Utils (safeHead) +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe + +----------------------------------------------------------------------------- +-- Data type definitions for derivation trees and derivation lists + +data DerivationTree s a = DT + { root :: a -- ^ The root of the tree + , endpoint :: Bool -- ^ Is this node an endpoint? + , branches :: [(s, DerivationTree s a)] -- ^ All branches + } + deriving Show + +type Derivations s a = [Derivation s a] + +data Derivation s a = D a [(s, a)] + +instance (Show s, Show a) => Show (Derivation s a) where + show (D a xs) = unlines $ + show a : concatMap (\(r, b) -> [" => " ++ show r, show b]) xs + +instance Functor (DerivationTree s) where + fmap f (DT a b xs) = DT (f a) b (map (second (fmap f)) xs) + +instance Functor (Derivation s) where + fmap f (D a xs) = D (f a) (map (second f) xs) + +----------------------------------------------------------------------------- +-- Constructors for a derivation tree + +-- | Constructs a node without branches; the boolean indicates whether the +-- node is an endpoint or not +singleNode :: a -> Bool -> DerivationTree s a +singleNode a b = DT a b [] + +-- | Add a single branch +addBranch :: (s, DerivationTree s a) -> DerivationTree s a -> DerivationTree s a +addBranch = addBranches . return + +-- | Branches are attached after the existing ones (order matters) +addBranches :: [(s, DerivationTree s a)] -> DerivationTree s a -> DerivationTree s a +addBranches new (DT a b xs) = DT a b (xs ++ new) + +----------------------------------------------------------------------------- +-- Inspecting a derivation tree + +-- | Returns the annotations at a given node +annotations :: DerivationTree s a -> [s] +annotations = map fst . branches + +-- | Returns all subtrees at a given node +subtrees :: DerivationTree s a -> [DerivationTree s a] +subtrees = map snd . branches + +-- | Returns all final terms +results :: DerivationTree s a -> [a] +results = map f . derivations + where f (D a xs) = last (a:map snd xs) + +-- | The argument supplied is the maximum number of steps; if more steps are +-- needed, Nothing is returned +lengthMax :: Int -> DerivationTree s a -> Maybe Int +lengthMax n = join . fmap (f . derivationLength) . derivation + . commit . restrictHeight (n+1) + where + f i = if i<=n then Just i else Nothing + +----------------------------------------------------------------------------- +-- Changing a derivation tree + +-- | Restrict the height of the tree (by cutting off branches at a certain depth). +-- Nodes at this particular depth are turned into endpoints +restrictHeight :: Int -> DerivationTree s a -> DerivationTree s a +restrictHeight n t + | n == 0 = singleNode (root t) True + | otherwise = t {branches = map f (branches t)} + where + f = second (restrictHeight (n-1)) + +-- | Restrict the width of the tree (by cuttin off branches). +restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a +restrictWidth n = rec + where + rec t = t {branches = map (second rec) (take n (branches t))} + +-- | Commit to the left-most derivation (even if this path is unsuccessful) +commit :: DerivationTree s a -> DerivationTree s a +commit = restrictWidth 1 + +-- | Filter out intermediate steps, and merge its branches (and endpoints) with +-- the rest of the derivation tree +mergeSteps :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a +mergeSteps p = rec + where + rec t = addBranches (concat list) (singleNode (root t) isEnd) + where + new = map rec (subtrees t) + (bools, list) = unzip (zipWith f (annotations t) new) + isEnd = endpoint t || or bools + f s st + | p s = (False, [(s, st)]) + | otherwise = (endpoint st, branches st) + +cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a +cutOnStep p = rec + where + rec t = t {branches = map f (branches t)} + f (s, t) + | p s = (s, singleNode (root t) True) + | otherwise = (s, rec t) + +----------------------------------------------------------------------------- +-- Inspecting a derivation + +-- | Tests whether the derivation is empty +isEmpty :: Derivation s a -> Bool +isEmpty (D _ xs) = null xs + +-- | Returns the number of steps in a derivation +derivationLength :: Derivation s a -> Int +derivationLength (D _ xs) = length xs + +-- | All terms in a derivation +terms :: Derivation s a -> [a] +terms (D a xs) = a:map snd xs + +-- | All steps in a derivation +steps :: Derivation s a -> [s] +steps (D _ xs) = map fst xs + +-- | Filter steps from a derivation +filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a +filterDerivation p (D a xs) = D a (filter (uncurry p) xs) + +----------------------------------------------------------------------------- +-- Conversions from a derivation tree + +-- | All possible derivations (returned in a list) +derivations :: DerivationTree s a -> Derivations s a +derivations t = map (D (root t)) $ + [ [] | endpoint t ] ++ + [ ((r,a2):ys) | (r, st) <- branches t, D a2 ys <- derivations st ] + +-- | The first derivation (if any) +derivation :: DerivationTree s a -> Maybe (Derivation s a) +derivation = safeHead . derivations diff --git a/src/Common/Exercise.hs b/src/Common/Exercise.hs new file mode 100644 --- /dev/null +++ b/src/Common/Exercise.hs @@ -0,0 +1,286 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines the concept of an exercise +-- +----------------------------------------------------------------------------- +module Common.Exercise + ( -- * Exercises + Exercise, Status(..), testableExercise, makeExercise, emptyExercise + , description, exerciseCode, status, parser, prettyPrinter + , equivalence, similarity, isReady, isSuitable, strategy, extraRules + , difference, ordering, testGenerator, randomExercise, examples, getRule + , simpleGenerator, useGenerator + , randomTerm, randomTermWith, ruleset + -- * Exercise codes + , ExerciseCode, noCode, makeCode, readCode, domain, identifier + -- * Miscellaneous + , restrictGenerator + , showDerivation, printDerivation + , checkExercise, checkParserPretty + , checksForList + ) where + +import Common.Apply +import Common.Context +import Common.Strategy hiding (not, fail, replicate) +import Common.Derivation +import Common.Transformation +import Common.Utils +import Control.Monad.Error +import Data.Char +import Data.List +import System.Random +import Test.QuickCheck hiding (label, arguments) +import Text.Parsing (SyntaxError(..)) + +data Exercise a = Exercise + { -- identification and meta-information + description :: String -- short sentence describing the task + , exerciseCode :: ExerciseCode -- uniquely determines the exercise (in a given domain) + , status :: Status + -- parsing and pretty-printing + , parser :: String -> Either SyntaxError a + , prettyPrinter :: a -> String + -- syntactic and semantic checks + , equivalence :: a -> a -> Bool + , similarity :: a -> a -> Bool -- possibly more liberal than syntactic equality + , ordering :: a -> a -> Ordering -- syntactic comparison + , isReady :: a -> Bool + , isSuitable :: a -> Bool + -- strategies and rules + , strategy :: LabeledStrategy (Context a) + , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy + , difference :: Bool -> a -> a -> Maybe (a, a) + -- testing and exercise generation + , testGenerator :: Maybe (Gen a) + , randomExercise :: Maybe (StdGen -> Int -> a) + , examples :: [a] + } + +data Status = Stable | Provisional | Experimental deriving (Show, Eq) + +instance Eq (Exercise a) where + e1 == e2 = exerciseCode e1 == exerciseCode e2 + +instance Ord (Exercise a) where + e1 `compare` e2 = exerciseCode e1 `compare` exerciseCode e2 + +instance Apply Exercise where + applyAll e = map fromContext . applyAll (strategy e) . inContext + +testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a +testableExercise = makeExercise + { testGenerator = Just arbitrary + } + +makeExercise :: (Show a, Ord a) => Exercise a +makeExercise = emptyExercise + { prettyPrinter = show + , similarity = (==) + , ordering = compare + } + +emptyExercise :: Exercise a +emptyExercise = Exercise + { -- identification and meta-information + description = "<>" + , exerciseCode = noCode + , status = Experimental + -- parsing and pretty-printing + , parser = const $ Left $ ErrorMessage "<>" + , prettyPrinter = const "<>" + -- syntactic and semantic checks + , equivalence = \_ _ -> True + , similarity = \_ _ -> True + , ordering = \_ _ -> EQ + , isReady = const True + , isSuitable = const True + -- strategies and rules + , strategy = label "Succeed" succeed + , extraRules = [] + , difference = \_ _ _ -> Nothing + -- testing and exercise generation + , testGenerator = Nothing + , randomExercise = Nothing + , examples = [] + } + +--------------------------------------------------------------- +-- Exercise generators + +-- returns a sorted list of rules (no duplicates) +ruleset :: Exercise a -> [Rule (Context a)] +ruleset ex = nub (sortBy cmp list) + where + list = rulesInStrategy (strategy ex) ++ extraRules ex + cmp a b = name a `compare` name b + +simpleGenerator :: Gen a -> Maybe (StdGen -> Int -> a) +simpleGenerator = useGenerator (const True) . const + +useGenerator :: (a -> Bool) -> (Int -> Gen a) -> Maybe (StdGen -> Int -> a) +useGenerator p g = Just f + where + f rng level + | p a = a + | otherwise = f (snd (next rng)) level + where + a = generate 100 rng (g level) + +restrictGenerator :: (a -> Bool) -> Gen a -> Gen a +restrictGenerator p g = do + a <- g + if p a then return a + else restrictGenerator p g + +randomTerm :: Int -> Exercise a -> IO a +randomTerm level ex = do + rng <- newStdGen + return (randomTermWith rng level ex) + +randomTermWith :: StdGen -> Int -> Exercise a -> a +randomTermWith rng level ex = + case randomExercise ex of + Just f -> f rng level + Nothing + | null xs -> error "randomTermWith: no generator" + | otherwise -> + xs !! fst (randomR (0, length xs - 1) rng) + where xs = examples ex + +--------------------------------------------------------------- +-- Exercise codes (unique identification) + +data ExerciseCode = EC String String | NoCode + deriving (Eq, Ord) + +instance Show ExerciseCode where + show (EC xs ys) = xs ++ "." ++ ys + show NoCode = "no code" + +noCode :: ExerciseCode +noCode = NoCode + +makeCode :: String -> String -> ExerciseCode +makeCode a b + | null a || null b || any invalidCodeChar (a++b) = + error $ "Invalid exercise code: " ++ show (EC a b) + | otherwise = + EC (map toLower a) (map toLower b) + +readCode :: String -> Maybe ExerciseCode +readCode xs = + case break invalidCodeChar xs of + (as, '.':bs) | all validCodeChar bs -> + return $ makeCode as bs + _ -> Nothing + +validCodeChar, invalidCodeChar :: Char -> Bool +validCodeChar c = isAlphaNum c || c `elem` "-_" +invalidCodeChar = not . validCodeChar + +domain :: ExerciseCode -> String +domain (EC s _) = s +domain _ = [] + +identifier :: ExerciseCode -> String +identifier (EC _ s) = s +identifier _ = [] + +--------------------------------------------------------------- +-- Rest + +getRule :: Monad m => Exercise a -> String -> m (Rule (Context a)) +getRule ex s = + case filter ((==s) . name) (ruleset ex) of + [hd] -> return hd + [] -> fail $ "Could not find ruleid " ++ s + _ -> fail $ "Ambiguous ruleid " ++ s + +showDerivation :: Exercise a -> a -> String +showDerivation ex = + let err = "<>" + f = show . fmap (Shown . prettyPrinter ex . fromContext) . filterDerivation (\r a -> isMajorRule r) + in maybe err f . derivation . fullDerivationTree (strategy ex) . inContext + +-- local helper datatype +data Shown = Shown String + +instance Show Shown where + show (Shown s) = s + +printDerivation :: Exercise a -> a -> IO () +printDerivation ex = putStrLn . showDerivation ex + +--------------------------------------------------------------- +-- Checks for an exercise + +checkExercise :: Show a => Exercise a -> IO () +checkExercise ex = + case testGenerator ex of + Nothing -> return () + Just gen -> do + putStrLn ("** " ++ show (exerciseCode ex)) + let check txt p = putLabel txt >> quickCheck p + check "parser/pretty printer" $ forAll gen $ + checkParserPretty (equivalence ex) (parser ex) (prettyPrinter ex) + + putStrLn "Soundness non-buggy rules" + forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> do + putLabel (" " ++ name r) + let eq f a b = fromContext a `f` fromContext b + checkRuleSmart (eq (equivalence ex)) r (liftM inContext gen) + + check "non-trivial terms" $ + forAll gen $ \x -> + let trivial = isReady ex x + rejected = not trivial + suitable = not trivial in + classify trivial "trivial" $ + classify rejected "rejected" $ + classify suitable "suitable" $ property True + check "soundness strategy/generator" $ + forAll gen $ + isReady ex . fromContext . applyD (strategy ex) . inContext + +-- check combination of parser and pretty-printer +checkParserPretty :: (a -> a -> Bool) -> (String -> Either b a) -> (a -> String) -> a -> Bool +checkParserPretty eq parser pretty p = + either (const False) (eq p) (parser (pretty p)) + +checksForList :: Exercise a -> IO () +checksForList ex + | status ex /= Experimental || null xs = return () + | otherwise = do + let err s = putStrLn $ "Error: " ++ s + putStrLn ("** " ++ show (exerciseCode ex)) + mapM_ (either err return . checksForTerm ex) xs + where xs = examples ex + +checksForTerm :: Monad m => Exercise a -> a -> m () +checksForTerm ex a = + let txt = prettyPrinter ex a in + case derivation (derivationTree (strategy ex) (inContext a)) of + Nothing -> fail $ "no derivation for " ++ txt + Just theDerivation -> do + unless (isReady ex (last as)) $ + fail $ "not solved: " ++ txt + case [ (x, y) | x <- as, y <- as, not (equivalence ex x y) ] of + (x, y):_ -> fail $ "not equivalent: " ++ prettyPrinter ex x ++ " and " + ++ prettyPrinter ex y + _ -> return () + case filter (not . checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex)) as of + hd:_ -> let s = prettyPrinter ex hd in + fail $ "parse error for " ++ s ++ ": parsed as " ++ + either show (prettyPrinter ex) (parser ex s) + _ -> return () + where + as = map fromContext (terms theDerivation) diff --git a/src/Common/Grammar.hs b/src/Common/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Common/Grammar.hs @@ -0,0 +1,366 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines a set of combinators for context-free grammars. These +-- grammars are the basis of the strategies. The fix-point combinator 'fix' +-- makes it context-free. The code is based on the RTS'08 paper +-- "Recognizing Strategies" +-- +----------------------------------------------------------------------------- +module Common.Grammar + ( -- * Abstract data type + Grammar + -- * Smart constructor functions + , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol + -- * Elementary operations + , empty, firsts, nonempty + -- * Membership and generated language + , member, language, languageBF + -- * Additional functions + , collectSymbols, join, withIndex + -- * QuickCheck properties + , checks + ) where + +import Common.Uniplate +import Control.Monad (liftM, liftM2) +import Data.List +import Prelude hiding (fail) +import Test.QuickCheck +import qualified Data.Set as S + +---------------------------------------------------------------------- +-- Abstract data type + +data Grammar a = Grammar a :*: Grammar a + | Grammar a :|: Grammar a + | Grammar a :||: Grammar a + | Rec Int (Grammar a) + | Symbol a | Var Int | Succeed | Fail deriving Show + +infixr 3 :|:, <|> +infixr 4 :||:, <||> +infixr 5 :*:, <*> + +---------------------------------------------------------------------- +-- Smart constructor functions + +-- simple constructors +succeed, fail :: Grammar a +var :: Int -> Grammar a +symbol :: a -> Grammar a + +succeed = Succeed +fail = Fail +symbol = Symbol +var = Var + +-- | Smart constructor for sequences: removes fails and succeeds in the +-- operands +(<*>) :: Grammar a -> Grammar a -> Grammar a +Succeed <*> t = t +s <*> Succeed = s +Fail <*> _ = fail +_ <*> Fail = fail +(s :*: t) <*> u = s :*: (t <*> u) +s <*> t = s :*: t + +-- | Smart constructor for alternatives: removes fails in the operands, and +-- merges succeeds if present in both arguments +(<|>) :: Grammar a -> Grammar a -> Grammar a +Fail <|> t = t +s <|> Fail = s +(s :|: t) <|> u = s :|: (t <|> u) +Succeed <|> Succeed = Succeed +s <|> t = s :|: t + +-- | Smart constructor for parallel execution: removes fails and succeeds in the operands +(<||>) :: Grammar a -> Grammar a -> Grammar a +Succeed <||> t = t +s <||> Succeed = s +Fail <||> _ = fail +_ <||> Fail = fail +(s :||: t) <||> u = s :||: (t <||> u) +s <||> t = s :||: t + +-- | For constructing a recursive grammar +rec :: Int -> Grammar a -> Grammar a +rec i s = if i `S.member` freeVars s then Rec i s else s + + +-- | Fix-point combinator to model recursion. Be careful: this combinator is +-- VERY powerfull, and it is your own responsibility that the result +-- is a valid, non-left-recursive grammar +fix :: (Grammar a -> Grammar a) -> Grammar a +fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice + where + s = allVars (f Succeed) + i = if S.null s then 0 else S.findMax s + 1 + +-- | Zero or more occurrences +many :: Grammar a -> Grammar a +many s = rec 0 (succeed <|> (nonempty s <*> var 0)) +{- TODO: deal with free variables? +many s = rec i (succeed <|> (nonempty s <*> var i)) + where + vs = freeVars s + i = if S.null vs then 0 else 1 + S.findMax vs -} + +---------------------------------------------------------------------- +-- Elementary operations + +-- | Tests whether the grammar accepts the empty string +empty :: Grammar a -> Bool +empty (s :*: t) = empty s && empty t +empty (s :|: t) = empty s || empty t +empty (s :||: t) = empty s && empty t +empty (Rec _ s) = empty s +empty Succeed = True +empty _ = False + +-- | Returns the firsts set of the grammar, where each symbol is +-- paired with the remaining grammar +firsts :: Grammar a -> [(a, Grammar a)] +firsts (s :*: t) = [ (a, s' <*> t) | (a, s') <- firsts s ] ++ + (if empty s then firsts t else []) +firsts (s :|: t) = firsts s ++ firsts t +firsts (s :||: t) = [ (a, s' <||> t ) | (a, s') <- firsts s ] ++ + [ (a, s <||> t' ) | (a, t') <- firsts t] +firsts (Rec i s) = firsts (replaceVar i (Rec i s) s) +firsts (Symbol a) = [(a, succeed)] +firsts _ = [] + +-- | Returns the grammar without the empty string alternative +nonempty :: Grammar a -> Grammar a +nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ] + +---------------------------------------------------------------------- +-- Membership and generated language + +-- | Checks whether a string is member of the grammar's language +member :: Eq a => [a] -> Grammar a -> Bool +member [] g = empty g +member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ] + +-- | Generates the language of the grammar (list can be infinite). The sentences are +-- returned sorted by length, thus in a breadth-first order. The integer that is passed +-- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination +language :: Int -> Grammar a -> [[a]] +language n = concat . take n . languageBF + +-- | Generates the language of a grammar in a breadth-first manner, which is made explicit +-- by the outermost list. Sentences are grouped by their length +languageBF :: Grammar a -> [[[a]]] +languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ] + where merge = map concat . transpose + +---------------------------------------------------------------------- +-- Additional functions + +-- | Collect all the symbols of the grammar +collectSymbols :: Grammar a -> [a] +collectSymbols (Symbol a) = [a] +collectSymbols g = compos [] (++) collectSymbols g + +-- | The (monadic) join +join :: Grammar (Grammar a) -> Grammar a +join = mapSymbol id + +-- | Label all symbols with an index (from left to right) +withIndex :: Grammar a -> Grammar (Int, a) +withIndex = snd . rec 0 + where + rec :: Int -> Grammar a -> (Int, Grammar (Int, a)) + rec n grammar = + case grammar of + p :*: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :*: b) + p :|: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :|: b) + p :||: q -> let (n1, a) = rec n p + (n2, b) = rec n1 q + in (n2, a :||: b) + Rec i s -> let (n1, a) = rec n s + in (n1, Rec i a) + Var i -> (n, Var i) + Symbol a -> (n+1, Symbol (n, a)) + Succeed -> (n, Succeed) + Fail -> (n, Fail) + +---------------------------------------------------------------------- +-- Local helper functions and instances + +instance Uniplate (Grammar a) where + uniplate (s :*: t) = ([s,t], \[a,b] -> a :*: b) + uniplate (s :|: t) = ([s,t], \[a,b] -> a :|: b) + uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b) + uniplate (Rec i s) = ([s] , \[a] -> Rec i a) + uniplate g = ([] , \[] -> g) + +instance Functor Grammar where + fmap f = mapSymbol (symbol . f) + +freeVars :: Grammar a -> S.Set Int +freeVars (Rec i s) = freeVars s S.\\ S.singleton i +freeVars (Var i) = S.singleton i +freeVars g = compos S.empty S.union freeVars g + +allVars :: Grammar a -> S.Set Int +allVars (Var i) = S.singleton i +allVars g = compos S.empty S.union allVars g + +replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a +replaceVar i new = rec + where + rec g = + case g of + Var j | i==j -> new + Rec j _ | i==j -> g + _ -> f $ map rec cs + where (cs, f) = uniplate g + +mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b +mapSymbol f (p :*: q) = mapSymbol f p <*> mapSymbol f q +mapSymbol f (p :|: q) = mapSymbol f p <|> mapSymbol f q +mapSymbol f (p :||: q) = mapSymbol f p <||> mapSymbol f q +mapSymbol f (Rec i p) = Rec i (mapSymbol f p) +mapSymbol _ (Var i) = Var i +mapSymbol f (Symbol a) = f a +mapSymbol _ Succeed = Succeed +mapSymbol _ Fail = Fail + +-------------------------------------------------------- +-- QuickCheck generator + +instance Arbitrary a => Arbitrary (Grammar a) where + arbitrary = sized (arbGrammar []) + coarbitrary grammar = + case grammar of + p :*: q -> variant 0 . coarbitrary p . coarbitrary q + p :|: q -> variant 1 . coarbitrary p . coarbitrary q + p :||: q -> variant 2 . coarbitrary p . coarbitrary q + Rec i p -> variant 3 . coarbitrary i . coarbitrary p + Var i -> variant 4 . coarbitrary i + Symbol a -> variant 5 . coarbitrary a + Succeed -> variant 6 + Fail -> variant 7 + +-- Use smart constructors here +arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a) +arbGrammar xs n + | n == 0 = oneof $ + liftM symbol arbitrary : + map return ([succeed, fail] ++ xs) + | otherwise = oneof + [ arbGrammar xs 0 + , liftM2 (<*>) rec rec + , liftM2 (<|>) rec rec + , liftM2 (<||>) rec rec + , liftM many rec +-- , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2))) +{- , do i <- oneof $ map return [1::Int ..5] + x <- arbGrammar (Var i:xs) (n `div` 2) + return $ Rec i x -} + ] + where + rec = arbGrammar xs (n `div` 2) + +-------------------------------------------------------- +-- QuickCheck properties + +propSymbols :: (Int -> Int) -> Grammar Int -> Bool +propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p) + +propIndexId :: Grammar Int -> Bool +propIndexId p = fmap snd (withIndex p) === p + +propIndexUnique :: Grammar Int -> Bool +propIndexUnique p = is == nub is + where is = map fst $ collectSymbols $ withIndex p + +propSound :: Grammar Int -> Property +propSound p = not (null xs) ==> all (`member` p) xs + where xs = take 20 $ language 10 p + +propEmpty :: Grammar Int -> Bool +propEmpty s = empty s == member [] s + +propNonEmpty :: Grammar Int -> Bool +propNonEmpty = not . member [] . nonempty + +propSplitSucceed :: Grammar Int -> Bool +propSplitSucceed p = p === if empty p then succeed <|> new else new + where new = nonempty p + +propFirsts :: Grammar Int -> Bool +propFirsts p = nonempty p === foldr op fail (firsts p) + where op (a, q) r = (symbol a <*> q) <|> r + +propJoin :: Grammar Int -> Bool +propJoin p = join (fmap symbol p) === p + +propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool +propMap f g p = fmap (f . g) p === fmap (f . g) p + +propRec :: Grammar Int -> Property +propRec this@(Rec i p) = property (replaceVar i this p === this) +propRec _ = False ==> True + +propSucceed :: Grammar Int -> Bool +propSucceed p = empty p == member [] p + +infixl 1 === + +(===) :: Grammar Int -> Grammar Int -> Bool +p === q = all (`member` p) ys && all (`member` q) xs + where + xs = take 20 $ language 10 p + ys = take 20 $ language 10 q + +associative op p q r = p `op` (q `op` r) === (p `op` q) `op` r +commutative op p q = p `op` q === q `op` p +idempotent op p = p `op` p === p +leftUnit op e p = e `op` p === p +rightUnit op e p = p `op` e === p +unit op e p = leftUnit op e p && rightUnit op e p +absorbe op e p = (e `op` p === e) && (p `op` e === e) +propStar p = many p === succeed <|> (p <*> many p) +propStarStar p = many (many p) === many p + +checks :: IO () +checks = do + putStrLn "** Grammar combinators" + quickCheck propMap + quickCheck propJoin + quickCheck propSymbols + quickCheck propIndexId + quickCheck propIndexUnique + quickCheck propSound + quickCheck propEmpty + quickCheck propNonEmpty + quickCheck propSplitSucceed + quickCheck propFirsts + quickCheck propRec + quickCheck propStar + quickCheck propStarStar + quickCheck propSucceed + quickCheck $ associative (<|>) + quickCheck $ commutative (<|>) + quickCheck $ idempotent (<|>) + quickCheck $ unit (<|>) fail + quickCheck $ associative (<*>) + quickCheck $ unit (<*>) succeed + quickCheck $ absorbe (<*>) fail + quickCheck $ associative (<||>) + quickCheck $ commutative (<||>) + quickCheck $ unit (<||>) succeed + quickCheck $ absorbe (<||>) fail diff --git a/src/Common/Rewriting.hs b/src/Common/Rewriting.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting + ( module Common.Rewriting.AC + , module Common.Rewriting.Confluence + , module Common.Rewriting.MetaVar + , module Common.Rewriting.RewriteRule + , module Common.Rewriting.Substitution + , module Common.Rewriting.Difference + , module Common.Rewriting.Unification + ) where + +import Common.Rewriting.AC +import Common.Rewriting.Confluence +import Common.Rewriting.MetaVar +import Common.Rewriting.RewriteRule +import Common.Rewriting.Substitution +import Common.Rewriting.Difference +import Common.Rewriting.Unification diff --git a/src/Common/Rewriting/AC.hs b/src/Common/Rewriting/AC.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/AC.hs @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.AC + ( Operator, Operators, constructor, destructor + , newOperator, associativeOperator, commutativeOperator, acOperator + , makeAssociative, makeCommutative, isAssociative, isCommutative + , collectWithOperator, buildWithOperator + , isOperator, findOperator + , normalizeWith, equalWith + , pairings, pairingsMatch + ) where + +import Common.Uniplate +import Common.Utils +import Data.List +import Data.Maybe + +----------------------------------------------------------- +-- AC theories + +type Operators a = [Operator a] + +data Operator a = O + { constructor :: a -> a -> a + , destructor :: a -> Maybe (a, a) + , isAssociative :: Bool + , isCommutative :: Bool + } + +newOperator :: (a -> a -> a) -> (a -> Maybe (a, a)) -> Operator a +newOperator f g = O f g False False + +associativeOperator, commutativeOperator, acOperator :: (a -> a -> a) -> (a -> Maybe (a, a)) -> Operator a +associativeOperator f = makeAssociative . newOperator f +commutativeOperator f = makeCommutative . newOperator f +acOperator f = makeAssociative . commutativeOperator f + +makeCommutative, makeAssociative :: Operator a -> Operator a +makeCommutative op = op { isCommutative = True } +makeAssociative op = op { isAssociative = True } + +collectWithOperator :: Operator a -> a -> [a] +collectWithOperator op a + | isAssociative op = rec a [] + | otherwise = maybe [a] (\(x, y) -> [x, y]) (destructor op a) + where + rec a = case destructor op a of + Just (x, y) -> rec x . rec y + Nothing -> (a:) + +buildWithOperator :: Operator a -> [a] -> a +buildWithOperator op xs + | null xs = + error "Rewriting.buildWithOperator: empty list" + | not (isAssociative op) && length xs > 2 = + error "Rewriting.buildWithOperator: non-associative operator" + | otherwise = + foldr1 (constructor op) xs + +isOperator :: Operator a -> a -> Bool +isOperator op = isJust . destructor op + +findOperator :: Operators a -> a -> Maybe (Operator a) +findOperator ops a = safeHead $ filter (`isOperator` a) ops + +normalizeWith :: (Uniplate a, Ord a) => Operators a -> a -> a +normalizeWith ops = rec + where + rec a = + case findOperator ops a of + Just op -> + buildWithOperator op $ (if isCommutative op then sort else id) $ map rec $ collectWithOperator op a + Nothing -> + let (cs, f) = uniplate a + in f (map rec cs) + +equalWith :: (Uniplate a, Ord a) => Operators a -> a -> a -> Bool +equalWith ops x y = normalizeWith ops x == normalizeWith ops y + +----------------------------------------------------------- +-- Pairing terms with an AC theory +-- matchMode: the left-hand sides cannot have the operator at top-level + +pairings, pairingsMatch :: Operator a -> a -> a -> [[(a, a)]] +pairings = pairingsMode False +pairingsMatch = pairingsMode True + +pairingsMode :: Bool -> Operator a -> a -> a -> [[(a, a)]] +pairingsMode matchMode op = + case (isAssociative op, isCommutative op) of + (True , True ) -> pairingsAC matchMode op + (True , False) -> pairingsA matchMode op + (False, True ) -> pairingsC op + (False, False) -> pairingsNone op + +-- non-associative, non-commutative pairings +pairingsNone :: Operator a -> a -> a -> [[(a, a)]] +pairingsNone op a b = + case (destructor op a, destructor op b) of + (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)]] + _ -> [] + +-- commutative pairings +pairingsC :: Operator a -> a -> a -> [[(a, a)]] +pairingsC op a b = + case (destructor op a, destructor op b) of + (Just (a1, a2), Just (b1, b2)) -> [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]] + _ -> [] + +-- associative pairings +pairingsA :: Bool -> Operator a -> a -> a -> [[(a, a)]] +pairingsA matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b) + where + rec [] [] = [[]] + rec as bs = + [ (a1, b1):ps + | i <- if matchMode && not (null as) then [1] else [1 .. length as] + , j <- [1 .. length bs] + , i==1 || j==1 + , let (as1, as2) = splitAt i as + , let (bs1, bs2) = splitAt j bs + , let a1 = buildWithOperator op as1 + , let b1 = buildWithOperator op bs1 + , ps <- rec as2 bs2 + ] + +-- associative/commutative pairings +pairingsAC :: Bool -> Operator a -> a -> a -> [[(a, a)]] +pairingsAC matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b) + where + rec [] [] = [[]] + rec [] _ = [] + rec (a:as) bs = + [ (a1, b1):ps + | (asr, as2) <- if matchMode then [([], as)] else splits as + , let as1 = a:asr + , (bs1, bs2) <- splits bs + , not (null bs1) + , length as1==1 || length bs1==1 + , let a1 = buildWithOperator op as1 + , let b1 = buildWithOperator op bs1 + , ps <- rec as2 bs2 + ] + +{- +data Tree = Leaf String | Bin Tree Tree deriving (Show, Eq, Ord) + +opBin :: Operator Tree +opBin = Operator isBin Bin + where + isBin (Bin a b) = Just (a, b) + isBin _ = Nothing + +tree1 = Bin (Bin (Leaf "1") (Leaf "2")) (Bin (Leaf "3") (Leaf "4")) -- Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d")) +tree2 = Bin (Bin (Leaf "a") (Leaf "b")) (Bin (Leaf "c") (Leaf "d")) --Bin (Bin (Leaf "w") (Leaf "x")) (Bin (Leaf "y") (Leaf "z")) + +ex1 = pairingsC opBin tree1 tree2 +ex2 = pairingsA False opBin tree1 tree2 +ex3 = pairingsA True opBin tree1 tree2 +ex4 = pairingsAC False opBin tree1 tree2 +ex5 = pairingsAC True opBin tree1 tree2 -} + +splits :: [a] -> [([a], [a])] +splits = foldr insert [([], [])] + where + insert a ps = + let toLeft (xs, ys) = (a:xs, ys) + toRight (xs, ys) = ( xs, a:ys) + in map toLeft ps ++ map toRight ps + +{- +permutations :: [a] -> [[a]] +permutations = foldr (concatMap . insert) [[]] + where + insert a [] = [[a]] + insert a (x:xs) = (a:x:xs) : map (x:) (insert a xs) +-} diff --git a/src/Common/Rewriting/Confluence.hs b/src/Common/Rewriting/Confluence.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Confluence.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Confluence + ( isConfluent, confluence, confluenceWith, confluentFunction + , testConfluence, testConfluenceWith, testConfluentFunction + ) where + +import Common.Rewriting.AC +import Common.Rewriting.MetaVar +import Common.Rewriting.RewriteRule +import Common.Rewriting.Substitution +import Common.Rewriting.Unification +import Common.Uniplate (subtermsAt, applyAtM, somewhereM) +import Data.List +import Data.Maybe + + +---------------------------------------------------- + +superImpose :: Rewrite a => RewriteRule a -> RewriteRule a -> [([Int], a)] +superImpose r1 r2 = + [ (loc, s |-> lhs2) | (loc, a) <- subtermsAt lhs2, s <- make a ] + where + lhs1 = lhs (rulePair r1 0) + lhs2 = lhs (rulePair r2 (nrOfMetaVars r1)) + + make a + | isJust (isMetaVar a) = [] + | otherwise = unifyM lhs1 a + +criticalPairs :: (Rewrite a, Eq a) => [RewriteRule a] -> [(a, (RewriteRule a, a), (RewriteRule a, a))] +criticalPairs rs = + [ (a, (r1, b1), (r2, b2)) + | r1 <- rs + , r2 <- rs + , (loc, a) <- superImpose r1 r2 + , b1 <- rewriteM r1 a + , b2 <- applyAtM loc (rewriteM r2) a + , b1 /= b2 + ] + +noDiamondPairs :: (Rewrite a, Eq a) => (a -> a) -> [RewriteRule a] -> [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))] +noDiamondPairs f rs = + [ (a, (r1, e1, nf1), (r2, e2, nf2)) + | (a, (r1, e1), (r2, e2)) <- criticalPairs rs + , let (nf1, nf2) = (f e1, f e2) + , nf1 /= nf2 + ] + +reportPairs :: (Show a, Eq a) => [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))] -> IO () +reportPairs = putStrLn . unlines . zipWith f [1::Int ..] + where + f i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines + [ show i ++ ") " ++ show a + , " " ++ show r1 + , " " ++ show e1 ++ if e1==nf1 then "" else " --> " ++ show nf1 + , " " ++ show r2 + , " " ++ show e2 ++ if e2==nf2 then "" else " --> " ++ show nf2 + ] + +---------------------------------------------------- + +isConfluent :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> Bool +isConfluent f = null . noDiamondPairs f + +confluentFunction :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> IO () +confluentFunction f = reportPairs . noDiamondPairs f + +confluenceWith :: (Ord a, Show a, Rewrite a) => [Operator a] -> [RewriteRule a] -> IO () +confluenceWith ops rs = confluentFunction (normalizeWith ops . normalFormWith ops rs) rs + +confluence :: (Ord a, Show a, Rewrite a) => [RewriteRule a] -> IO () +confluence = confluenceWith operators + +---------------------------------------------------- + +testConfluentFunction :: (Eq a, Rewrite a) => (a -> a) -> [RewriteRule a] -> a -> Bool +testConfluentFunction f rs a = + case nub [ f b | r <- rs, b <- somewhereM (rewriteM r) a ] of + _:_:_ -> False + _ -> True + +testConfluenceWith :: (Ord a, Rewrite a) => [Operator a] -> [RewriteRule a] -> a -> Bool +testConfluenceWith ops rs = testConfluentFunction (normalFormWith ops rs) rs + +testConfluence :: (Ord a, Rewrite a) => [RewriteRule a] -> a -> Bool +testConfluence = testConfluenceWith operators diff --git a/src/Common/Rewriting/Difference.hs b/src/Common/Rewriting/Difference.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Difference.hs @@ -0,0 +1,74 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Compute the difference of two terms generically, taking associativity +-- into account. +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Difference + ( difference, differenceEqual, differenceMode + ) where + +import Common.Rewriting.AC +import Common.Rewriting.Unification +import Control.Monad +import Common.Uniplate +import Data.Maybe + +differenceMode :: Rewrite a => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a) +differenceMode eq b = + if b then differenceEqual eq else difference + +-- | This function returns the difference, except that the +-- returned terms should be logically equivalent. Nothing can signal that +-- there is no difference, or that the terms to start with are not equivalent. +differenceEqual :: Rewrite a => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +differenceEqual eq p q = do + guard (eq p q) + diff eq p q + +difference :: Rewrite a => a -> a -> Maybe (a, a) +difference = diff (\_ _ -> True) + +-- local implementation function +diff :: Rewrite a => (a -> a -> Bool) -> a -> a -> Maybe (a, a) +diff eq p q + | shallowEq p q = + case findOperator operators p of + Just op | isAssociative op && not (isCommutative op) -> + let ps = collectWithOperator op p + qs = collectWithOperator op q + in diffA eq op ps qs + _ -> diffList eq (children p) (children q) + | otherwise = Just (p, q) + +diffList :: Rewrite a => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a) +diffList eq xs ys + | length xs /= length ys = Nothing + | otherwise = + case catMaybes (zipWith (diff eq) xs ys) of + [p] -> Just p + _ -> Nothing + +diffA :: Rewrite a => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a) +diffA eq op = curry (make . uncurry rev . f . uncurry rev . f) + where + f (p:ps, q:qs) | not (null ps || null qs) && + isNothing (diff eq p q) && + (equal ps qs) = + f (ps, qs) + f pair = pair + + equal ps qs = buildWithOperator op ps `eq` buildWithOperator op qs + rev ps qs = (reverse ps, reverse qs) + make pair = + case pair of + ([p], [q]) -> diff eq p q + (ps, qs) -> Just (buildWithOperator op ps, buildWithOperator op qs) diff --git a/src/Common/Rewriting/MetaVar.hs b/src/Common/Rewriting/MetaVar.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/MetaVar.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.MetaVar where + +import Common.Uniplate +import Common.Utils (readInt) +import Data.Char (ord, isDigit) +import Data.List +import qualified Data.IntSet as IS + + +----------------------------------------------------------- +--- Meta variables + +-- | Type class for creating meta-variables +class MetaVar a where + metaVar :: Int -> a + isMetaVar :: a -> Maybe Int + +instance MetaVar String where + isMetaVar ('_':xs) = readInt xs + isMetaVar _ = Nothing + metaVar n = '_' : show n + +-- | Produces an infinite list of meta-variables +metaVars :: MetaVar a => [a] +metaVars = map metaVar [0..] + +-- | Collect all meta-variables +getMetaVars :: (MetaVar a, Uniplate a) => a -> IS.IntSet +getMetaVars a = getMetaVarsList [a] + +-- | Collect all meta-variables in the list +getMetaVarsList :: (MetaVar a, Uniplate a) => [a] -> IS.IntSet +getMetaVarsList xs = IS.fromList [ i | x <- xs, a <- universe x, Just i <- [isMetaVar a] ] + +-- | Checks whether the meta-variable is used in a term +hasMetaVar :: (MetaVar a, Uniplate a) => Int -> a -> Bool +hasMetaVar i = IS.member i . getMetaVars + +-- | Checks whether the meta-variable is used in one of the elements in the list +hasMetaVarList :: (MetaVar a, Uniplate a) => Int -> [a] -> Bool +hasMetaVarList i = IS.member i . getMetaVarsList + +-- | Checks whether a value has no variables +noMetaVars :: (Uniplate a, MetaVar a) => a -> Bool +noMetaVars = IS.null . getMetaVars + +-- | Determine what the next unused meta-varable is +nextMetaVar :: (Uniplate a, MetaVar a) => a -> Int +nextMetaVar a = nextMetaVarOfList [a] + +-- | Determine what the next meta-variable is that is not used in +-- an element of the list +nextMetaVarOfList :: (Uniplate a, MetaVar a) => [a] -> Int +nextMetaVarOfList xs + | IS.null s = 0 + | otherwise = 1 + IS.findMax s + where + s = getMetaVarsList xs + +-- | Rename the meta-variables +renameMetaVars :: (MetaVar a, Uniplate a) => (Int -> Int) -> a -> a +renameMetaVars f a = + case isMetaVar a of + Just i -> metaVar (f i) + Nothing -> g $ map (renameMetaVars f) cs + where + (cs, g) = uniplate a diff --git a/src/Common/Rewriting/RewriteRule.hs b/src/Common/Rewriting/RewriteRule.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/RewriteRule.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.RewriteRule + ( RuleSpec(..), lhs, rhs + , RewriteRule, Builder, rewriteRule, BuilderList, rewriteRules + , ruleName, nrOfMetaVars, rulePair + , inverse, bothWays, checkScope + , rewrite, rewriteM, rewriteWith + , normalForm, normalFormWith + , smartGenerator, showRewriteRule, showRuleSpec + ) where + +import Common.Apply +import Common.Rewriting.AC +import Common.Rewriting.MetaVar +import Common.Rewriting.Substitution +import Common.Rewriting.Unification +import Common.Uniplate (transform) +import Common.Utils +import Control.Monad +import Data.List +import Data.Maybe +import Test.QuickCheck +import qualified Data.IntSet as IS + +----------------------------------------------------------- +-- Rewrite rules + +infixl 1 :~> + +data RuleSpec a = a :~> a + deriving Show + +lhs, rhs :: RuleSpec a -> a +lhs (x :~> _) = x +rhs (_ :~> y) = y + +data RewriteRule a = Rewrite a => R { ruleName :: String, nrOfMetaVars :: Int, rulePair :: Int -> RuleSpec a } + +instance Show (RewriteRule a) where + show r = "[" ++ ruleName r ++ "]" + +instance Eq (RewriteRule a) where + r1 == r2 = ruleName r1 == ruleName r2 + +class Rewrite a => Builder t a | t -> a where + buildSpec :: t -> Int -> RuleSpec a + countVars :: t -> Int + +instance Rewrite a => Builder (RewriteRule a) a where + buildSpec = rulePair + countVars = nrOfMetaVars + +instance Rewrite a => Builder (RuleSpec a) a where + buildSpec rp _ = rp + countVars _ = 0 + +instance (Rewrite a, Builder b a) => Builder (a -> b) a where + buildSpec f i = buildSpec (f (metaVar i)) (i+1) + countVars f = countVars (f $ error "countVars") + 1 + +class Rewrite a => BuilderList t a | t -> a where + getSpecNr :: t -> Int -> Int -> RuleSpec a + countSpecsL :: t -> Int + countVarsL :: t -> Int + +instance Rewrite a => BuilderList (RewriteRule a) a where + getSpecNr r n = if n==0 then rulePair r else error "getSpecNr" + countSpecsL _ = 1 + countVarsL = nrOfMetaVars + +instance Rewrite a => BuilderList [RuleSpec a] a where + getSpecNr rs = buildSpec . (rs !!) + countSpecsL = length + countVarsL _ = 0 + +instance BuilderList b a => BuilderList (a -> b) a where + getSpecNr f n i = getSpecNr (f (metaVar i)) n (i+1) + countSpecsL f = countSpecsL (f $ error "countSpecsL") + countVarsL f = countVarsL (f $ error "countSpecsL") + 1 + +rewriteRule :: Builder f a => String -> f -> RewriteRule a +rewriteRule s f = R s (countVars f) (buildSpec f) + +rewriteRules :: BuilderList f a => String -> f -> [RewriteRule a] +rewriteRules s f = map (R s (countVarsL f) . getSpecNr f) [0 .. countSpecsL f-1] + +inverse :: RewriteRule a -> Maybe (RewriteRule a) +inverse r@(R _ _ _) = if checkScope new then Just new else Nothing + where + swap (x :~> y) = y :~> x + new = R (ruleName r) (nrOfMetaVars r) (swap . rulePair r) + +bothWays :: Rewrite a => [RewriteRule a] -> [RewriteRule a] +bothWays rs = rs ++ mapMaybe inverse rs + +checkScope :: Rewrite a => RewriteRule a -> Bool +checkScope r = IS.null (getMetaVars rhs IS.\\ getMetaVars lhs) + where lhs :~> rhs = rulePair r 0 + +----------------------------------------------------------- +-- Applying rewrite rules + +instance Apply RewriteRule where + applyAll = rewriteM + +rewrite :: RewriteRule a -> a -> [a] +rewrite r@(R _ _ _) = rewriteWith operators r + +rewriteM :: MonadPlus m => RewriteRule a -> a -> m a +rewriteM r@(R _ _ _) = msum . map return . rewriteWith operators r + +rewriteWith :: Operators a -> RewriteRule a -> a -> [a] +rewriteWith ops r0@(R _ _ _) e = do + r <- extendContext ops r0 + let lhs :~> rhs = rulePair r (nextMetaVar e) + s <- matchWith ops lhs e + return (s |-> rhs) + +-- Bug fix 4/3/2009: for associative operators, we need to extend rewrite +-- rules to take "contexts" into account. In addition to a left and a right +-- context, we also should consider a context on both sides. If not, we +-- might miss some locations, as pointed out by Josje's bug report. +extendContext :: Operators a -> RewriteRule a -> [RewriteRule a] +extendContext ops r = + case findOperator ops (lhs $ rulePair r 0) of + Just op | isAssociative op -> + [r, extend (leftContext op) r, extend (rightContext op) r + , extend (rightContext op) (extend (leftContext op) r) ] + _ -> [r] + where + leftContext op a (x :~> y) = + constructor op a x :~> constructor op a y + + rightContext op a (x :~> y) = + constructor op x a :~> constructor op y a + +extend :: (a -> RuleSpec a -> RuleSpec a) -> RewriteRule a -> RewriteRule a +extend f (R s n g) = R s (n+1) (\i -> f (metaVar (i+n)) (g i)) + +----------------------------------------------------------- +-- Normal forms + +normalFormWith :: (Rewrite a, Ord a) => [Operator a] -> [RewriteRule a] -> a -> a +normalFormWith ops rs = fixpoint $ transform $ \a -> + case [ b | r <- rs, b <- rewriteWith ops r a ] of + hd:_ -> normalizeWith ops hd + _ -> a + +normalForm :: (Rewrite a, Ord a) => [RewriteRule a] -> a -> a +normalForm = normalFormWith operators + +----------------------------------------------------------- +-- Smart generator that creates instantiations of the left-hand side + +smartGenerator :: RewriteRule a -> Gen a +smartGenerator r@(R _ _ _) = do + let a :~> _ = rulePair r 0 + let vs = getMetaVars a + list <- vector (IS.size vs) + let sub = listToSubst $ zip (IS.toList vs) list + return (sub |-> a) + +----------------------------------------------------------- +-- Showing a rewrite-rule + +showRewriteRule :: Bool -> RewriteRule a -> String +showRewriteRule sound r@(R _ _ _) = ruleName r ++ ": " ++ showRuleSpec sound r + +showRuleSpec :: Bool -> RewriteRule a -> String +showRuleSpec sound r@(R _ _ _) = show lhs ++ " " ++ leadsto ++ " " ++ show rhs + where + leadsto = if sound then ":~>" else ":/~>" + lhs :~> rhs = rulePair r 0 diff --git a/src/Common/Rewriting/Substitution.hs b/src/Common/Rewriting/Substitution.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Substitution.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Substitution + ( Substitution, emptySubst, singletonSubst, listToSubst, (@@), (@@@) + , lookupVar, dom, removeDom, ran, (|->) + ) where + +import Common.Uniplate +import Common.Rewriting.MetaVar +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.List +import Data.Maybe + +----------------------------------------------------------- +--- Substitution + + +-- | Abstract data type for substitutions +newtype Substitution a = S { unS :: IM.IntMap a } + +invariant :: (Uniplate a, MetaVar a) => Substitution a -> Bool +invariant s = IS.null (dom s `IS.intersection` getMetaVarsList (ran s)) + +makeS :: (Uniplate a, MetaVar a) => IM.IntMap a -> Substitution a +makeS m | invariant new = new + | otherwise = error "Rewriting.Substitution: invariant was violated" + where + new = S m + +infixr 4 |-> +infixr 5 @@, @@@ + +instance Show a => Show (Substitution a) where + show = show . unS + +-- | Returns the empty substitution +emptySubst :: (Uniplate a, MetaVar a) => Substitution a +emptySubst = makeS IM.empty + +-- | Returns a singleton substitution +singletonSubst :: (MetaVar a, Uniplate a) => Int -> a -> Substitution a +singletonSubst i a + | isMetaVar a == Just i = emptySubst + | otherwise = makeS (IM.singleton i a) + +-- | Turns a list into a substitution +listToSubst :: (Uniplate a, MetaVar a) => [(Int, a)] -> Substitution a +listToSubst = makeS . IM.fromListWith (error "Substitution: keys are not unique") + +-- | Combines two substitutions. The left-hand side substitution is first applied to +-- the co-domain of the right-hand side substitution +(@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a +S a @@ S b = makeS $ a `IM.union` IM.map (S a |->) b + +-- | Combines two substitutions with disjoint domains. If the domains are not disjoint, +-- an error is reported +(@@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a +S a @@@ S b = makeS (IM.unionWith err a b) + where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint" + +-- | Lookups a variable in a substitution. Nothing indicates that the variable is +-- not in the domain of the substitution +lookupVar :: Int -> Substitution a -> Maybe a +lookupVar s = IM.lookup s . unS + +-- | Returns the domain of a substitution (as a list) +dom :: Substitution a -> IS.IntSet +dom = IM.keysSet . unS + +-- | Removes variables from the domain of a substitution +removeDom :: IS.IntSet -> Substitution a -> Substitution a +removeDom s (S a) = S (IM.filterWithKey (\k _ -> IS.member k s) a) + +ran :: Substitution a -> [a] +ran = IM.elems . unS + +-- | Apply the substitution +(|->) :: (MetaVar a, Uniplate a) => Substitution a -> a -> a +s |-> e = + case isMetaVar e of + Just i -> fromMaybe e (lookupVar i s) + Nothing -> let (cs, f) = uniplate e + in f (map (s |->) cs) diff --git a/src/Common/Rewriting/Unification.hs b/src/Common/Rewriting/Unification.hs new file mode 100644 --- /dev/null +++ b/src/Common/Rewriting/Unification.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Rewriting.Unification + ( ShallowEq(..), Rewrite(..) + , unify, unifyM, unifyWith + , match, matchM, matchWith + ) where + +import Common.Rewriting.AC +import Common.Rewriting.MetaVar +import Common.Rewriting.Substitution +import Common.Uniplate +import Control.Monad +import Test.QuickCheck +import qualified Data.IntSet as IS + +----------------------------------------------------------- +-- Unification (in both ways) + +class ShallowEq a where + shallowEq :: a -> a -> Bool + +-- The arbitrary type class is a quick solution to have smart generators +-- (in combination with lifting rules). The function in the RewriteRule module +-- cannot have a type class for this reason +-- The show type class is added for pretty-printing rules +class (MetaVar a, Uniplate a, ShallowEq a, Arbitrary a, Show a) => Rewrite a where + operators :: [Operator a] + -- default definition: no associative/commutative operators + operators = [] + +unify :: Rewrite a => a -> a -> [Substitution a] +unify = unifyWith operators + +unifyM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a) +unifyM x y = msum $ map return $ unify x y + +unifyWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a] +unifyWith ops = rec + where + rec x y = + case (isMetaVar x, isMetaVar y) of + (Just i, Just j) | i==j -> return emptySubst + (Just i, _) | not (hasMetaVar i y) -> return $ singletonSubst i y + (_, Just j) | not (hasMetaVar j x) -> return $ singletonSubst j x + _ -> do + guard (shallowEq x y) + case findOperator ops x of + Just op -> + concatMap (uncurry recList . unzip) (pairings op x y) + Nothing -> + recList (children x) (children y) + + recList [] [] = return emptySubst + recList (x:xs) (y:ys) = do + s1 <- rec x y + s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) + return (s2 @@ s1) + recList _ _ = [] + +----------------------------------------------------------- +-- Matching (or: one-way unification) + +match :: Rewrite a => a -> a -> [Substitution a] +match = matchWith operators + +matchM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a) +matchM x y = msum $ map return $ match x y + +matchWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a] +matchWith ops x y = do + s <- rec x y + guard (IS.null $ dom s `IS.intersection` getMetaVars y) + return s + where + rec x y = + case isMetaVar x of + Just i | not (hasMetaVar i y) -> return $ singletonSubst i y + _ -> do + guard (shallowEq x y) + case findOperator ops x of + Just op -> + concatMap (uncurry recList . unzip) (pairingsMatch op x y) + Nothing -> + recList (children x) (children y) + + recList [] [] = return emptySubst + recList (x:xs) (y:ys) = do + s1 <- rec x y + s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys) + return (s2 @@ s1) + recList _ _ = [] diff --git a/src/Common/Strategy.hs b/src/Common/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/Common/Strategy.hs @@ -0,0 +1,399 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A strategy is a context-free grammar with rules as symbols. Strategies can be +-- labeled with strings. A type class is introduced to lift all the combinators +-- that work on strategies, only to prevent that you have to insert these lifting +-- functions yourself. +-- +----------------------------------------------------------------------------- +module Common.Strategy + ( -- * Data types and type classes + Strategy, LabeledStrategy, strategyName, unlabel + , IsStrategy(..) + -- * Running strategies + , fullDerivationTree, derivationTree + -- * Strategy combinators + -- ** Basic combinators + , (<*>), (<|>), (<||>), succeed, fail, label, sequence, alternatives + -- ** EBNF combinators + , many, many1, replicate, option + -- ** Negation and greedy combinators + , check, not, repeat, repeat1, try, (|>), exhaustive + -- ** Traversal combinators + , fix, once, somewhere, topDown, bottomUp + -- * Strategy locations + , StrategyLocation, StrategyOrRule, strategyLocations, subStrategy + , mapRules, rulesInStrategy, cleanUpStrategy + -- * Prefixes + , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) + , prefixToSteps, stepsToRules, lastStepInPrefix + ) where + +import Common.Apply +import Common.Context +import Common.Derivation +import Common.Rewriting hiding (inverse) +import Common.Transformation +import Common.Uniplate (Uniplate, children) +import Common.Utils +import Prelude hiding (fail, not, repeat, replicate, sequence) +import qualified Common.Grammar as RE +import qualified Prelude as Prelude + +----------------------------------------------------------- +-- Data types and type classes + +-- | Abstract data type for a strategy +newtype Strategy a = S { unS :: RE.Grammar (Either (Rule a) (LabeledStrategy a)) } + +-- | A strategy which is labeled with a string +data LabeledStrategy a = LS + { strategyName :: String -- ^ Returns the label of the strategy + , unlabel :: Strategy a -- ^ Removes the label from a strategy + } + +-- | Type class to turn values into strategies +class Apply f => IsStrategy f where + toStrategy :: f a -> Strategy a + +-- instances for Show +instance Show a => Show (Strategy a) where + show = show . unS + +instance Show a => Show (LabeledStrategy a) where + show s = + strategyName s ++ ": " ++ show (unlabel s) + +-- instances for Apply +instance Apply Strategy where + applyAll s = results . fullDerivationTree s + +instance Apply LabeledStrategy where + applyAll = applyAll . unlabel + +-- instances for IsStrategy +instance IsStrategy RewriteRule where + toStrategy r = + toStrategy (makeRule (ruleName r) (RewriteRule r)) + +instance IsStrategy Rule where + toStrategy = S . RE.symbol . Left + +instance IsStrategy Strategy where + toStrategy = id + +instance IsStrategy (LabeledStrategy) where + toStrategy = S . RE.symbol . Right + +-- instances for Lift +instance Lift Strategy where + lift lp (S re) = S (fmap (either (Left . lift lp) (Right . lift lp)) re) + +instance Lift (LabeledStrategy) where + lift lp (LS n s) = LS n (lift lp s) + +----------------------------------------------------------- +--- Running strategies + +-- | Returns the derivation tree for a strategy and a term, including all +-- minor rules +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a +fullDerivationTree = rec . noLabels . toStrategy + where + rec s a = addBranches (list s a) (singleNode a (RE.empty s)) + list s a = [ (f, rec rest b) + | (f, rest) <- RE.firsts s + , b <- applyAll f a + ] + +-- | Returns the derivation tree for a strategy and a term with only major rules +derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a +derivationTree s = mergeSteps isMajorRule . fullDerivationTree s + +noLabels :: Strategy a -> RE.Grammar (Rule a) +noLabels = RE.join . fmap (either RE.symbol (noLabels . unlabel)) . unS + +----------------------------------------------------------- +--- Strategy combinators + +-- Basic combinators -------------------------------------- + +infixr 3 <|> +infixr 4 <||> +infixr 5 <*> + +-- | Put two strategies in sequence (first do this, then do that) +(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +s <*> t = S (unS (toStrategy s) RE.<*> unS (toStrategy t)) + +-- | Choose between the two strategies (either do this or do that) +(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +s <|> t = S (unS (toStrategy s) RE.<|> unS (toStrategy t)) + +-- | Run two strategies in parallel (with interleaving) +(<||>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +s <||> t = S (unS (toStrategy s) RE.<||> unS (toStrategy t)) + +-- | The strategy that always succeeds (without doing anything) +succeed :: Strategy a +succeed = S RE.succeed + +-- | The strategy that always fails +fail :: Strategy a +fail = S RE.fail + +-- | Labels a strategy with a string +label :: IsStrategy f => String -> f a -> LabeledStrategy a +label l = LS l . toStrategy + +-- | Puts a list of strategies into a sequence +sequence :: IsStrategy f => [f a] -> Strategy a +sequence = foldr ((<*>) . toStrategy) succeed + +-- | Combines a list of alternative strategies +alternatives :: IsStrategy f => [f a] -> Strategy a +alternatives = foldr ((<|>) . toStrategy) fail + +-- EBNF combinators -------------------------------------- + +-- | Repeat a strategy zero or more times (non-greedy) +many :: IsStrategy f => f a -> Strategy a +many = S . RE.many . unS . toStrategy + +-- | Apply a certain strategy at least once (non-greedy) +many1 :: IsStrategy f => f a -> Strategy a +many1 s = s <*> many s + +-- | Apply a strategy a certain number of times +replicate :: IsStrategy f => Int -> f a -> Strategy a +replicate n = sequence . Prelude.replicate n + +-- | Apply a certain strategy or do nothing (non-greedy) +option :: IsStrategy f => f a -> Strategy a +option s = s <|> succeed + +-- Negation and greedy combinators ---------------------- + +infixr 4 |> + +-- | Checks whether a predicate holds for the current term. The +-- check is considered to be a minor step. +check :: (a -> Bool) -> Strategy a +check p = toStrategy checkRule + where + checkRule = minorRule $ makeSimpleRule "check" $ \a -> + if p a then Just a else Nothing + +-- | Check whether or not the argument strategy cannot be applied: the result +-- strategy only succeeds if this is not the case (otherwise it fails). +not :: IsStrategy f => f a -> Strategy a +not s = check (Prelude.not . applicable (toStrategy s)) + +{- alternative definition, with an early commit. No performance gain was +measurable + +applicableOne :: Strategy a -> a -> Bool +applicableOne s a = + let tree = derivationTree s a + in endpoint tree || Prelude.not (null (branches tree)) -} + +-- | Repeat a strategy zero or more times (greedy version of 'many') +repeat :: IsStrategy f => f a -> Strategy a +repeat s = many s <*> not s + +-- | Apply a certain strategy at least once (greedy version of 'many1') +repeat1 :: IsStrategy f => f a -> Strategy a +repeat1 s = many1 s <*> not s + +-- | Apply a certain strategy if this is possible (greedy version of 'option') +try :: IsStrategy f => f a -> Strategy a +try s = s <|> not s + +-- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, +-- try the right-operand strategy +(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +s |> t = s <|> (not s <*> t) + +-- | Apply the strategies from the list exhaustively (until this is no longer possible) +exhaustive :: IsStrategy f => [f a] -> Strategy a +exhaustive = repeat . alternatives + +-- Traversal combinators -------------------------------------------- + +-- | A fix-point combinator on strategies (to model recursion). Powerful +-- (but dangerous) combinator +fix :: (Strategy a -> Strategy a) -> Strategy a +fix f = S $ RE.fix $ unS . f . S + +-- | Apply a strategy on (exactly) one of the term's direct children +once :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) +once s = ruleMoveDown <*> s <*> ruleMoveUp + where + ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" moveDown + moveDown c = + let n = maybe 0 (pred . length . children) (currentFocus c) + in [ changeLocation (locationDown i) c | i <- [0 .. n] ] + + ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" moveUp + moveUp c = do + new <- locationUp (location c) + return $ setLocation new c + +-- | Apply a strategy somewhere in the term +somewhere :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) +somewhere s = fix $ \this -> s <|> once this + +-- | Search for a suitable location in the term to apply the strategy using a +-- top-down approach +topDown :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) +topDown s = fix $ \this -> s |> once this + +-- | Search for a suitable location in the term to apply the strategy using a +-- bottom-up approach +bottomUp :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a) +bottomUp s = fix $ \this -> once this <|> (not (once (bottomUp s)) <*> s) + +{- The ideal implementation does not yet work: there appears to be a strange + interplay between the fixpoint operator (with variables) and the not combinator + > bottomUp s = fix $ \this -> once this |> s -} + +----------------------------------------------------------- +--- Strategy locations + +-- | A strategy location corresponds to a substrategy or a rule +type StrategyLocation = [Int] + +type StrategyOrRule a = Either (LabeledStrategy a) (Rule a) + +-- | Returns a list of all strategy locations, paired with the labeled +-- substrategy or rule at that location +strategyLocations :: LabeledStrategy a -> [(StrategyLocation, Either (LabeledStrategy a) (Rule a))] +strategyLocations = rec [] + where + rec loc ns = + let f is = either (\r -> [ (is, Right r) | isMajorRule r ]) (rec is) + xs = RE.collectSymbols $ combine (,) loc $ unS $ unlabel ns + in (loc, Left ns) : concatMap (uncurry f) xs + +-- | Returns the substrategy or rule at a strategy location. Nothing indicates that the location is invalid +subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a) +subStrategy loc s = + case loc of + [] -> return (Left s) + n:ns -> + case lookup n . RE.collectSymbols . RE.withIndex . unS . unlabel $ s of + Just (Left r) | null ns -> return (Right r) + Just (Right t) -> subStrategy ns t + _ -> Nothing + +-- | Apply a function to all the rules that make up a labeled strategy +mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b +mapRules fun = f + where + f (LS n s) = LS n (g s) + g (S expr) = S (fmap h expr) + h (Left r) = Left (fun r) + h (Right ls) = Right (f ls) + +-- | Returns a list of all major rules that are part of a labeled strategy +rulesInStrategy :: LabeledStrategy a -> [Rule a] +rulesInStrategy s = [ r | (_, Right r) <- strategyLocations s ] + +-- local helper-function +combine :: ([Int] -> a -> b) -> [Int] -> RE.Grammar a -> RE.Grammar b +combine g is = fmap (\(i, a) -> g (is++[i]) a) . RE.withIndex + +-- | Use a function as do-after hook for all rules in a labeled strategy +cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a +cleanUpStrategy f s = mapRules g (label (strategyName s) (doAfter f idRule <*> unlabel s)) + where + g r | isMajorRule r = doAfter f r + | otherwise = r + +----------------------------------------------------------- +--- Prefixes + +-- | Abstract data type for a (labeled) strategy with a prefix (a sequence of +-- executed rules). A prefix is still "aware" of the labels that appear in the +-- strategy. A prefix is encoded as a list of integers (and can be reconstructed +-- from such a list: see @makePrefix@). The list is stored in reversed order. +data Prefix a = P [(Int, Step a)] (RE.Grammar (Step a)) + +instance Show (Prefix a) where + show (P xs _) = show (reverse (map fst xs)) + +instance Eq (Prefix a) where + P xs _ == P ys _ = map fst xs == map fst ys + +-- | Construct the empty prefix for a labeled strategy +emptyPrefix :: LabeledStrategy a -> Prefix a +emptyPrefix = makePrefix [] + +-- | Construct a prefix for a given list of integers and a labeled strategy. +makePrefix :: [Int] -> LabeledStrategy a -> Prefix a +makePrefix is ls = rec [] is start + where + start = withSteps ls + + rec acc [] g = P acc g + rec acc (n:ns) g = + case drop n (RE.firsts g) of + (z, h):_ -> rec ((n, z):acc) ns h + _ -> P [] start + +-- | The @Step@ data type can be used to inspect the structure of the strategy +data Step a = Begin StrategyLocation + | Step StrategyLocation (Rule a) + | End StrategyLocation + deriving (Show, Eq) + +instance Apply Step where + applyAll (Step _ r) = applyAll r + applyAll (Begin _) = return + applyAll (End _) = return + +instance Apply Prefix where + applyAll p = results . prefixTree p + +-- | Create a derivation tree with a "prefix" as annotation. +prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a +prefixTree (P xs g) a = + addBranches list (singleNode a (RE.empty g)) + where + add (i, (step, rest)) = P ((i, step):xs) rest + list = [ (newPrefix, prefixTree newPrefix b) + | triple@(_, (step, _)) <- zip [0..] (RE.firsts g) + , let newPrefix = add triple + , b <- applyAll step a + ] + +-- | Returns the steps that belong to the prefix +prefixToSteps :: Prefix a -> [Step a] +prefixToSteps (P xs _) = map snd (reverse xs) + +-- | Retrieves the rules from a list of steps +stepsToRules :: [Step a] -> [Rule a] +stepsToRules steps = [ r | Step _ r <- steps ] + +-- | Returns the last rule of a prefix (if such a rule exists) +lastStepInPrefix :: Prefix a -> Maybe (Step a) +lastStepInPrefix (P xs _) = safeHead (map snd xs) + +-- local helper function +withSteps :: LabeledStrategy a -> RE.Grammar (Step a) +withSteps = rec [] + where + rec is = mark is . RE.join . combine f is . unS . unlabel + f is = either (RE.symbol . Step is) (rec is) + mark is g = + let begin = RE.symbol (Begin is) + end = RE.symbol (End is) + in begin RE.<*> g RE.<*> end diff --git a/src/Common/Transformation.hs b/src/Common/Transformation.hs new file mode 100644 --- /dev/null +++ b/src/Common/Transformation.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines transformations. Given a term, a transformation returns a list of +-- results (often a singleton list or the empty list). A transformation can be parameterized +-- with one or more arguments. A rule is in essence just a transformation with a name (which +-- should be unique). Both transformations and rules can be lifted to work on more complex domains. +-- +----------------------------------------------------------------------------- +module Common.Transformation + ( -- * Transformations + Transformation(RewriteRule), makeTrans, makeTransList + , inverseTrans, getPatternPair + -- * Arguments + , ArgDescr(..), defaultArgDescr, Argument(..) + , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1 + , hasArguments, expectedArguments, getDescriptors, useArguments + -- * Rules + , Rule, name, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule + , ruleGroups, addRuleToGroup + , rule, ruleList, ruleListF + , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList + , idRule, emptyRule, minorRule, buggyRule, doBefore, doAfter + , transformations, getRewriteRules + -- * Lifting + , LiftPair, liftPairGet, liftPairSet, liftPairChange, makeLiftPair, Lift(..) + , ruleOnce, ruleOnce2, ruleMulti, ruleMulti2, ruleSomewhere + -- * QuickCheck + , checkRule, checkRuleSmart + ) where + +import Common.Apply +import Common.Rewriting +import Common.Traversable +import Common.Uniplate (Uniplate, somewhereM) +import Common.Utils +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import Data.Ratio +import Test.QuickCheck hiding (arguments) + + +----------------------------------------------------------- +--- Transformations + +-- | Abstract data type for representing transformations +data Transformation a + = Function String (a -> [a]) + | RewriteRule (RewriteRule a) + | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a) + | forall b . Lift (LiftPair b a) (Transformation b) + +instance Apply Transformation where + applyAll (Function _ f) = f + applyAll (RewriteRule r) = rewriteM r + applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a) + applyAll (Lift lp t ) = \b -> maybe [] (map (\new -> liftPairSet lp new b) . applyAll t) (liftPairGet lp b) + +-- | Turn a function (which returns its result in the Maybe monad) into a transformation +makeTrans :: String -> (a -> Maybe a) -> Transformation a +makeTrans s f = makeTransList s (maybe [] return . f) + +-- | Turn a function (which returns a list of results) into a transformation +makeTransList :: String -> (a -> [a]) -> Transformation a +makeTransList = Function + +-- | Return the inverse of a transformation. Only transformation that are constructed with (|-) +-- can be inversed +inverseTrans :: Transformation a -> Maybe (Transformation a) +inverseTrans trans = + case trans of + RewriteRule r -> fmap RewriteRule (inverse r) + Lift lp t -> fmap (Lift lp) (inverseTrans t) + _ -> Nothing + +getPatternPair :: a -> Transformation a -> Maybe (a, a) +getPatternPair _ (RewriteRule r) = let a :~> b = rulePair r 0 in Just (a, b) +getPatternPair a (Lift lp t) = do + let f t = liftPairSet lp t a + b <- liftPairGet lp a + (x, y) <- getPatternPair b t + return (f x, f y) +getPatternPair _ _ = Nothing + +----------------------------------------------------------- +--- Arguments + +-- | A data type for describing an argument of a parameterized transformation +data ArgDescr a = ArgDescr + { labelArgument :: String -- ^ Label that is shown to the user when asked to supply the argument + , defaultArgument :: Maybe a -- ^ Default value that can be used + , parseArgument :: String -> Maybe a -- ^ A parser + , showArgument :: a -> String -- ^ A pretty-printer + , genArgument :: Gen a -- ^ An arbitrary argument generator + } + +-- | Constructor function for an argument descriptor that uses the Show and Read type classes +defaultArgDescr :: (Show a, Read a, Arbitrary a) => String -> ArgDescr a +defaultArgDescr descr = ArgDescr descr Nothing parse show arbitrary + where + parse s = case reads s of + [(a, xs)] | all isSpace xs -> return a + _ -> Nothing + +-- | A type class for types which have an argument descriptor +class Arbitrary a => Argument a where + makeArgDescr :: String -> ArgDescr a -- ^ The first argument is the label of the argument descriptor + +instance Argument Int where + makeArgDescr = defaultArgDescr + +instance Argument Integer where + makeArgDescr = defaultArgDescr + +instance (Integral a, Arbitrary a) => Argument (Ratio a) where + makeArgDescr = ratioArgDescr + +-- | Parameterization with one argument using a default label +supply1 :: Argument x => + (a -> Maybe x) -> (x -> Transformation a) -> Transformation a +supply1 = supplyLabeled1 "argument 1" + +-- | Parameterization with two arguments using default labels +supply2 :: (Argument x, Argument y) => + (a -> Maybe (x, y)) -> (x -> y -> Transformation a) -> Transformation a +supply2 = supplyLabeled2 ("argument 1", "argument 2") + +-- | Parameterization with three arguments using default labels +supply3 :: (Argument x, Argument y, Argument z) => + (a -> Maybe (x, y, z)) -> (x -> y -> z -> Transformation a) -> Transformation a +supply3 = supplyLabeled3 ("argument 1", "argument 2", "argument 3") + +-- | Parameterization with one argument using the provided label +supplyLabeled1 :: Argument x + => String -> (a -> Maybe x) + -> (x -> Transformation a) -> Transformation a +supplyLabeled1 s f t = + let args = cons (makeArgDescr s) nil + nest a = (a, ()) + in Abstraction args (fmap nest . f) (\(a, ()) -> t a) + +supplyWith1 :: ArgDescr x -> (a -> Maybe x) + -> (x -> Transformation a) -> Transformation a +supplyWith1 descr f t = + let args = cons descr nil + nest a = (a, ()) + in Abstraction args (fmap nest . f) (\(a, ()) -> t a) + +-- | Parameterization with two arguments using the provided labels +supplyLabeled2 :: (Argument x, Argument y) + => (String, String) -> (a -> Maybe (x, y)) + -> (x -> y -> Transformation a) -> Transformation a +supplyLabeled2 (s1, s2) f t = + let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) nil) + nest (a, b) = (a, (b, ())) + in Abstraction args (fmap nest . f) (\(a, (b, ())) -> t a b) + +-- | Parameterization with three arguments using the provided labels +supplyLabeled3 :: (Argument x, Argument y, Argument z) + => (String, String, String) -> (a -> Maybe (x, y, z)) + -> (x -> y -> z -> Transformation a) -> Transformation a +supplyLabeled3 (s1, s2, s3) f t = + let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) (cons (makeArgDescr s3) nil)) + nest (a, b, c) = (a, (b, (c, ()))) + in Abstraction args (fmap nest . f) (\(a, (b, (c, ()))) -> t a b c) + +-- | Checks whether a rule is parameterized +hasArguments :: Rule a -> Bool +hasArguments = not . null . getDescriptors + +-- | Returns a list of argument descriptors +getDescriptors :: Rule a -> [Some ArgDescr] +getDescriptors rule = + case transformations rule of + [Abstraction args _ _] -> someArguments args + [Lift _ t] -> getDescriptors $ rule + { transformations = [t] + , doBeforeHook = id + , doAfterHook = id + } + _ -> [] + +-- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments +expectedArguments :: Rule a -> a -> Maybe [String] +expectedArguments rule a = + case transformations rule of + [Abstraction args f _] -> + fmap (showArguments args) (f a) + [Lift lp t] -> do + b <- liftPairGet lp a + expectedArguments rule + { transformations = [t] + , doBeforeHook = id + , doAfterHook = id + } b + _ -> Nothing + +-- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are +-- invalid (not parsable), or that the wrong number of arguments was supplied +useArguments :: [String] -> Rule a -> Maybe (Rule a) +useArguments list rule = + case transformations rule of + [t] -> do new <- make t + return rule {transformations = [new]} + _ -> Nothing + where + make :: Transformation a -> Maybe (Transformation a) + make trans = + case trans of + Abstraction args _ g -> fmap g (parseArguments args list) + Lift lp t -> fmap (Lift lp) (make t) + _ -> Nothing + +----------------------------------------------------------- +--- Internal machinery for arguments + +data ArgumentList a + = Nil a + | forall b c . Cons ((b, c) -> a, a -> (b, c)) (ArgDescr b) (ArgumentList c) + +-- smart constructor +nil :: ArgumentList () +nil = Nil () + +-- smart constructor (provides the isomorphism proofs) +cons :: ArgDescr a -> ArgumentList b -> ArgumentList (a, b) +cons = Cons (id, id) + +showArguments :: ArgumentList a -> a -> [String] +showArguments (Nil _) _ = [] +showArguments (Cons (_, f) arg list) a = + let (b, c) = f a + in showArgument arg b : showArguments list c + +parseArguments :: ArgumentList a -> [String] -> Maybe a +parseArguments (Nil a) [] = Just a +parseArguments (Cons (f, _) arg list) (x:xs) = do + b <- parseArgument arg x + c <- parseArguments list xs + return $ f (b, c) +parseArguments _ _ = Nothing + +someArguments :: ArgumentList a -> [Some ArgDescr] +someArguments (Nil _) = [] +someArguments (Cons _ arg list) = Some arg : someArguments list + +ratioArgDescr :: (Integral a, Arbitrary a) => String -> ArgDescr (Ratio a) +ratioArgDescr descr = ArgDescr descr Nothing parseRatio showRatio arbitrary + where + showRatio r = show (numerator r) ++ if denominator r == 1 then "" else '/' : show (denominator r) + parseRatio s = + let readDivOp s = + case dropWhile isSpace s of + ('/':rest) -> return rest + [] -> return "1" + _ -> fail "no (/) operator" + in safeHead [ fromInteger x / fromInteger y + | (x, s1) <- reads s + , s2 <- readDivOp s1 + , (y, s3) <- reads s2 + , y /= 0 + , all isSpace s3 + ] + +----------------------------------------------------------- +--- Rules + +-- | Abstract data type for representing rules +data Rule a = Rule + { name :: String -- ^ Returns the name of the rule (should be unique) + , transformations :: [Transformation a] + , isBuggyRule :: Bool -- ^ Inspect whether or not the rule is buggy (unsound) + , isMinorRule :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system) + , ruleGroups :: [String] + , doBeforeHook :: a -> a -- ^ Hook to perform an action before the rule is fired + , doAfterHook :: a -> a -- ^ Hook to perform an action after the rule has been fired + } + +instance Show (Rule a) where + show = name + +instance Eq (Rule a) where + r1 == r2 = name r1 == name r2 + +instance Apply Rule where + applyAll r a = do + let b = doBeforeHook r a + t <- transformations r + c <- applyAll t b + return (doAfterHook r c) + +-- | Returns whether or not the rule is major (i.e., not minor) +isMajorRule :: Rule a -> Bool +isMajorRule = not . isMinorRule + +isRewriteRule :: Rule a -> Bool +isRewriteRule = all p . transformations + where + p :: Transformation a -> Bool + p (RewriteRule _) = True + p (Lift _ t) = p t + p _ = False + +addRuleToGroup :: String -> Rule a -> Rule a +addRuleToGroup group r = r { ruleGroups = group : ruleGroups r } + +ruleList :: Builder f a => String -> [f] -> Rule a +ruleList s = makeRuleList s . map (RewriteRule . rewriteRule s) + +ruleListF :: BuilderList f a => String -> f -> Rule a +ruleListF s = makeRuleList s . map RewriteRule . rewriteRules s + +rule :: Builder f a => String -> f -> Rule a +rule s = makeRule s . RewriteRule . rewriteRule s + +-- | Turn a transformation into a rule: the first argument is the rule's name +makeRule :: String -> Transformation a -> Rule a +makeRule n = makeRuleList n . return + +-- | Turn a list of transformations into a single rule: the first argument is the rule's name +makeRuleList :: String -> [Transformation a] -> Rule a +makeRuleList n ts = Rule n ts False False [] id id + +-- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name +makeSimpleRule :: String -> (a -> Maybe a) -> Rule a +makeSimpleRule n = makeRule n . makeTrans n + +-- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name +makeSimpleRuleList :: String -> (a -> [a]) -> Rule a +makeSimpleRuleList n = makeRule n . makeTransList n + +-- | A special (minor) rule that always returns the identity +idRule :: Rule a +idRule = minorRule $ makeSimpleRule "Identity" return + +-- | A special (minor) rule that is never applicable (i.e., this rule always fails) +emptyRule :: Rule a +emptyRule = minorRule $ makeSimpleRule "Empty" (const Nothing) + +-- | Mark the rule as minor (by default, rules are not minor) +minorRule :: Rule a -> Rule a +minorRule r = r {isMinorRule = True} + +-- | Mark the rule as buggy (by default, rules are supposed to be sound) +buggyRule :: Rule a -> Rule a +buggyRule r = r {isBuggyRule = True} + +-- | Perform the function before the rule has been fired +doBefore :: (a -> a) -> Rule a -> Rule a +doBefore f r = r { doBeforeHook = f } + +-- | Perform the function after the rule has been fired +doAfter :: (a -> a) -> Rule a -> Rule a +doAfter f r = r { doAfterHook = f } + +getRewriteRules :: Rule a -> [(Some RewriteRule, Bool)] +getRewriteRules r = concatMap f (transformations r) + where + f :: Transformation a -> [(Some RewriteRule, Bool)] + f trans = + case trans of + RewriteRule rr -> [(Some rr, not $ isBuggyRule r)] + Lift _ t -> f t + _ -> [] + +----------------------------------------------------------- +--- Lifting + +-- | A lift pair consists of two functions: the first to access a value in a context (this can fail, +-- hence the Maybe), the second to update the value in its context +data LiftPair a b = LiftPair + { liftPairGet :: b -> Maybe a -- ^ Returns the accessor function of a lift pair + , liftPairSet :: a -> b -> b -- ^ Returns the update function of a lift pair + } +-- | Update a value in a context +liftPairChange :: LiftPair a b -> (a -> Maybe a) -> b -> Maybe b +liftPairChange lp f b = do + a <- liftPairGet lp b + new <- f a + return (liftPairSet lp new b) + +-- | Constructor for a lift pair +makeLiftPair :: (b -> Maybe a) -> (a -> b -> b) -> LiftPair a b +makeLiftPair = LiftPair + +-- | A type class for functors that can be lifted with a lift pair +class Lift f where + lift :: LiftPair a b -> f a -> f b + +instance Lift Transformation where + lift = Lift + +instance Lift Rule where + lift lp r = r + { transformations = map (lift lp) (transformations r) + , doBeforeHook = liftFunction lp (doBeforeHook r) + , doAfterHook = liftFunction lp (doAfterHook r) + } + +liftFunction :: LiftPair a b -> (a -> a) -> b -> b +liftFunction lp f a = + case liftPairGet lp a of + Just b -> liftPairSet lp (f b) a + Nothing -> a + +-- | Lift a rule using the Once type class +ruleOnce :: Once f => Rule a -> Rule (f a) +ruleOnce r = makeSimpleRuleList (name r) $ onceM $ applyAll r + +-- | Apply a rule once (in two functors) +ruleOnce2 :: (Once f, Once g) => Rule a -> Rule (f (g a)) +ruleOnce2 = ruleOnce . ruleOnce + +-- | Apply at multiple locations, but at least once +ruleMulti :: (Switch f, Crush f) => Rule a -> Rule (f a) +ruleMulti r = makeSimpleRuleList (name r) $ multi $ applyAll r + +-- | Apply at multiple locations, but at least once (in two functors) +ruleMulti2 :: (Switch f, Crush f, Switch g, Crush g) => Rule a -> Rule (f (g a)) +ruleMulti2 = ruleMulti . ruleMulti + +multi :: (Switch f, Crush f) => (a -> [a]) -> f a -> [f a] +multi f a = + let g a = case f a of + [] -> [(False, a)] + xs -> zip (repeat True) xs + xs = switch (fmap g a) + p = any fst . crush + in map (fmap snd) (filter p xs) + +ruleSomewhere :: Uniplate a => Rule a -> Rule a +ruleSomewhere r = makeSimpleRuleList (name r) $ somewhereM $ applyAll r + +----------------------------------------------------------- +--- QuickCheck + +-- | Check the soundness of a rule: the equality function is passed explicitly +checkRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO () +checkRule eq rule = + quickCheck (propRule eq rule arbitrary) + +-- | Check the soundness of a rule and use a "smart generator" for this. The smart generator +-- behaves differently on transformations constructed with a (|-), and for these transformations, +-- the left-hand side patterns are used (meta variables are instantiated with random terms) +checkRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO () +checkRuleSmart eq rule gen = + quickCheck (propRule eq rule (smartGen rule gen)) + +propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property +propRule eq rule gen = + forAll gen $ \a -> + forAll (smartApplyRule rule a) $ \ma -> + isJust ma ==> (a `eq` fromJust ma) + +smartGen :: Rule a -> Gen a -> Gen a +smartGen r gen = frequency [(2, gen), (1, smart)] + where + smart = gen >>= \a -> + oneof (gen : mapMaybe (smartGenTrans a) (transformations r)) + +smartGenTrans :: a -> Transformation a -> Maybe (Gen a) +smartGenTrans a trans = + case trans of + RewriteRule r -> return (smartGenerator r) + Lift lp t -> do + b <- liftPairGet lp a + gen <- smartGenTrans b t + return $ liftM (\c -> liftPairSet lp c a) gen + _ -> Nothing + +smartApplyRule :: Rule a -> a -> Gen (Maybe a) +smartApplyRule r a = do + xss <- mapM (`smartApplyTrans` a) (transformations r) + case concat xss of + [] -> return Nothing + xs -> oneof $ map (return . Just) xs + +smartApplyTrans :: Transformation a -> a -> Gen [a] +smartApplyTrans trans a = + case trans of + Abstraction args _ g -> smartArgs args >>= \b -> smartApplyTrans (g b) a + _ -> return (applyAll trans a) + +smartArgs :: ArgumentList a -> Gen a +smartArgs (Nil a) = return a +smartArgs (Cons (f, _) descr xs) = liftM2 (curry f) (genArgument descr) (smartArgs xs) diff --git a/src/Common/Traversable.hs b/src/Common/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Common/Traversable.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Common.Traversable + ( Once(..), Switch(..), Crush(..), OnceJoin(..), useOnceJoin + ) where + +import Control.Monad.Identity +import qualified Data.IntMap as IM +import qualified Data.Map as M + +{- Examples: + +once (^2) [1..3] + ~> [[1,2,3],[1,4,3],[1,2,9]] + +onceM (\x -> [x+1, x^2]) [1..3] + ~> [[2,2,3],[1,2,3],[1,3,3],[1,4,3],[1,2,4],[1,2,9]] + +onceJoin (\x -> [x+1, x^2]) [1..3] + ~> [[2,1,2,3],[1,3,4,3],[1,2,4,9]] + +onceJoinM (\x -> [[x+1], [x^2, x^3]]) [1..3] + ~> [[2,2,3],[1,1,2,3],[1,3,3],[1,4,8,3],[1,2,4],[1,2,9,27]] +-} + +----------------------------------------------------------- +-- * Type class |Once| + +class Functor f => Once f where + -- | Apply a function once in a given structure + once :: (a -> a) -> f a -> [f a] + -- | Apply a monadic function once in a given structure + onceM :: MonadPlus m => (a -> m a) -> f a -> m (f a) + + -- default definition + once f = onceM (return . f) + +instance Once [] where + onceM = useOnceJoin + +instance Once Maybe where + onceM = useOnceJoin + +instance Once Identity where + onceM = useOnceJoin + +instance Eq a => Once (M.Map a) where + onceM f m = liftM M.fromAscList (onceM g (M.toList m)) + where g (a, b) = liftM (\c -> (a, c)) (f b) + +instance Once IM.IntMap where + onceM f m = liftM IM.fromAscList (onceM g (IM.toList m)) + where g (a, b) = liftM (\c -> (a, c)) (f b) + +useOnceJoin :: (OnceJoin f, MonadPlus m) => (a -> m a) -> f a -> m (f a) +useOnceJoin f = onceJoinM (liftM return . f) + +----------------------------------------------------------- +-- * Type class |Switch| + +class Functor f => Switch f where + switch :: Monad m => f (m a) -> m (f a) + +instance Switch [] where + switch = sequence + +instance Switch Maybe where + switch = maybe (return Nothing) (liftM Just) + +instance Switch Identity where + switch (Identity m) = liftM Identity m + +instance Eq a => Switch (M.Map a) where + switch m = do + let (ns, ms) = unzip (M.toList m) + as <- sequence ms + return $ M.fromAscList $ zip ns as + +instance Switch IM.IntMap where + switch m = do + let (ns, ms) = unzip (IM.toList m) + as <- sequence ms + return $ IM.fromAscList $ zip ns as + +----------------------------------------------------------- +-- * Type class |Crush| + +class Functor f => Crush f where + crush :: f a -> [a] + +instance Crush [] where + crush = id + +instance Crush Maybe where + crush = maybe [] return + +instance Crush Identity where + crush = return . runIdentity + +instance Crush (M.Map a) where + crush = M.elems + +instance Crush IM.IntMap where + crush = IM.elems + +----------------------------------------------------------- +-- * Type class |OnceJoin| + +class (Once f, Monad f) => OnceJoin f where + -- | Apply a function once in a given structure, join the result afterwards + onceJoin :: (a -> f a) -> f a -> [f a] + -- | Apply a monadic function once in a given structure, join the result afterwards + onceJoinM :: MonadPlus m => (a -> m (f a)) -> f a -> m (f a) + + -- default definition + onceJoin f = onceJoinM (return . f) + +instance OnceJoin [] where + onceJoinM _ [] = mzero + onceJoinM f (x:xs) = liftM (++xs) (f x) `mplus` liftM (x:) (onceJoinM f xs) + +instance OnceJoin Maybe where + onceJoinM = maybe mzero + +instance OnceJoin Identity where + onceJoinM f = f . runIdentity diff --git a/src/Common/Uniplate.hs b/src/Common/Uniplate.hs new file mode 100644 --- /dev/null +++ b/src/Common/Uniplate.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines the Uniplate type class, and some utility functions. It +-- should be replaced in future by the original Uniplate library. +-- +----------------------------------------------------------------------------- +module Common.Uniplate ( + -- * Uniplate type class and utility functions + Uniplate(..) + , universe, subtermsAt, children, child + , getTermAt, applyTo, applyToM, applyAt, applyAtM + , transform, transformM, transformTD, rewrite, rewriteM + , somewhere, somewhereM + , compos + ) where + +--------------------------------------------------------- +-- Uniplate class for generic traversals + +import Common.Utils (safeHead) +import Control.Monad + +-- | The Uniplate type class offers some light-weight functions for generic traversals. Only +-- a minimal set of operations are supported +class Uniplate a where + uniplate :: a -> ([a], [a] -> a) -- ^ Function for generic traversals + +-- | Returns all subterms +universe :: Uniplate a => a -> [a] +universe a = a : [ c | b <- children a, c <- universe b ] + +-- | Like universe, but also returns the location of the subterm +subtermsAt :: Uniplate a => a -> [([Int], a)] +subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ] + +-- | Returns all the immediate children of a term +children :: Uniplate a => a -> [a] +children = fst . uniplate + +-- | Selects one immediate child of a term. Nothing indicates that the child does not exist +child :: Uniplate a => Int -> a -> Maybe a +child n = safeHead . drop n . children + +-- | Selects a child based on a path. Nothing indicates that the path is invalid +getTermAt :: Uniplate a => [Int] -> a -> Maybe a +getTermAt is a = foldM (flip child) a is + +-- | Apply a function to one immediate child. +applyTo :: Uniplate a => Int -> (a -> a) -> a -> a +applyTo n f a = + let (as, build) = uniplate a + g i = if i==n then f else id + in build (zipWith g [0..] as) + +-- | Monadic variant of applyTo +applyToM :: (Monad m, Uniplate a) => Int -> (a -> m a) -> a -> m a +applyToM n f a = + let (as, build) = uniplate a + g (i, b) = if i==n then f b else return b + in liftM build $ mapM g (zip [0..] as) + +-- | Apply a function at a given position (based on a path). +applyAt :: Uniplate a => [Int] -> (a -> a) -> a -> a +applyAt is f = foldr applyTo f is + +-- | Monadic variant of applyAt +applyAtM :: (Monad m, Uniplate a) => [Int] -> (a -> m a) -> a -> m a +applyAtM is f = foldr applyToM f is + +-- | A bottom-up transformation +transform :: Uniplate a => (a -> a) -> a -> a +transform g a = g $ f $ map (transform g) cs + where + (cs, f) = uniplate a + +-- | Monadic variant of transform +transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a +transformM g a = mapM (transformM g) cs >>= (g . f) + where + (cs, f) = uniplate a + +-- | A top-down transformation +transformTD :: Uniplate a => (a -> a) -> a -> a +transformTD g a = + let (cs, f) = uniplate (g a) + in f (map (transformTD g) cs) + +-- | Applies the function at a position until this is no longer possible +rewrite :: Uniplate a => (a -> Maybe a) -> a -> a +rewrite f = transform g + where g x = maybe x (rewrite f) (f x) + +-- | Monadic variant of rewrite +rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a +rewriteM f = transformM g + where g x = f x >>= maybe (return x) (rewriteM f) + +somewhere :: Uniplate a => (a -> a) -> a -> [a] +somewhere f = somewhereM (return . f) + +somewhereM :: (MonadPlus m, Uniplate a) => (a -> m a) -> a -> m a +somewhereM f a = msum $ f a : map g [0..n-1] + where + n = length (children a) + g i = applyToM i (somewhereM f) a + +-- | The compos function +compos :: Uniplate b => a -> (a -> a -> a) -> (b -> a) -> b -> a +compos zero combine f = foldr (combine . f) zero . children diff --git a/src/Common/Utils.hs b/src/Common/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Common/Utils.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A collection of general utility functions +-- +----------------------------------------------------------------------------- +module Common.Utils where + +import Control.Monad +import Data.Char +import Data.List +import Data.Ratio +import System.Random +import Test.QuickCheck +import qualified Data.Map as M + +data Some f = forall a . Some (f a) + +thoroughCheck :: Testable a => a -> IO () +thoroughCheck = check $ defaultConfig {configMaxTest = 1000, configMaxFail = 5000} + +generateStd :: Gen a -> IO a +generateStd gen = do + stdgen <- newStdGen + return (generate 100 stdgen gen) + +readInt :: String -> Maybe Int +readInt xs + | null xs = Nothing + | any (not . isDigit) xs = Nothing + | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + +stringToHex :: String -> Maybe Int +stringToHex = foldl op (Just 0) + where + op (Just i) c = fmap (\j -> i*16 + j) (charToHex c) + op Nothing _ = Nothing + +charToHex :: Char -> Maybe Int +charToHex c + | isDigit c = return (ord c - 48) + | toUpper c `elem` ['A' .. 'F'] = return (ord (toUpper c) - 55) + | otherwise = Nothing + +subsets :: [a] -> [[a]] +subsets = foldr op [[]] + where op a list = list ++ map (a:) list + +isSubsetOf :: Eq a => [a] -> [a] -> Bool +isSubsetOf xs ys = all (`elem` ys) xs + +eqListBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool +eqListBy f = rec + where + rec (x:xs) (y:ys) = f x y && rec xs ys + rec [] [] = True + rec _ _ = False + +cartesian :: [a] -> [b] -> [(a, b)] +cartesian as bs = [ (a, b) | a <- as, b <- bs ] + +distinct :: Eq a => [a] -> Bool +distinct [] = True +distinct (x:xs) = all (/=x) xs && distinct xs + +safeHead :: [a] -> Maybe a +safeHead (x:_) = return x +safeHead _ = Nothing + +fixpoint :: Eq a => (a -> a) -> a -> a +fixpoint f = stop . iterate f + where + stop (x:xs) + | x == head xs = x + | otherwise = stop xs + +fixpointM :: (Monad m, Eq a) => (a -> m a) -> a -> m a +fixpointM f a = do + b <- f a + if a==b then return a else fixpointM f b + +splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) +splitAtElem c s = + case break (==c) s of + (xs, _:ys) -> Just (xs, ys) + _ -> Nothing + +splitsWithElem :: Eq a => a -> [a] -> [[a]] +splitsWithElem c s = + case splitAtElem c s of + Just (xs, ys) -> xs : splitsWithElem c ys + Nothing -> [s] + +{- safeIndex :: Int -> [a] -> Maybe a +safeIndex 0 (x:_) = return x +safeIndex n (_:xs) = safeIndex (n-1) xs +safeIndex _ _ = Nothing -} + +-- | Use a fixed standard "random" number generator. This generator is +-- accessible by calling System.Random.getStdGen +useFixedStdGen :: IO () +useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} + +trim :: String -> String +trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +isNatural :: String -> Bool +isNatural x = all isDigit x && not (null x) + +fst3 (x, _, _) = x +snd3 (_, x, _) = x +thd3 (_, _, x) = x + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +mapLeft :: (a -> b) -> Either a c -> Either b c +mapLeft f = either (Left . f) Right + +mapRight :: (b -> c) -> Either a b -> Either a c +mapRight f = either Left (Right . f) + +commaList :: [String] -> String +commaList = concat . intersperse ", " + +indent :: Int -> String -> String +indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines + +primes :: [Int] +primes = rec [2..] + where + rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) + +putLabel :: String -> IO () +putLabel = putStr . take 40 . (++ repeat ' ') + +reportTest :: String -> Bool -> IO () +reportTest s b = putLabel s >> putStrLn (if b then "OK" else "FAILED") + +instance Show (a -> b) where + show _ = "" + +instance Arbitrary Char where + arbitrary = let chars = ['a' .. 'z'] ++ ['A' .. 'Z'] + in oneof (map return chars) + coarbitrary = coarbitrary . ord + +instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where + arbitrary = liftM M.fromList arbitrary + coarbitrary = coarbitrary . M.toList + +-- Generating arbitrary random rational numbers +instance Integral a => Arbitrary (Ratio a) where + arbitrary = sized (\n -> ratioGen n (n `div` 4)) + coarbitrary r = f (numerator r) . f (denominator r) + where f = variant . fromIntegral + +-- | Prevents a bias towards small numbers +ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) +ratioGen n m = do + a <- choose (-n, n) + b <- liftM (succ . abs) (choose (-m, m)) + c <- choose (1-b, b-1) + return (fromIntegral a + (fromIntegral c / fromIntegral b)) diff --git a/src/Common/View.hs b/src/Common/View.hs new file mode 100644 --- /dev/null +++ b/src/Common/View.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- This module defines views on data-types +-- +----------------------------------------------------------------------------- +module Common.View + ( Match, View, makeView, Simplification, makeSimplification + , match, matchM, build, canonical, canonicalM, canonicalWith + , simplify, simplifyWith, isCanonical, isCanonicalWith + , belongsTo, viewEquivalent, viewEquivalentWith + , (>>>), Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..), identity + , listView, conversion, ( #> ) + , propIdempotence, propSoundness, propNormalForm + ) where + +import Control.Arrow hiding ((>>>)) +import Control.Monad +import Data.Maybe +import Test.QuickCheck +import qualified Control.Category as C + +-- For all v::View the following should hold: +-- 1) simplify v a "is equivalent to" a +-- 2) match (build b) equals Just b +-- (but only for b that have at least one "a") +-- +-- Derived property: simplification is idempotent + +type Match a b = a -> Maybe b + +data View a b = View + { match :: Match a b + , build :: b -> a + } + +type Simplification a = View a a + +matchM :: Monad m => View a b -> a -> m b +matchM v = maybe (Prelude.fail "no match") return . match v + +makeView :: (a -> Maybe b) -> (b -> a) -> View a b +makeView = View + +makeSimplification :: (a -> a) -> Simplification a +makeSimplification f = makeView (return . f) id + +canonical :: View a b -> a -> Maybe a +canonical = canonicalWith id + +canonicalM :: Monad m => View a b -> a -> m a +canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v + +canonicalWith :: (b -> b) -> View a b -> a -> Maybe a +canonicalWith f view = liftM (build view . f) . match view + +simplify :: View a b -> a -> a +simplify = simplifyWith id + +simplifyWith :: (b -> b) -> View a b -> a -> a +simplifyWith f view a = fromMaybe a (canonicalWith f view a) + +--------------------------------------------------------------- + +belongsTo :: a -> View a b -> Bool +belongsTo a view = isJust (match view a) + +viewEquivalent :: Eq b => View a b -> a -> a -> Bool +viewEquivalent = viewEquivalentWith (==) + +viewEquivalentWith :: (b -> b -> Bool) -> View a b -> a -> a -> Bool +viewEquivalentWith eq view x y = + case (match view x, match view y) of + (Just a, Just b) -> a `eq` b + _ -> False + +isCanonical :: Eq a => View a b -> a -> Bool +isCanonical = isCanonicalWith (==) + +isCanonicalWith :: (a -> a -> Bool) -> View a b -> a -> Bool +isCanonicalWith eq v a = maybe False (eq a) (canonical v a) + +--------------------------------------------------------------- +-- Arrow combinators + +identity :: View a a +identity = makeView Just id + +(>>>) :: View a b -> View b c -> View a c +v >>> w = makeView (\a -> match v a >>= match w) (build v . build w) + +instance C.Category View where + id = identity + v . w = w >>> v + +instance Arrow View where + arr f = makeView + (return . f) + (error "Control.View.arr: function is not invertible") + + first v = makeView + (\(a, c) -> match v a >>= \b -> return (b, c)) + (first (build v)) + + second v = makeView + (\(a, b) -> match v b >>= \c -> return (a, c)) + (second (build v)) + + v *** w = makeView + (\(a, c) -> liftM2 (,) (match v a) (match w c)) + (build v *** build w) + + -- left-biased builder + v &&& w = makeView + (\a -> liftM2 (,) (match v a) (match w a)) + (\(b, _) -> build v b) + +instance ArrowChoice View where + left v = makeView + (either (liftM Left . match v) (return . Right)) + (either (Left . build v) Right) + + right v = makeView + (either (return . Left) (liftM Right . match v)) + (either Left (Right . build v)) + + v +++ w = makeView + (either (liftM Left . match v) (liftM Right . match w)) + (either (Left . build v) (Right . build w)) + + -- left-biased builder + v ||| w = makeView + (either (match v) (match w)) + (Left . build v) + +--------------------------------------------------------------- +-- More combinators + +listView :: View a b -> View [a] [b] +listView v = makeView (mapM (match v)) (map (build v)) + +conversion :: (a -> b) -> (b -> a) -> View a b +conversion f g = makeView (Just . f) g + +( #> ) :: (a -> Bool) -> View a b -> View a b +p #> v = makeView f (build v) + where f a = guard (p a) >> match v a + +--------------------------------------------------------------- +-- Properties on views + +propIdempotence :: (Show a, Eq a) => Gen a -> View a b -> Property +propIdempotence g v = forAll g $ \a -> + let b = simplify v a + in b == simplify v b + +propSoundness :: Show a => (a -> a -> Bool) -> Gen a -> View a c -> Property +propSoundness semEq g v = forAll g $ \a -> + let b = simplify v a + in semEq a b + +propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property +propNormalForm g v = forAll g $ \a -> a == simplify v a diff --git a/src/Domain/LinearAlgebra.hs b/src/Domain/LinearAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra + ( module Domain.LinearAlgebra.Matrix + , module Domain.LinearAlgebra.Parser + , module Domain.LinearAlgebra.MatrixRules + , module Domain.LinearAlgebra.EquationsRules + , module Domain.LinearAlgebra.Strategies + , module Domain.LinearAlgebra.LinearSystem + , module Domain.LinearAlgebra.Exercises + , module Domain.LinearAlgebra.Symbols + ) where + +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.Parser +import Domain.LinearAlgebra.MatrixRules +import Domain.LinearAlgebra.EquationsRules hiding (changeCover) +import Domain.LinearAlgebra.Strategies +import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.Exercises +import Domain.LinearAlgebra.Symbols diff --git a/src/Domain/LinearAlgebra/Checks.hs b/src/Domain/LinearAlgebra/Checks.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Checks.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Checks (checks) where + +import Domain.Math.Simplification (simplify) +import Domain.LinearAlgebra hiding (getSolution) +import Test.QuickCheck +import Control.Monad +import Common.Utils +import Data.List +import Common.Apply +import Common.Context + +----------------------------------------------------------- +--- QuickCheck properties + +checks :: IO () +checks = do + putStrLn "** Linear algebra" + thoroughCheck propEchelon + thoroughCheck propReducedEchelon + thoroughCheck propSound + thoroughCheck propSolution + +propEchelon :: Matrix Rational -> Bool +propEchelon = + inRowEchelonForm . matrix . applyD forwardPass . inContext . fmap fromRational + +propReducedEchelon :: Matrix Rational -> Bool +propReducedEchelon = + inRowReducedEchelonForm . matrix . applyD gaussianElimStrategy . inContext . fmap fromRational + +propSound :: Matrix Rational -> Bool +propSound m = + (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m + == fmap fromRational (reduce m) + +propSolution :: Matrix Rational -> Property +propSolution m1 = + forAll (arbSolution m1) $ \(solution, m2) -> + let m3 = (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m2 + p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0 + g = (*) . fromRational + in all p (rows m3) + +arbSolution :: (Arbitrary a, Num a) => Matrix a -> Gen ([a], Matrix a) +arbSolution m = do + solution <- vector (snd $ dimensions m) + let finalCol = map (return . sum . zipWith (*) solution) (rows m) + newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol + return (solution, newMatrix) diff --git a/src/Domain/LinearAlgebra/EquationsRules.hs b/src/Domain/LinearAlgebra/EquationsRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/EquationsRules.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.EquationsRules where + +import Prelude hiding (repeat) +import Common.Context +import Common.Transformation +import Common.Utils +import Common.View hiding (simplify) +import Control.Monad +import Data.List hiding (repeat) +import Data.Maybe +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Domain.Math.Simplification (simplify) +import Domain.LinearAlgebra.LinearView +import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.MatrixRules (covered) -- for context +import Test.QuickCheck + +equationsRules :: [Rule (Context (LinearSystem Expr))] +equationsRules = + [ ruleExchangeEquations, ruleEliminateVar, ruleDropEquation + , ruleInconsistentSystem + , ruleScaleEquation, ruleBackSubstitution, ruleIdentifyFreeVariables + , ruleCoverUpEquation, ruleUncoverEquation, ruleCoverAllEquations + ] + +ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) +ruleExchangeEquations = simplifySystem $ makeRule "Exchange" $ + supplyLabeled2 descr args (\x y -> liftSystemTrans $ exchange x y) + where + descr = ("equation 1", "equation 2") + args c = do mv <- minvar c + i <- findIndex (elem mv . getVarsSystem . return) (remaining c) + return (get covered c, get covered c + i) + +ruleEliminateVar :: Rule (Context (LinearSystem Expr)) +ruleEliminateVar = simplifySystem $ makeRule "Eliminate variable" $ + supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z) + where + descr = ("equation 1", "equation 2", "scale factor") + args c = do + mv <- minvar c + let hd:rest = remaining c + getCoef = coefficientOf mv . getLHS + (i, coef) <- safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ] + guard (getCoef hd /= 0) + let v = negate coef / getCoef hd + return ( i + get covered c + 1, get covered c, v) + +ruleDropEquation :: Rule (Context (LinearSystem Expr)) +ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ + \c -> do i <- findIndex (fromMaybe False . testConstants (==)) (equations c) + return $ change covered (\n -> if i < n then n-1 else n) + $ fmap (deleteIndex i) c + +ruleInconsistentSystem :: Rule (Context (LinearSystem Expr)) +ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ + \c -> do let stop = [0 :==: 1] + guard $ invalidSystem (equations c) && equations c /= stop + return $ set covered 1 (fmap (const stop) c) + +ruleScaleEquation :: Rule (Context (LinearSystem Expr)) +ruleScaleEquation = simplifySystem $ makeRule "Scale equation to one" $ + supplyLabeled2 descr args (\x y -> liftSystemTrans $ scaleEquation x y) + where + descr = ("equation", "scale factor") + args c = do eq <- safeHead $ drop (get covered c) (equations c) + let expr = getLHS eq + mv <- minvar c + guard (coefficientOf mv expr /= 0) + let coef = 1 / coefficientOf mv expr + return (get covered c, coef) + +ruleBackSubstitution :: Rule (Context (LinearSystem Expr)) +ruleBackSubstitution = simplifySystem $ makeRule "Back substitution" $ + supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z) + where + descr = ("equation 1", "equation 2", "scale factor") + args c = do eq <- safeHead $ drop (get covered c) (equations c) + let expr = getLHS eq + mv <- safeHead (getVars expr) + i <- findIndex ((/= 0) . coefficientOf mv . getLHS) (take (get covered c) (equations c)) + let coef = negate $ coefficientOf mv (getLHS (equations c !! i)) + return (i, get covered c, coef) + +ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a)) +ruleIdentifyFreeVariables = minorRule $ makeSimpleRule "Identify free variables" $ + \c -> let vars = [ head ys | ys <- map (getVars . getLHS) (equations c), not (null ys) ] + change eq = + let (e1, e2) = splitLinearExpr (`notElem` vars) (getLHS eq) -- constant ends up in e1 + in e2 :==: getRHS eq - e1 + in return (fmap (map change) c) + +ruleCoverUpEquation :: Rule (Context (LinearSystem a)) +ruleCoverUpEquation = minorRule $ makeRule "Cover up first equation" $ changeCover (+1) + +ruleUncoverEquation :: Rule (Context (LinearSystem a)) +ruleUncoverEquation = minorRule $ makeRule "Uncover one equation" $ changeCover (\x -> x-1) + +ruleCoverAllEquations :: Rule (Context (LinearSystem a)) +ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ + \c -> return (set covered (length $ equations c) c) + +-- local helper functions +deleteIndex :: Int -> [a] -> [a] +deleteIndex i xs = ys ++ drop 1 zs + where (ys, zs) = splitAt i xs + +testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool +testConstants f (lhs :==: rhs) + | isConstant lhs && isConstant rhs = Just (f lhs rhs) + | otherwise = Nothing + +-- simplify a linear system +simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr)) +simplifySystem = doAfter $ fmap (map (fmap f)) + where f = simplifyWith (fmap simplify) linearView + +--------------------------------------------------------------------------------- +-- Parameterized transformations + +exchange :: Int -> Int -> Transformation [a] +exchange i j + | i > j = exchange j i + | otherwise = makeTrans "exchange" $ \xs -> do + guard (i/=j && validEquation i xs && validEquation j xs) + let (begin, x:rest) = splitAt i xs + (middle, y:end) = splitAt (j-i-1) rest + return $ begin++[y]++middle++[x]++end + +scaleEquation :: IsLinear a => Int -> a -> Transformation (LinearSystem a) +scaleEquation i a = makeTrans "scaleEquation" $ \xs -> do + guard (a `notElem` [0,1] && validEquation i xs) + let (begin, this:end) = splitAt i xs + return (begin ++ [fmap (a*) this] ++ end) + +addEquations :: IsLinear a => Int -> Int -> a -> Transformation (LinearSystem a) +addEquations i j a = makeTrans "addEquations" $ \xs -> do + guard (i/=j && validEquation i xs && validEquation j xs) + let (begin, this:end) = splitAt i xs + exprj = xs!!j + return $ begin++[combineWith (+) this (fmap (a*) exprj)]++end + +changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a)) +changeCover f = makeTrans "changeCover" $ \c -> do + let new = f (get covered c) + guard (new >= 0 && new <= length (equations c)) + return (set covered new c) + +-- local helper function +validEquation :: Int -> [a] -> Bool +validEquation n xs = n >= 0 && n < length xs + +-------------------- +-- TEMP + +equations :: Context (LinearSystem a) -> LinearSystem a +equations = fromContext + +-- | The equations that remain to be solved +remaining :: Context (LinearSystem a) -> Equations a +remaining c = drop (get covered c) (equations c) + +-- | The minimal variable in the remaining equations +minvar :: IsLinear a => Context (LinearSystem a) -> Maybe String +minvar c | null list = Nothing + | otherwise = Just (minimum list) + where + list = getVarsSystem (remaining c) + +liftSystemTrans :: Transformation (LinearSystem a) -> Transformation (Context (LinearSystem a)) +liftSystemTrans = lift $ makeLiftPair (return . equations) (fmap . const) + +systemInNF :: (Arbitrary a, IsLinear a) => Gen (LinearSystem a) +systemInNF = do + n <- arbitrary + replicateM n $ liftM2 (:==:) arbitrary arbitrary + +toIntegerSystem :: RealFrac a => LinearSystem a -> LinearSystem Integer +toIntegerSystem = map (fmap round) + +fromIntegerSystem :: RealFrac a => LinearSystem Integer -> LinearSystem a +fromIntegerSystem = map (fmap fromInteger) diff --git a/src/Domain/LinearAlgebra/Exercises.hs b/src/Domain/LinearAlgebra/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Exercises.hs @@ -0,0 +1,159 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Exercises + ( gramSchmidtExercise, linearSystemExercise + , gaussianElimExercise, systemWithMatrixExercise + ) where + +import Common.Apply +import Common.Context +import Common.Exercise +import Common.Transformation +import Control.Monad +import Domain.LinearAlgebra.EquationsRules +import Domain.LinearAlgebra.GramSchmidtRules +import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.MatrixRules +import Domain.LinearAlgebra.Parser +import Domain.LinearAlgebra.Strategies +import Domain.LinearAlgebra.Vector +import Domain.Math.Data.Equation +import Domain.Math.Expr +import Domain.Math.Simplification +import Test.QuickCheck +import Text.Parsing (SyntaxError(..)) + +gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr)) +gramSchmidtExercise = testableExercise + { description = "Gram-Schmidt" + , exerciseCode = makeCode "linalg" "gramschmidt" + , status = Provisional + , parser = \s -> case parseVectorSpace s of + (a, []) -> Right (fmap simplified a) + (_, m:_) -> Left $ ErrorMessage $ show m + , prettyPrinter = unlines . map show . vectors + , equivalence = \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt + in f x == f y + , extraRules = rulesGramSchmidt + , isReady = orthonormalList . filter (not . isZero) . vectors + , strategy = gramSchmidtStrategy + , randomExercise = simpleGenerator arbitrary + } + +linearSystemExercise :: Exercise (Equations Expr) +linearSystemExercise = testableExercise + { description = "Solve Linear System" + , exerciseCode = makeCode "linalg" "linsystem" + , status = Stable + , parser = \s -> case parseSystem s of + (a, []) -> Right (simplify a) + (_, m:_) -> Left $ ErrorMessage $ show m + , prettyPrinter = unlines . map show + , equivalence = \x y -> let f = getSolution . equations . applyD linearSystemStrategy + . inContext . map toStandardForm + in f x == f y + , extraRules = equationsRules + , isReady = inSolvedForm + , strategy = linearSystemStrategy + , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix) + } + +gaussianElimExercise :: Exercise (Matrix Expr) +gaussianElimExercise = testableExercise + { description = "Gaussian Elimination" + , exerciseCode = makeCode "linalg" "gaussianelim" + , status = Stable + , parser = \s -> case parseMatrix s of + (a, []) -> Right (simplify a) + (_, m:_) -> Left $ ErrorMessage $ show m + , prettyPrinter = ppMatrixWith show + , equivalence = \x y -> fmap simplified x === fmap simplified y + , extraRules = matrixRules + , isReady = inRowReducedEchelonForm + , strategy = gaussianElimStrategy + , randomExercise = simpleGenerator arbMatrix + } + +systemWithMatrixExercise :: Exercise (Either (LinearSystem Expr) (Matrix Expr)) +systemWithMatrixExercise = testableExercise + { description = "Solve Linear System with Matrix" + , exerciseCode = makeCode "linalg" "systemwithmatrix" + , status = Provisional + , parser = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of + (Right ok, _) -> Right $ Left ok + (_, Right ok) -> Right $ Right ok + (Left _, Left _) -> Left $ ErrorMessage "Syntax error" -- FIX THIS + , prettyPrinter = either (unlines . map show) ppMatrix + , equivalence = \x y -> let f = either id matrixToSystem + in equivalence linearSystemExercise (f x) (f y) + , extraRules = map liftRuleContextLeft equationsRules ++ map liftRuleContextRight matrixRules + , isReady = either inSolvedForm (const False) + , strategy = systemWithMatrixStrategy + , randomExercise = simpleGenerator (fmap (Left . matrixToSystem) arbMatrix) + , testGenerator = fmap (liftM Left) (testGenerator linearSystemExercise) + } + +-------------------------------------------------------------- +-- Other stuff (to be cleaned up) + +instance Arbitrary a => Arbitrary (Vector a) where + arbitrary = liftM fromList $ oneof $ map vector [0..2] + coarbitrary = coarbitrary . toList + +instance Arbitrary a => Arbitrary (VectorSpace a) where + arbitrary = do + i <- choose (0, 3) -- too many vectors "disables" prime factorization + j <- choose (0, 10 `div` i) + xs <- replicateM i (liftM fromList $ replicateM j arbitrary) + return $ makeVectorSpace xs + coarbitrary = coarbitrary . vectors + +arbMatrix :: Num a => Gen (Matrix a) +arbMatrix = fmap (fmap fromInteger) arbNiceMatrix + +liftRuleContextLeft :: Rule (Context a) -> Rule (Context (Either a b)) +liftRuleContextLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a) + +liftRuleContextRight :: Rule (Context b) -> Rule (Context (Either a b)) +liftRuleContextRight = lift $ makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b) + +instance Arbitrary a => Arbitrary (Matrix a) where + arbitrary = do + (i, j) <- arbitrary + arbSizedMatrix (i `mod` 5, j `mod` 5) + coarbitrary = coarbitrary . rows + +arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a) +arbSizedMatrix (i, j) = + do rows <- replicateM i (vector j) + return (makeMatrix rows) + +arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a) +arbUpperMatrix = do + a <- oneof $ map return [-5 .. 5] + b <- oneof $ map return [-5 .. 5] + c <- oneof $ map return [-5 .. 5] + return $ makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]] + +arbAugmentedMatrix :: (Enum a, Num a) => Gen (Matrix a) +arbAugmentedMatrix = do + a <- oneof $ map return [-5 .. 5] + b <- oneof $ map return [-5 .. 5] + c <- oneof $ map return [-5 .. 5] + return $ makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]] + +arbNiceMatrix :: (Enum a, Num a) => Gen (Matrix a) +arbNiceMatrix = do + m1 <- arbUpperMatrix + m2 <- arbAugmentedMatrix + return (multiply m1 m2) diff --git a/src/Domain/LinearAlgebra/GramSchmidtRules.hs b/src/Domain/LinearAlgebra/GramSchmidtRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/GramSchmidtRules.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.GramSchmidtRules where + +import Common.Context +import Common.Transformation +import Common.Utils +import Domain.LinearAlgebra.Vector +import Control.Monad +import Data.List + +varI, varJ :: Var Int +varI = "considered" := 0 +varJ = "j" := 0 + +rulesGramSchmidt :: Floating a => [Rule (Context (VectorSpace a))] +rulesGramSchmidt = [ruleNormalize, ruleOrthogonal, ruleNext] + +-- Make the current vector of length 1 +-- (only applicable if this is not already the case) +ruleNormalize :: Floating a => Rule (Context (VectorSpace a)) +ruleNormalize = makeSimpleRule "Turn into unit Vector" $ + \c -> do v <- current c + guard (norm v `notElem` [0, 1]) + setCurrent (toUnit v) c + +-- Make the current vector orthogonal with some other vector +-- that has already been considered +ruleOrthogonal :: Floating a => Rule (Context (VectorSpace a)) +ruleOrthogonal = makeRule "Make orthogonal" $ supplyLabeled2 descr args transOrthogonal + where + descr = ("vector 1", "vector 2") + args c = do let i = get varI c-1 + j = get varJ c-1 + guard (i>j) + return (j, i) + +-- Variable "j" is for administrating which vectors are already orthogonal +ruleNextOrthogonal :: Rule (Context (VectorSpace a)) +ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ + \c -> do guard (get varJ c + 1 < get varI c) + return (change varJ (+1) c) + +-- Consider the next vector +-- This rule should fail if there are no vectors left +ruleNext :: Rule (Context (VectorSpace a)) +ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ + \c -> do guard (get varI c < length (vectors (fromContext c))) + return $ change varI (+1) $ set varJ 0 c + +current :: Context (VectorSpace a) -> Maybe (Vector a) +current c = + case drop (get varI c - 1) (vectors (fromContext c)) of + v:_ -> Just v + _ -> Nothing + +setCurrent :: Vector a -> Context (VectorSpace a) -> Maybe (Context (VectorSpace a)) +setCurrent v c = + case splitAt (get varI c - 1) (vectors (fromContext c)) of + (xs, _:ys) -> Just $ fmap (makeVectorSpace . const (xs ++ v:ys)) c + _ -> Nothing + +-- Two indices, change the second vector and make it orthogonal +-- to the first +transOrthogonal :: Floating a => Int -> Int -> Transformation (Context (VectorSpace a)) +transOrthogonal i j = contextTrans "transOrthogonal" $ \xs -> + do guard (i /= j && i >=0 && j >= 0) + u <- safeHead $ drop i (vectors xs) + guard (isUnit u) + case splitAt j (vectors xs) of + (begin, v:end) -> Just $ makeVectorSpace $ begin ++ makeOrthogonal u v:end + _ -> Nothing + +-- Find proper abstraction, and move this function to transformation module +contextTrans :: String -> (a -> Maybe a) -> Transformation (Context a) +contextTrans s f = makeTrans s $ \c -> do + new <- f (fromContext c) + return (fmap (const new) c) diff --git a/src/Domain/LinearAlgebra/LinearSystem.hs b/src/Domain/LinearAlgebra/LinearSystem.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/LinearSystem.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.LinearSystem where + +import Domain.Math.Data.Equation +import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows) +import Domain.LinearAlgebra.LinearView +import Data.List +import Data.Maybe +import Control.Monad +import Common.Utils +import Common.Uniplate + +type LinearSystem a = Equations a + +getVarsSystem :: IsLinear a => LinearSystem a -> [String] +getVarsSystem = foldr (\(lhs :==: rhs) xs -> getVars lhs `union` getVars rhs `union` xs) [] + +evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool +evalSystem = all . evalEquationWith . evalLinearExpr + +invalidSystem :: IsLinear a => LinearSystem a -> Bool +invalidSystem = any invalidEquation + +invalidEquation :: IsLinear a => Equation a -> Bool +invalidEquation (lhs :==: rhs) = null (getVars lhs ++ getVars rhs) && getConstant lhs /= getConstant rhs + +getSolution :: IsLinear a => LinearSystem a -> Maybe [(String, a)] +getSolution xs = do + guard (distinct vars) + guard (null (vars `intersect` frees)) + mapM make xs + where + vars = concatMap (getVars . getLHS) xs + frees = concatMap (getVars . getRHS) xs + make (lhs :==: rhs) = do + v <- isVar lhs + return (v, rhs) + +-- No constant on the left, no variables on the right +inStandardForm :: IsLinear a => Equation a -> Bool +inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && null (getVars rhs) + +toStandardForm :: IsLinear a => Equation a -> Equation a +toStandardForm (lhs :==: rhs) = + let c = getConstant rhs - getConstant lhs + in (lhs - rhs + c) :==: c + + +inSolvedForm :: IsLinear a => LinearSystem a -> Bool +inSolvedForm xs = invalidSystem xs || isJust (getSolution xs) + +homogeneous :: IsLinear a => LinearSystem a -> Bool +homogeneous = all ((== 0) . getRHS) + +-- Conversions +systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String]) +systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vars) + where + vars = getVarsSystem system + makeRow (lhs :==: rhs) = + map (`coefficientOf` lhs) vars ++ [getConstant rhs] + +matrixToSystem :: IsLinear a => Matrix a -> LinearSystem a +matrixToSystem = matrixToSystemWith variables + +matrixToSystemWith :: IsLinear a => [String] -> Matrix a -> LinearSystem a +matrixToSystemWith vs = map makeEquation . rows + where + varList = vs ++ (variables \\ vs) + makeEquation [] = 0 :==: 0 + makeEquation xs = + let lhs = sum (zipWith (\v a -> a * var v) varList (init xs)) + rhs = last xs + in lhs :==: rhs + +variables :: [String] +variables = map (\n -> 'x' : [n]) $ ['1' .. '9'] ++ ['a' .. 'z'] -- should be sorted!! diff --git a/src/Domain/LinearAlgebra/LinearView.hs b/src/Domain/LinearAlgebra/LinearView.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/LinearView.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.LinearView + ( IsLinear(..), var, isVar, isConstant, renameVariables + , splitLinearExpr, evalLinearExpr, linearView + , LinearMap + ) where + +import Control.Monad +import Data.List +import Common.Uniplate +import Data.Maybe +import Common.View hiding (simplify) +import GHC.Real +import Domain.Math.Expr +import qualified Data.Map as M + +data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a } + +instance Functor LinearMap where + fmap f (LM m c) = LM (M.map f m) (f c) + +linearView :: View Expr (LinearMap Expr) +linearView = makeView f g + where + -- compositional (sumView would be a more restrictive alternative) + f expr = + case expr of + Nat n -> return $ LM M.empty (fromInteger n) + Var s -> return $ LM (M.singleton s 1) 0 + a :+: b -> liftM2 plusLM (f a) (f b) + a :-: b -> liftM2 plusLM (f a) (liftM negateLM (f b)) + Negate a -> liftM negateLM (f a) + a :*: b -> join $ liftM2 timesLM (f a) (f b) + a :/: b -> join $ liftM2 divLM (f a) (f b) + Sqrt a -> join $ liftM sqrtLM (f a) + Sym s as -> mapM f as >>= symLM s + + g (LM m c) = build sumView (concatMap make (M.toList m) ++ [c | c /= 0]) + make (s, e) + | e == 0 = [] + | e == 1 = [variable s] + | e == -1 = [negate (variable s)] + | otherwise = [e*variable s] + +plusLM :: Num a => LinearMap a -> LinearMap a -> LinearMap a +plusLM (LM m1 c1) (LM m2 c2) = LM (M.unionWith (+) m1 m2) (c1+c2) + +negateLM :: Num a => LinearMap a -> LinearMap a +negateLM (LM m c) = LM (M.map negate m) (negate c) + +timesLM :: Num a => LinearMap a -> LinearMap a -> Maybe (LinearMap a) +timesLM lm1@(LM m1 c1) lm2@(LM m2 c2) + | M.null m1 = return $ fmap (c1*) lm2 + | M.null m2 = return $ fmap (*c2) lm1 + | otherwise = Nothing + +divLM :: Fractional a => LinearMap a -> LinearMap a -> Maybe (LinearMap a) +divLM lm (LM m2 c2) = do + guard (M.null m2 && c2 /= 0) + return $ fmap (/c2) lm + +sqrtLM :: Floating a => LinearMap a -> Maybe (LinearMap a) +sqrtLM (LM m c) = do + guard (M.null m) + return $ LM M.empty (sqrt c) + +symLM :: Symbolic a => Symbol -> [LinearMap a] -> Maybe (LinearMap a) +symLM f ps = do + guard (all (M.null . lmMap) ps) + return $ LM M.empty (function f (map lmConstant ps)) + +class (Fractional a, Symbolic a) => IsLinear a where + isLinear :: a -> Bool + isVariable :: a -> Maybe String + getVars :: a -> [String] + getConstant :: a -> a + coefficientOf :: String -> a -> a + +instance IsLinear Expr where + + isLinear expr = belongsTo expr linearView + + isVariable expr = + case expr of + Var s -> Just s + _ -> Nothing + + getVars = collectVars + + getConstant expr = + case match linearView expr of + Just (LM _ c) -> c + _ -> 0 + + coefficientOf s expr = + case match linearView expr of + Just (LM m _) -> M.findWithDefault 0 s m + _ -> 0 + +{- instance IsLinear SExpr where + isLinear = isLinear . toExpr + isVariable = isVariable . toExpr + getVars = getVars . toExpr + getConstant = simplifyExpr . getConstant . toExpr + coefficientOf s = simplifyExpr . coefficientOf s . toExpr -} + +splitLinearExpr :: IsLinear a => (String -> Bool) -> a -> (a, a) +splitLinearExpr f a = (make (getConstant a) xs, make 0 ys) + where + (xs, ys) = partition f (getVars a) + make = foldr (\v r -> coefficientOf v a * var v + r) + +evalLinearExpr :: (IsLinear a, Uniplate a) => (String -> a) -> a -> a +evalLinearExpr f a = + case isVariable a of + Just s -> f s + Nothing -> g $ map (evalLinearExpr f) cs + where + (cs, g) = uniplate a + +renameVariables :: (IsLinear a, Uniplate a) => (String -> String) -> a -> a +renameVariables f a = + case isVariable a of + Just s -> variable (f s) + Nothing -> g $ map (renameVariables f) cs + where + (cs, g) = uniplate a + +isConstant :: IsLinear a => a -> Bool +isConstant = null . getVars + +var :: IsLinear a => String -> a +var = variable + +isVar :: IsLinear a => a -> Maybe String +isVar = isVariable diff --git a/src/Domain/LinearAlgebra/Matrix.hs b/src/Domain/LinearAlgebra/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Matrix.hs @@ -0,0 +1,262 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Matrix + ( Matrix, Row, Column, isRectangular, makeMatrix, identity, mapWithPos + , changeEntries, changeEntry, setEntries, setEntry + , rows, row, columns, column, dimensions, entry, isEmpty + , add, scale, multiply + , reduce, forward, backward, inverse, invertible, rank, nullity, (===) + , switchRows, scaleRow, addRow + , inRowEchelonForm, inRowReducedEchelonForm + , nonZero, pivot, isPivotColumn + , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular + ) where + +import Control.Monad +import Data.Maybe +import Data.List hiding (transpose) +import Common.Traversable +import qualified Data.List as L +import qualified Data.Map as M + +-- Invariant: a matrix is always rectangular +newtype Matrix a = M [[a]] + deriving (Eq, Ord, Show) + +type Row a = [a] +type Column a = [a] + +instance Functor Matrix where + fmap f (M rows) = M (map (map f) rows) + +instance Once Matrix where + onceM f (M xss) = do + yss <- onceM (onceM f) xss + return (M yss) + +instance Switch Matrix where + switch (M xss) = liftM M (mapM sequence xss) + +-- Check whether the table is rectangular +isRectangular :: [[a]] -> Bool +isRectangular xss = + case map length xss of + [] -> True + n:ns -> all (==n) ns + +-- Constructor function that checks whether the table is rectangular +makeMatrix :: [Row a] -> Matrix a +makeMatrix rows + | null (concat rows) = M [] + | isRectangular rows = M rows + | otherwise = error "makeMatrix: not rectangular" + +identity :: Num a => Int -> Matrix a +identity n = M $ map f [0..n-1] + where f i = replicate i 0 ++ [1] ++ replicate (n-i-1) 0 + +isEmpty :: Matrix a -> Bool +isEmpty (M xs) = null xs + +rows :: Matrix a -> [Row a] +rows (M rows) = rows + +row :: Int -> Matrix a -> Row a +row n = (!!n) . rows + +columns :: Matrix a -> [Column a] +columns = rows . transpose + +column :: Int -> Matrix a -> Column a +column n = (!!n) . columns + +dimensions :: Matrix a -> (Int, Int) +dimensions m = (length $ rows m, length $ columns m) + +entry :: (Int, Int) -> Matrix a -> a +entry (i, j) m = row i m !! j + +mapWithPos :: ((Int, Int) -> a -> b) -> Matrix a -> Matrix b +mapWithPos f (M rows) = M $ zipWith g [0..] rows + where g y = zipWith (\x -> f (y, x)) [0..] + +changeEntries :: M.Map (Int, Int) (a -> a) -> Matrix a -> Matrix a +changeEntries mp = mapWithPos (\pos -> M.findWithDefault id pos mp) + +changeEntry :: (Int, Int) -> (a -> a) -> Matrix a -> Matrix a +changeEntry pos = changeEntries . M.singleton pos + +setEntries :: M.Map (Int, Int) a -> Matrix a -> Matrix a +setEntries mp = mapWithPos (\pos a -> M.findWithDefault a pos mp) + +setEntry :: (Int, Int) -> a -> Matrix a -> Matrix a +setEntry pos = setEntries . M.singleton pos + +------------------------------------------------------- + +add :: Num a => Matrix a -> Matrix a -> Matrix a +add a b + | dimensions a == dimensions b = + M $ zipWith (zipWith (+)) (rows a) (rows b) + | otherwise = + error "add: dimensions differ" + +scale :: Num a => a -> Matrix a -> Matrix a +scale a = fmap (*a) + +multiply :: Num a => Matrix a -> Matrix a -> Matrix a +multiply a b + | snd (dimensions a) == fst (dimensions b) = + M $ map (\r -> map (sum . zipWith (*) r) (columns b)) (rows a) + | otherwise = + error "multiply: incorrect dimensions" + +------------------------------------------------------- +-- Gaussian Elimination + +reduce :: Fractional a => Matrix a -> Matrix a +reduce = backward . forward + +forward :: Fractional a => Matrix a -> Matrix a +forward m + | h==0 || w==0 = m + | all (==0) col = M $ zipWith (:) (repeat 0) $ rows $ forward $ M $ map tail $ rows m + | x == 0 = forward (switchRows 0 (fromJust $ findIndex (/= 0) col) m) + | x == 1 = let M (r:rs) = foldr (\k -> addRow k 0 (negate $ entry (k,0) m)) m [1..h-1] + M ts = forward (M rs) + in M (r:ts) + | otherwise = forward (scaleRow 0 (1/x) m) + where + (h, w) = dimensions m + x = entry (0,0) m + col = column 0 m + +backward :: Fractional a => Matrix a -> Matrix a +backward m = foldr f m [1..h-1] + where + (h, _) = dimensions m + f i = let g j = case findIndex (/=0) (row i m) of + Just k -> addRow j i (negate (entry (j, k) m)) + Nothing -> id + in flip (foldr g) [0..i-1] + +rank :: Fractional a => Matrix a -> Int +rank = length . filter (isJust . pivot) . rows . reduce + +nullity :: Fractional a => Matrix a -> Int +nullity m = snd (dimensions m) - rank m + +inverse :: Fractional a => Matrix a -> Maybe (Matrix a) +inverse m + | h /= w = Nothing + | rank m < w = Nothing + | otherwise = Just $ M $ map (drop h) $ rows $ reduce $ M $ zipWith (++) (rows m) $ rows $ identity h + where + (h, w) = dimensions m + +invertible :: Fractional a => Matrix a -> Bool +invertible = isJust . inverse + +(===) :: Fractional a => Matrix a -> Matrix a -> Bool +m1 === m2 = reduce m1 == reduce m2 + +-- test = rank $ makeMatrix $ [[0 :: Rational ,1,1,1], [1,2,3,2], [3,1,1,3]] + +-- t = inverse $ M [[1,0],[0,3]] + +------------------------------------------------------- + +transpose :: Matrix a -> Matrix a +transpose (M rows) = M (L.transpose rows) + +------------------------------------------------------- + +isSquare :: Matrix a -> Bool +isSquare m = i==j + where (i, j) = dimensions m + +identityMatrix :: Num a => Int -> Matrix a +identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list + where list = [0..n-1] + +------------------------------------------------------- +-- Elementary row operations (preserve matrix equivalence) + +checkRow :: Int -> Matrix a -> Bool +checkRow i m = i >= 0 && i < fst (dimensions m) + +switchRows :: Int -> Int -> Matrix a -> Matrix a +switchRows i j m@(M rows) + | i == j = m + | i > j = switchRows j i m + | checkRow i m && checkRow j m = + let (before, r1:rest) = splitAt i rows + (middle, r2:after) = splitAt (j-i-1) rest + in M $ before ++ [r2] ++ middle ++ [r1] ++ after + | otherwise = + error "switchRows: invalid rows" + +scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a +scaleRow i a m@(M rows) + | checkRow i m = + let f y = if y==i then map (*a) else id + in M $ zipWith f [0..] rows + | otherwise = + error "scaleRow: invalid row" + +addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a +addRow i j a m@(M rows) + | checkRow i m && checkRow j m = + let rj = map (*a) (row j m) + f y = if y==i then zipWith (+) rj else id + in M $ zipWith f [0..] rows + | otherwise = + error "addRow: invalid row" + +------------------------------------------------------- + +isLowerTriangular :: Num a => Matrix a -> Bool +isLowerTriangular = and . zipWith check [1..] . rows + where check n = all (==0) . drop n + +isUpperTriangular :: Num a => Matrix a -> Bool +isUpperTriangular = and . zipWith check [0..] . rows + where check n = all (==0) . take n + +inRowEchelonForm :: Num a => Matrix a -> Bool +inRowEchelonForm (M rows) = + null (filter nonZero (dropWhile nonZero rows)) && + increasing (map (length . takeWhile (==0)) (filter nonZero rows)) + where + increasing (x:ys@(y:_)) = x < y && increasing ys + increasing _ = True + +nonZero :: Num a => [a] -> Bool +nonZero = any (/=0) + +-- or row canonical form +inRowReducedEchelonForm :: Num a => Matrix a -> Bool +inRowReducedEchelonForm m@(M rows) = + inRowEchelonForm m && + all (==1) (mapMaybe pivot rows) && + all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rows) + +pivot :: Num a => Row a -> Maybe a +pivot r = case dropWhile (==0) r of + hd:_ -> Just hd + _ -> Nothing + +isPivotColumn :: Num a => Column a -> Bool +isPivotColumn c = + case filter (/=0) c of + [1] -> True + _ -> False diff --git a/src/Domain/LinearAlgebra/MatrixRules.hs b/src/Domain/LinearAlgebra/MatrixRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/MatrixRules.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.MatrixRules where + +import Domain.Math.Simplification +import Domain.LinearAlgebra.Matrix +import Common.Context +import Common.Transformation +import Control.Monad +import Data.List + +instance Simplify a => Simplify (Matrix a) where + simplify = fmap simplify + +matrixRules :: (Argument a, Fractional a) => [Rule (Context (Matrix a))] +matrixRules = + let noArgs f = f (const Nothing) + in [ noArgs ruleScaleRow + , noArgs ruleExchangeRows + , noArgs ruleAddMultiple + ] + +ruleFindColumnJ :: Num a => Rule (Context (Matrix a)) +ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ \c -> do + let cols = columns (subMatrix c) + i <- findIndex nonZero cols + return (set columnJ i c) + +ruleExchangeNonZero :: (Simplify a, Num a) => Rule (Context (Matrix a)) +ruleExchangeNonZero = simplify $ ruleExchangeRows $ \c -> do + nonEmpty c + let col = column (get columnJ c) (subMatrix c) + i <- findIndex (/= 0) col + return (get covered c, i + get covered c) + +ruleScaleToOne :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) +ruleScaleToOne = simplify $ ruleScaleRow $ \c -> do + nonEmpty c + let pv = entry (0, get columnJ c) (subMatrix c) + guard (pv /= 0) + return (get covered c, 1 / pv) + +ruleZerosFP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) +ruleZerosFP = simplify $ ruleAddMultiple $ \c -> do + nonEmpty c + let col = drop 1 $ column (get columnJ c) (subMatrix c) + i <- findIndex (/= 0) col + let v = negate (col!!i) + return (i + get covered c + 1, get covered c, v) + +ruleZerosBP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a)) +ruleZerosBP = simplify $ ruleAddMultiple $ \c -> do + nonEmpty c + let ri = row 0 (subMatrix c) + j = length $ takeWhile (==0) ri + col = column j (matrix c) + guard (any (/= 0) ri) + k <- findIndex (/= 0) col + let v = negate (col!!k) + return (k, get covered c, v) + +ruleCoverRow :: Rule (Context (Matrix a)) +ruleCoverRow = minorRule $ makeRule "CoverRow" $ changeCover (+1) + +ruleUncoverRow :: Rule (Context (Matrix a)) +ruleUncoverRow = minorRule $ makeRule "UncoverRow" $ changeCover (\x -> x-1) + +--------------------------------------------------------------------------------- +-- Parameterized rules + +ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a)) +ruleScaleRow f = makeRule "Scale" (supplyLabeled2 descr f rowScale) + where descr = ("row", "scale factor") + +ruleExchangeRows :: Num a => (Context (Matrix a) -> Maybe (Int, Int)) -> Rule (Context (Matrix a)) +ruleExchangeRows f = makeRule "Exchange" (supplyLabeled2 descr f rowExchange) + where descr = ("row 1", "row 2") + +ruleAddMultiple :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, Int, a)) -> Rule (Context (Matrix a)) +ruleAddMultiple f = makeRule "Add" (supplyLabeled3 descr f rowAdd) + where descr = ("row 1", "row2", "scale factor") + +--------------------------------------------------------------------------------- +-- Parameterized transformations + +rowExchange :: Int -> Int -> Transformation (Context (Matrix a)) +rowExchange i j = matrixTrans "rowExchange" $ \m -> do + guard (i /= j && validRow i m && validRow j m) + return (switchRows i j m) + +rowScale :: Num a => Int -> a -> Transformation (Context (Matrix a)) +rowScale i k = matrixTrans "rowScale" $ \m -> do + guard (k `notElem` [0, 1] && validRow i m) + return (scaleRow i k m) + +rowAdd :: Num a => Int -> Int -> a -> Transformation (Context (Matrix a)) +rowAdd i j k = matrixTrans "rowAdd" $ \m -> do + guard (k /= 0 && i /= j && validRow i m && validRow j m) + return (addRow i j k m) + +changeCover :: (Int -> Int) -> Transformation (Context (Matrix a)) +changeCover f = makeTrans "changeCover" $ \c -> do + let new = f (get covered c) + guard (new >= 0 && new <= fst (dimensions (matrix c))) + return $ set covered new c -- c {get covered = new} + +matrixTrans :: String -> (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a)) +matrixTrans s f = makeTrans s $ \c -> do + new <- f (fromContext c) + return (fmap (const new) c) + +-- local helper function +validRow :: Int -> Matrix a -> Bool +validRow i m = i >= 0 && i < fst (dimensions m) + +nonEmpty :: Context (Matrix a) -> Maybe () +nonEmpty = guard . not . isEmpty . subMatrix + +covered, columnJ :: Var Int +covered = "covered" := 0 +columnJ = "columnJ" := 0 + +matrix, subMatrix :: Context (Matrix a) -> Matrix a +matrix = fromContext +subMatrix c = makeMatrix $ drop (get covered c) $ rows $ matrix c diff --git a/src/Domain/LinearAlgebra/Parser.hs b/src/Domain/LinearAlgebra/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Parser.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Parser + ( parseMatrix, parseVectorSpace, ppMatrix, ppMatrixWith + , parseSystem + ) where + +import Domain.Math.Data.Equation +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.LinearSystem +import Domain.LinearAlgebra.LinearView (isLinear) +import Domain.LinearAlgebra.Vector +import Control.Monad +import Data.List +import Data.Char +import Domain.Math.Expr +import Domain.Math.Expr.Parser +import Text.Parsing + +{- +testje = case parseSystem " \n\n x == 43 \n 3*y == sqrt 4 \n" of -- "\n\n 1*x + 3*y + 2 + 87 == 2 \n " of + this -> this -} + +parseSystem :: String -> (LinearSystem Expr, [String]) +parseSystem = f . parse pSystem . scanWith s + where + s0 = newlinesAsSpecial scannerExpr + s = s0 {keywordOperators = "==" : keywordOperators s0 } + f (Nothing, xs) = ([], "System is not linear" : map show xs) + f (Just m, xs) = (m, map show xs) + +pSystem :: TokenParser (Maybe (LinearSystem Expr)) +pSystem = convertSystem <$> pEquations pExpr + where + convertSystem :: Equations Expr -> Maybe (LinearSystem Expr) + convertSystem eqs + | all f eqs = return eqs + | otherwise = Nothing + where + f (a :==: b) = isLinear a && isLinear b + +----------------------------------------------------------- +--- Parser + +parseMatrix :: String -> (Matrix Expr, [String]) +parseMatrix = f . parse p . scanWith s + where + s = newlinesAsSpecial scannerExpr + p = pMatrix pFractional + f (Nothing, xs) = (makeMatrix [], "Matrix is not rectangular" : map show xs) + f (Just m, xs) = (m, map show xs) + +pMatrix :: TokenParser a -> TokenParser (Maybe (Matrix a)) +pMatrix p = make <$> pLines True (pList1 p) + where + make xs = if isRectangular xs then Just (makeMatrix xs) else Nothing + +parseVectorSpace :: String -> (VectorSpace Expr, [Message Token]) +parseVectorSpace = parse p . scanWith s + where + s = newlinesAsSpecial scannerExpr + p = makeVectorSpace <$> pVectors pExpr + +pVectors :: TokenParser a -> TokenParser [Vector a] +pVectors p = pLines True (pVector p) + +pVector :: TokenParser a -> TokenParser (Vector a) +pVector p = fromList <$> myParens (myListSep (pSpec ',') p) + +myListSep :: TokenParser a -> TokenParser b -> TokenParser [b] +myListSep sep p = optional ((:) <$> p <*> pList (sep *> p)) [] + +myParens :: TokenParser a -> TokenParser a +myParens p = pSpec '(' *> p <* pSpec ')' + +----------------------------------------------------------- +--- Pretty-Printer + +ppMatrix :: Show a => Matrix a -> String +ppMatrix = ppMatrixWith show + +ppMatrixWith :: (a -> String) -> Matrix a -> String +ppMatrixWith f = ppStringMatrix . fmap f + +ppStringMatrix :: Matrix String -> String +ppStringMatrix = format . rows + where + format m = let ws = foldr (zipWith max . map length) (repeat 0) m + align i s = take i (s ++ repeat ' ') + in unlines $ map (unwords . zipWith align ws) m diff --git a/src/Domain/LinearAlgebra/Strategies.hs b/src/Domain/LinearAlgebra/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Strategies.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Strategies + ( gaussianElimStrategy, linearSystemStrategy + , gramSchmidtStrategy, systemWithMatrixStrategy + , forwardPass + , isLeft, isRight, maybeInContext + ) where + +import Prelude hiding (repeat) +import Domain.Math.Expr +import Domain.Math.Simplification +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.MatrixRules +import Domain.LinearAlgebra.EquationsRules +import Domain.LinearAlgebra.GramSchmidtRules +import Domain.LinearAlgebra.LinearSystem +import Common.Apply +import Common.Strategy hiding (not) +import Common.Transformation +import Common.Context +import Domain.LinearAlgebra.Vector + +gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr)) +gaussianElimStrategy = label "Gaussian elimination" $ + forwardPass <*> backwardPass + +forwardPass :: LabeledStrategy (Context (Matrix Expr)) +forwardPass = label "Forward pass" $ + simplifyRule <*> + repeat ( label "Find j-th column" ruleFindColumnJ + <*> label "Exchange rows" (try ruleExchangeNonZero) + <*> label "Scale row" (try ruleScaleToOne) + <*> label "Zeros in j-th column" (repeat ruleZerosFP) + <*> label "Cover up top row" ruleCoverRow + ) + +backwardPass :: LabeledStrategy (Context (Matrix Expr)) +backwardPass = label "Backward pass" $ + simplifyRule <*> + repeat ( label "Uncover row" ruleUncoverRow + <*> label "Sweep" (repeat ruleZerosBP) + ) + +backSubstitutionSimple :: LabeledStrategy (Context (LinearSystem Expr)) +backSubstitutionSimple = + label "Back substitution with equally many variables and equations" $ + simplifyFirst + <*> label "Cover all equations" ruleCoverAllEquations + <*> repeat ( label "Uncover one equation" ruleUncoverEquation + <*> label "Scale equation to one" (try ruleScaleEquation) + <*> label "Back Substitution" (repeat ruleBackSubstitution) + ) + +backSubstitution :: LabeledStrategy (Context (LinearSystem Expr)) +backSubstitution = label "Back substitution" $ + ruleIdentifyFreeVariables <*> backSubstitutionSimple + +systemToEchelonWithEEO :: LabeledStrategy (Context (LinearSystem Expr)) +systemToEchelonWithEEO = + label "System to Echelon Form (EEO)" $ + simplifyFirst <*> + repeat ( dropEquation + <|> check (not . null . remaining) + <*> label "Exchange equations" (try ruleExchangeEquations) + <*> label "Scale equation to one" (option ruleScaleEquation) + <*> label "Eliminate variable" (repeat ruleEliminateVar) + <*> label "Cover up first equation" ruleCoverUpEquation + ) + +dropEquation :: LabeledStrategy (Context (LinearSystem Expr)) +dropEquation = + label "Drop equations" $ + label "Inconsistent system (0=1)" ruleInconsistentSystem + <|> label "Drop (0=0) equation" ruleDropEquation + +linearSystemStrategy :: LabeledStrategy (Context (LinearSystem Expr)) +linearSystemStrategy = label "General solution to a linear system" $ + systemToEchelonWithEEO <*> backSubstitution + +systemWithMatrixStrategy :: LabeledStrategy (Context (Either (LinearSystem Expr) (Matrix Expr))) +systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $ + repeat (liftLeft dropEquation) + <*> conv1 + <*> liftRight gaussianElimStrategy + <*> conv2 + <*> repeat (liftLeft dropEquation) + +gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr))) +gramSchmidtStrategy = + label "Gram-Schmidt" $ repeat $ label "Iteration" $ + label "Consider next vector" ruleNext + <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal)) + <*> label "Normalize" (try ruleNormalize) + +vars :: Var [String] +vars = "variables" := [] + +simplifyFirst :: Rule (Context (LinearSystem Expr)) +simplifyFirst = simplifySystem idRule + +conv1 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr))) +conv1 = translationToContext "Linear system to matrix" $ \c -> + let (m, vs) = systemToMatrix (fromContext c) + in return $ set vars vs $ fmap (const (simplify m)) c + +conv2 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr))) +conv2 = translationFromContext "Matrix to linear system" $ \c -> + let linsys = matrixToSystemWith (get vars c) (fromContext c) + in return $ applyD simplifyFirst $ fmap (const linsys) c + +liftLeft :: (IsStrategy f, Lift f) => f (Context a) -> f (Context (Either a b)) +liftLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a) + +liftRight :: (IsStrategy f, Lift f) => f (Context b) -> f (Context (Either a b)) +liftRight = lift $ + makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b) + +maybeInContext :: Context (Maybe a) -> Maybe (Context a) +maybeInContext c = fmap (\a -> fmap (const a) c) (fromContext c) + +isLeft :: Either a b -> Maybe a +isLeft = either Just (const Nothing) + +isRight :: Either a b -> Maybe b +isRight = either (const Nothing) Just + +translationToContext :: String -> (Context a -> Maybe (Context b)) -> Rule (Context (Either a b)) +translationToContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Right) . f) . maybeInContext . fmap isLeft) + +translationFromContext :: String -> (Context b -> Maybe (Context a)) -> Rule (Context (Either a b)) +translationFromContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Left) . f) . maybeInContext . fmap isRight) + +instance Simplify a => Simplify (Vector a) where + simplify = fmap simplify + +instance Simplify a => Simplify (VectorSpace a) where + simplify = fmap simplify diff --git a/src/Domain/LinearAlgebra/Symbols.hs b/src/Domain/LinearAlgebra/Symbols.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Symbols.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Symbols + ( -- linalg2 + matrixSymbol, matrixrowSymbol, vectorSymbol + ) where + +import Domain.Math.Expr.Conversion +import Domain.Math.Expr.Symbolic +import Domain.LinearAlgebra.Matrix +import Domain.LinearAlgebra.Vector +import Control.Monad +import Text.OpenMath.Dictionary.Linalg2 + +------------------------------------------------------- +-- Conversion to the Expr data type + +instance IsExpr a => IsExpr (Matrix a) where + toExpr = + let f = function matrixrowSymbol . map toExpr + in function matrixSymbol . map f . rows + fromExpr a = do + rs <- isSymbol matrixSymbol a + xss <- mapM (isSymbol matrixrowSymbol) rs + yss <- mapM (mapM fromExpr) xss + guard (isRectangular yss) + return (makeMatrix yss) + +instance IsExpr a => IsExpr (Vector a) where + toExpr = function vectorSymbol . map toExpr . toList + fromExpr expr = do + xs <- isSymbol vectorSymbol expr + ys <- mapM fromExpr xs + return (fromList ys) + +instance IsExpr a => IsExpr (VectorSpace a) where + toExpr = toExpr . vectors + fromExpr expr = do + xs <- fromExpr expr + guard (sameDimension xs) + return (makeVectorSpace xs) diff --git a/src/Domain/LinearAlgebra/Vector.hs b/src/Domain/LinearAlgebra/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Domain/LinearAlgebra/Vector.hs @@ -0,0 +1,144 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.LinearAlgebra.Vector + ( Vector, VectorSpace + , makeVectorSpace, vectors, sameDimension, gramSchmidt + , fromList, toList, liftV, liftV2, showVectorWith + , toUnit, isUnit, isZero, makeOrthogonal, orthogonal, orthonormalList + , scale, norm, distance, vectorSum, innerProduct, dimension + ) where + +import Control.Monad +import Common.Traversable +import Data.List + +------------------------------------------------------------------------------- +-- Data types + +newtype Vector a = V [a] + deriving (Eq, Ord) + +newtype VectorSpace a = VS [Vector a] + deriving (Eq, Ord) + +------------------------------------------------------------------------------- +-- Instances + +instance Functor Vector where + fmap f (V xs) = V (map f xs) + +instance Once Vector where + onceM f (V xs) = liftM V (onceM f xs) + +instance Switch Vector where + switch (V xs) = liftM V (switch xs) + +instance Show a => Show (Vector a) where + show = showVectorWith show + +instance Num a => Num (Vector a) where + (+) = liftV2 (+) + (*) = liftV2 (*) + (-) = liftV2 (-) + negate = liftV negate + abs = liftV abs + signum = liftV signum + fromInteger = fromList . return . fromInteger + +instance Functor VectorSpace where + fmap f (VS xs) = VS (map (fmap f) xs) + +instance Show a => Show (VectorSpace a) where + show = show . vectors + +------------------------------------------------------------------------------- +-- Vector Space operations + +-- Check whether all vectors have same dimension +sameDimension :: [Vector a] -> Bool +sameDimension xs = + case map dimension xs of + [] -> True + n:ns -> all (==n) ns + +-- | Checks that all vectors in vector space have same dimension +makeVectorSpace :: [Vector a] -> VectorSpace a +makeVectorSpace xs + | sameDimension xs = VS xs + | otherwise = error "makeVectorSpace: different dimensions" + +vectors :: VectorSpace a -> [Vector a] +vectors (VS xs) = xs + +gramSchmidt :: Floating a => VectorSpace a -> VectorSpace a +gramSchmidt (VS xs) = VS (reverse (foldr op [] xs)) + where + op a as = toUnit (foldr makeOrthogonal a as):as + +------------------------------------------------------------------------------- +-- Vector operations + +showVectorWith :: (a -> String) -> Vector a -> String +showVectorWith f (V xs) = "(" ++ concat (intersperse "," (map f xs)) ++ ")" + +toList :: Vector a -> [a] +toList (V xs) = xs + +fromList :: [a] -> Vector a +fromList = V + +-- local helper function +liftV :: (a -> b) -> Vector a -> Vector b +liftV op = fromList . map op . toList + +-- local helper function +liftV2 :: (a -> b -> c) -> Vector a -> Vector b -> Vector c +liftV2 op v1 v2 = fromList $ zipWith op (toList v1) (toList v2) + +toUnit :: Floating a => Vector a -> Vector a +toUnit v = scale (1 / norm v) v + +isUnit :: Floating a => Vector a -> Bool +isUnit v = norm v == 1 + +isZero :: Num a => Vector a -> Bool +isZero = all (==0) . toList + +makeOrthogonal :: Num a => Vector a -> Vector a -> Vector a +makeOrthogonal v1 v2 = v2 - scale (innerProduct v1 v2) v1 + +orthogonal :: Num a => Vector a -> Vector a -> Bool +orthogonal v1 v2 = innerProduct v1 v2 == 0 + +scale :: Num a => a -> Vector a -> Vector a +scale a = liftV (*a) + +orthonormalList :: Floating a => [Vector a] -> Bool +orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs + where + pairs = [ (a, b) | (i, a) <- zip [0..] xs, (j, b) <- zip [0..] xs, i < j ] + +-- length of the vector (also called norm) +norm :: Floating a => Vector a -> a +norm v = sqrt $ innerProduct v v + +distance :: Floating a => Vector a -> Vector a -> a +distance v1 v2 = norm (v1 - v2) + +vectorSum :: Num a => Vector a -> a +vectorSum = sum . toList + +innerProduct :: Num a => Vector a -> Vector a -> a +innerProduct v1 v2 = vectorSum (v1 * v2) + +dimension :: Vector a -> Int +dimension = length . toList diff --git a/src/Domain/Logic.hs b/src/Domain/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic + ( module Domain.Logic.Formula + , module Domain.Logic.Generator + , module Domain.Logic.Parser + , module Domain.Logic.Strategies + , module Domain.Logic.Rules + , module Domain.Logic.BuggyRules + , module Domain.Logic.GeneralizedRules + , module Domain.Logic.Exercises + , module Domain.Logic.FeedbackText + ) where + +import Domain.Logic.Formula +import Domain.Logic.Generator +import Domain.Logic.Parser +import Domain.Logic.Strategies +import Domain.Logic.Rules +import Domain.Logic.BuggyRules +import Domain.Logic.GeneralizedRules +import Domain.Logic.Exercises +import Domain.Logic.FeedbackText + diff --git a/src/Domain/Logic/BuggyRules.hs b/src/Domain/Logic/BuggyRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/BuggyRules.hs @@ -0,0 +1,222 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Buggy rules in the logic domain, expressing common misconceptions +-- +----------------------------------------------------------------------------- +module Domain.Logic.BuggyRules where + +import Domain.Logic.Formula +import Domain.Logic.Generator() +import Domain.Logic.Rules (makeGroup) +import Common.Rewriting +import Common.Transformation + +-- Collection of all known buggy rules +buggyRules :: [Rule SLogic] +buggyRules = makeGroup "Common misconceptions" + [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui + , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3 + , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3 + , buggyRuleDeMorgan4, buggyRuleDeMorgan5, buggyRuleNotOverImpl, buggyRuleParenth1, buggyRuleParenth2 + , buggyRuleParenth3, buggyRuleAssoc, buggyRuleAbsor + , buggyRuleAndSame, buggyRuleAndCompl, buggyRuleOrSame, buggyRuleOrCompl + , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot + ] + +----------------------------------------------------------------------------- +-- Buggy rules + +buggyRuleAndSame :: Rule SLogic +buggyRuleAndSame = buggyRule $ rule "AndSame" $ + \x -> x :&&: x :~> T + +buggyRuleAndCompl :: Rule SLogic +buggyRuleAndCompl = buggyRule $ ruleList "AndComplBuggy" + [ \x -> x :&&: Not x :~> T + , \x -> Not x :&&: x :~> T + , \x -> x :&&: Not x :~> x + , \x -> Not x :&&: x :~> x + ] + +buggyRuleOrSame :: Rule SLogic +buggyRuleOrSame = buggyRule $ rule "OrSame" $ + \x -> x :||: x :~> T + +buggyRuleOrCompl :: Rule SLogic +buggyRuleOrCompl = buggyRule $ ruleList "OrComplBuggy" + [ \x -> x :||: Not x :~> F + , \x -> Not x :||: x :~> F + , \x -> x :||: Not x :~> x + , \x -> Not x :||: x :~> x + ] + +buggyRuleTrueProp :: Rule SLogic +buggyRuleTrueProp = buggyRule $ ruleList "TrueProp" + [ \x -> x :||: T :~> x + , \x -> T :||: x :~> x + , \x -> x :&&: T :~> T + , \x -> T :&&: x :~> T + ] + +buggyRuleFalseProp :: Rule SLogic +buggyRuleFalseProp = buggyRule $ ruleList "FalseProp" + [ \x -> x :||: F :~> F + , \x -> F :||: x :~> F + , \x -> x :&&: F :~> x + , \x -> F :&&: x :~> x + ] + +buggyRuleCommImp :: Rule SLogic +buggyRuleCommImp = buggyRule $ rule "CommImp" $ + \x y -> x :->: y :~> y :->: x --this does not hold: T->T => T->x + +buggyRuleAssImp :: Rule SLogic +buggyRuleAssImp = buggyRule $ ruleList "AssImp" + [ \x y z -> x :->: (y :->: z) :~> (x :->: y) :->: z + , \x y z -> (x :->: y) :->: z :~> x :->: (y :->: z) + ] + +buggyRuleIdemImp :: Rule SLogic +buggyRuleIdemImp = buggyRule $ rule "IdemImp" $ + \x -> x :->: x :~> x + +buggyRuleIdemEqui :: Rule SLogic +buggyRuleIdemEqui = buggyRule $ rule "IdemEqui" $ + \x -> x :<->: x :~> x + +buggyRuleEquivElim1 :: Rule SLogic +buggyRuleEquivElim1 = buggyRule $ ruleList "BuggyEquivElim1" + [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (x :&&: y) + , \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :||: Not y) + ] + +buggyRuleEquivElim2 :: Rule SLogic +buggyRuleEquivElim2 = buggyRule $ ruleList "BuggyEquivElim2" + [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y) + , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y) + ] + +buggyRuleEquivElim3 :: Rule SLogic +buggyRuleEquivElim3 = buggyRule $ rule "EquivElim3" $ + \x y -> x :<->: y :~> Not x :||: y + +buggyRuleImplElim :: Rule SLogic +buggyRuleImplElim = buggyRule $ ruleList "BuggyImplElim" + [\x y -> x :->: y :~> Not (x :||: y) + ,\x y -> x :->: y :~> (x :||: y) + ,\x y -> x :->: y :~> Not (x :&&: y) + ] + +buggyRuleImplElim1 :: Rule SLogic +buggyRuleImplElim1 = buggyRule $ rule "BuggyImplElim1" $ + \x y -> x :->: y :~> Not x :&&: y + +buggyRuleImplElim2 :: Rule SLogic +buggyRuleImplElim2 = buggyRule $ rule "BuggyImplElim2" $ + \x y -> x :->: y :~> (x :&&: y) :||: (Not x :&&: Not y) + +buggyRuleDeMorgan1 :: Rule SLogic +buggyRuleDeMorgan1 = buggyRule $ ruleList "BuggyDeMorgan1" + [ \x y -> Not (x :&&: y) :~> Not x :||: y + , \x y -> Not (x :&&: y) :~> x :||: Not y + , \x y -> Not (x :&&: y) :~> x :||: y + , \x y -> Not (x :||: y) :~> Not x :&&: y + , \x y -> Not (x :||: y) :~> x :&&: Not y + , \x y -> Not (x :||: y) :~> x :&&: y + ] + +buggyRuleDeMorgan2 :: Rule SLogic +buggyRuleDeMorgan2 = buggyRule $ ruleList "BuggyDeMorgan2" + [ \x y -> Not (x :&&: y) :~> Not (Not x :||: Not y) + , \x y -> Not (x :||: y) :~> Not (Not x :&&: Not y) --note the firstNot in both formulas! + ] +buggyRuleDeMorgan3 :: Rule SLogic +buggyRuleDeMorgan3 = buggyRule $ rule "BuggyDeMorgan3" $ + \x y -> Not (x :&&: y) :~> Not x :&&: Not y + +buggyRuleDeMorgan4 :: Rule SLogic +buggyRuleDeMorgan4 = buggyRule $ rule "BuggyDeMorgan4" $ + \x y -> Not (x :||: y) :~> Not x :||: Not y + +buggyRuleDeMorgan5 :: Rule SLogic +buggyRuleDeMorgan5 = buggyRule $ ruleList "BuggyDeMorgan5" + [ \x y z -> Not (Not (x :&&: y) :||: z) :~> Not (Not x :||: Not y):||: z + , \x y z -> Not (Not (x :&&: y) :&&: z) :~> Not (Not x :||: Not y):&&: z + , \x y z -> Not (Not (x :||: y) :||: z) :~> Not (Not x :&&: Not y):||: z + , \x y z -> Not (Not (x :||: y) :&&: z) :~> Not (Not x :&&: Not y):&&: z + ] + +buggyRuleNotOverImpl :: Rule SLogic +buggyRuleNotOverImpl = buggyRule $ rule "BuggyNotOverImpl" $ + \x y -> Not (x :->: y) :~> Not x :->: Not y + +buggyRuleParenth1 :: Rule SLogic +buggyRuleParenth1 = buggyRule $ ruleList "BuggyParenth1" + [ \x y -> Not (x :&&: y) :~> Not x :&&: y + , \x y -> Not (x :||: y) :~> Not x :||: y + ] + +buggyRuleParenth2 :: Rule SLogic +buggyRuleParenth2 = buggyRule $ rule "BuggyParenth2" $ + \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y) + +buggyRuleParenth3 :: Rule SLogic +buggyRuleParenth3 = buggyRule $ ruleList "BuggyParenth3" + [ \x y -> Not (Not x :&&: y) :~> x :&&: y + , \x y -> Not (Not x :||: y) :~> x :||: y + , \x y -> Not (Not x :->: y) :~> x :->: y + , \x y -> Not (Not x :<->: y) :~> x :<->: y + ] + + +buggyRuleAssoc :: Rule SLogic +buggyRuleAssoc = buggyRule $ ruleList "BuggyAssoc" + [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z + , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z) + , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z) + , \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: z + ] + +buggyRuleAbsor :: Rule SLogic +buggyRuleAbsor = buggyRule $ ruleList "BuggyAbsor" + [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y) + , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y) + , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y) + , \x y z -> (x :&&: y) :&&: ((x :||: y) :||: z) :~> (x :&&: y) + ] + +buggyRuleDistr :: Rule SLogic +buggyRuleDistr = buggyRule $ ruleList "BuggyDistr" + [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :&&: (x :&&: z) + , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :&&: (y :&&: z) + , \x y z -> x :&&: (y :||: z) :~> (x :||: y) :&&: (x :||: z) + , \x y z -> (x :||: y) :&&: z :~> (x :||: z) :&&: (y :||: z) + , \x y z -> x :||: (y :&&: z) :~> (x :||: y) :||: (x :||: z) + , \x y z -> (x :&&: y) :||: z :~> (x :||: z) :||: (y :||: z) + , \x y z -> x :||: (y :&&: z) :~> (x :&&: y) :||: (x :&&: z) + , \x y z -> (x :&&: y) :||: z :~> (x :&&: z) :||: (y :&&: z) + ] + +buggyRuleDistrNot :: Rule SLogic +buggyRuleDistrNot = buggyRule $ ruleList "BuggyDistrNot" + [ \x y z -> Not x :&&: (y :||: z) :~> (Not x :&&: y) :||: (x :&&: z) + , \x y z -> Not x :&&: (y :||: z) :~> (x :&&: y) :||: (Not x :&&: z) + , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: Not z) :||: (y :&&: z) + , \x y z -> (x :||: y) :&&: Not z :~> (x :&&: z) :||: (y :&&: Not z) + , \x y z -> Not x :||: (y :&&: z) :~> (Not x :||: y) :&&: (x :||: z) + , \x y z -> Not x :||: (y :&&: z) :~> (x :||: y) :&&: (Not x :||: z) + , \x y z -> (x :&&: y) :||: Not z :~> (x :||: Not z) :&&: (y :||: z) + , \x y z -> (x :&&: y) :||: Not z :~> (x :||: z) :&&: (y :||: Not z) + ] diff --git a/src/Domain/Logic/Exercises.hs b/src/Domain/Logic/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Exercises.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exercise for the logic domain, used for the OUNL course +-- "Discrete Wiskunde A (DWA)" +-- +----------------------------------------------------------------------------- +module Domain.Logic.Exercises + ( dnfExercise, dnfUnicodeExercise + ) where + +import Common.Context +import Common.Derivation +import Common.Exercise +import Common.Rewriting (differenceMode) +import Common.Strategy +import Data.Maybe +import Domain.Logic.BuggyRules +import Domain.Logic.Formula +import Domain.Logic.Generator +import Domain.Logic.Parser +import Domain.Logic.Rules +import Domain.Logic.Strategies +import Test.QuickCheck +import Text.Parsing (fromRanged) + +-- Currently, we use the DWA strategy +dnfExercise :: Exercise SLogic +dnfExercise = makeExercise + { description = "Proposition to DNF" + , exerciseCode = makeCode "logic" "dnf" + , status = Stable + , parser = either Left (Right . fromRanged) . parseLogicPars + , prettyPrinter = ppLogicPars + , equivalence = eqLogic + , similarity = equalLogicA + , isReady = isDNF + , isSuitable = suitable + , extraRules = map liftToContext (logicRules ++ buggyRules) + , strategy = dnfStrategyDWA + , difference = differenceMode eqLogic + , testGenerator = Just (restrictGenerator suitable generateLogic) + , randomExercise = useGenerator (const True) logicExercise + } + +-- Direct support for unicode characters +dnfUnicodeExercise :: Exercise SLogic +dnfUnicodeExercise = dnfExercise + { description = description dnfExercise ++ " (unicode support)" + , exerciseCode = makeCode "logic" "dnf-unicode" + , parser = either Left (Right . fromRanged) . parseLogicUnicodePars + , prettyPrinter = ppLogicUnicodePars + } + +logicExercise :: Int -> Gen SLogic +logicExercise n = + let (gen, (minStep, maxStep)) + | n == 1 = generateLevel Easy + | n == 3 = generateLevel Difficult + | otherwise = generateLevel Normal + ok p = let n = fromMaybe maxBound (stepsRemaining maxStep p) + in countEquivalences p <= 2 && n >= minStep && n <= maxStep + in restrictGenerator ok gen + +suitable :: SLogic -> Bool +suitable = (<=2) . countEquivalences + +stepsRemaining :: Int -> SLogic -> Maybe Int +stepsRemaining i = + lengthMax i . derivationTree dnfStrategyDWA . inContext + +-- QuickCheck property to monitor the number of steps needed +-- to normalize a random proposition (30-40% is ok) +{- +testGen :: Property +testGen = forAll generateLogic $ \p -> + let n = steps p + in countEquivalences p <= 2 ==> label (show (n >= 4 && n <= 12)) True + +testme :: IO () +testme = quickCheck testGen + + +import Service.TypedAbstractService + +start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r)) + where + (p, q, r, s) = (Var "p", Var "q", Var "r", Var "s") + +go = derivation . emptyState dnfExercise +-} diff --git a/src/Domain/Logic/FeedbackText.hs b/src/Domain/Logic/FeedbackText.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/FeedbackText.hs @@ -0,0 +1,196 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Feedback messages reported for the logic domain. Content to be provided +-- by Josje Lodder. +-- +----------------------------------------------------------------------------- +module Domain.Logic.FeedbackText + ( feedbackSyntaxError, ruleText, appliedRule + , feedbackBuggy, feedbackNotEquivalent + , feedbackSame + , feedbackOk, feedbackDetour, feedbackUnknown + ) where + +import Data.Maybe +import Text.Parsing +import Common.Transformation +import Domain.Logic.Rules +import Domain.Logic.BuggyRules + +-- This is more general than the logic domain. Perhaps it should +-- be defined elsewhere +feedbackSyntaxError :: SyntaxError -> String +feedbackSyntaxError syntaxError = + case syntaxError of + ParNotClosed token -> + "Opening parenthesis symbol '(' at position " ++ tokenPos token ++ " is not closed." + ParNoOpen token -> + "Closing parenthesis symbol ')' at position " ++ tokenPos token ++ " has no matching opening parenthesis." + ParMismatch token1 token2 -> + "The openening parenthesis at position " ++ tokenPos token1 ++ + " does not match with the closing parenthesis at position " ++ tokenPos token2 ++ "." + ErrorMessage txt -> + txt + Unexpected token -> + "Unexpected " ++ showToken token + +feedbackBuggy :: Bool -> [Rule a] -> String +feedbackBuggy ready [br] + | br ~= buggyRuleCommImp = + f "Did you think that implication is commutative? This is not the case. " + | br ~= buggyRuleAssImp = + f "Did you think that implication is associative? This is not the case. " + | br ~= buggyRuleImplElim2 = + f "Make sure that you use the rule for implication elimanation, you seemed to use equivalence elimination " + | br ~= buggyRuleEquivElim3 = + f "Make sure that you use the rule for equivalence elimanation, you seemed to use implication elimination " + | br ~= buggyRuleIdemImp = + f "Did you think that implication is idempotent? This is not the case. " + | br ~= buggyRuleIdemEqui = + f "Did you think that equivalence is idempotent? This is not the case. " + | br ~= buggyRuleAndSame = + f "Did you think that phi AND phi is equivalent to True? This is not the case. Idempotency of AND means that phi AND phi is equivalent to phi. " + | br ~= buggyRuleOrSame = + f "Did you think that phi OR phi is equivalent to True? This is not the case. Idempotency of OR means that phi OR phi is equivalent to phi. " + | br ~= buggyRuleAndCompl = + f "Be careful in the application of the the complement-rules " + | br ~= buggyRuleOrCompl = + f "Be careful in the application of the the complement-rules " + | br ~= buggyRuleTrueProp = + f "Be careful in the application of the the True-False rules " + | br ~= buggyRuleFalseProp = + f "Be careful in the application of the the True-False rules " + | br ~= buggyRuleEquivElim1 = + f "Be careful with the elimination of an equivalence; take care of the negations. " + | br ~= buggyRuleEquivElim2 = + f "Be careful with the elimination of an equivalence; make sure that the disjunctions and the conjunctions are at the right place. " + | br ~= buggyRuleImplElim = + f "Be careful with the elimination of an implication; make sure the negation is at the right place. " + | br ~= buggyRuleImplElim1 = + f "Did you try to eliminate an implication? In that case you used an AND instead of an OR " + | br ~= buggyRuleDeMorgan1 = + f "Did you try to apply DeMorgan? Be careful with the negations. " + | br ~= buggyRuleDeMorgan2 = + f "Did you try to apply DeMorgan? Make sure that you remove the outer negation when applying this rule " + | br ~= buggyRuleDeMorgan3 = + f "Did you try to apply DeMorgan? Make sure that you replace AND by OR. " + | br ~= buggyRuleDeMorgan4 = + f "Did you try to apply DeMorgan? Make sure that you replace OR by AND. " + | br ~= buggyRuleDeMorgan5 = + f "Did you try to apply DeMorgan? Take care of the scope of the negations. " + | br ~= buggyRuleNotOverImpl = + f "Did you think that you can distribute a negation over an implication? This is not the case. " + | br ~= buggyRuleParenth1 = + f "Take care of the negations and the parentheses. " + | br ~= buggyRuleParenth2 = + f "Take care of the outer negation when you eliminate an equivalence. " + | br ~= buggyRuleParenth3 = + f "Did you try to apply double negation? At this place this is not allowed, because of the parenthesis between the negations. " + | br ~= buggyRuleAssoc = + f "Did you change the parentheses? This is not allowed in a subformula consisting of a disjunction and a conjunction. " + | br ~= buggyRuleAbsor = + f "Did you try to apply absorption? You cant't apply this rule at this place since the resulting sub formula is not a subformula of the bigger term. " + | br ~= buggyRuleDistr = + f "Did you try to apply distribution? Take care of the place of the disjunctions and the conjunctions. " + | br ~= buggyRuleDistrNot = + f "Did you try to apply distribution? Don't forget the negations!. " + where f = incorrect ready +feedbackBuggy ready _ = incorrect ready "" + +feedbackNotEquivalent :: Bool -> String +feedbackNotEquivalent ready = incorrect ready "" + +feedbackSame :: String +feedbackSame = "You have submitted a similar term. " ++ + "Maybe you inserted or removed parentheses (the tool supports associativity)?" + +feedbackOk :: [Rule a] -> (String, Bool) +feedbackOk [one] = (okay (appliedRule one), True) +feedbackOk _ = ("You have combined multiple steps. Press the Back button and perform one step at the time.", False) + +-- TODO Bastiaan: welke regel wordt er dan verwacht door de strategie? +feedbackDetour :: Bool -> Maybe (Rule a) -> [Rule a] -> (String, Bool) +feedbackDetour True _ [one] = (appliedRule one ++ " " ++ feedbackFinished, True) +feedbackDetour True _ _ = (feedbackMultipleSteps ++ " " ++ feedbackFinished, True) +feedbackDetour _ _ [one] | one `inGroup`"Commutativity" = + ("You have applied one of the commutativity rules correctly. This step is not mandatory, but sometimes helps to simplify the formula.", True) +feedbackDetour _ mexp [one] = + let however = case mexp >>= ruleText of + Just s -> "However, the standard strategy suggests to use " ++ s ++ "." + Nothing -> "However, the standard strategy suggests a different step." + in (appliedRule one ++ " This is correct. " ++ however, True) +feedbackDetour ready _ _ = (feedbackUnknown ready, False) + +feedbackUnknown :: Bool -> String +feedbackUnknown ready = feedbackMultipleSteps ++ " " ++ backAndHint ready + +feedbackMultipleSteps :: String +feedbackMultipleSteps = "You have combined multiple steps (or made a mistake)." + +feedbackFinished :: String +feedbackFinished = "Are you aware that you already reached disjunctive normal form?" + +appliedRule :: Rule a -> String +appliedRule r = "You have applied " ++ txt ++ " correctly." + where txt = fromMaybe "some rule" (ruleText r) + +ruleText :: Rule a -> Maybe String +ruleText r + | r ~= ruleFalseZeroOr || r ~= ruleTrueZeroOr || r ~= ruleFalseZeroAnd || r ~= ruleTrueZeroAnd || r ~= ruleNotTrue || r ~= ruleNotFalse = + return "one of the False/True rules" + | r ~= ruleComplOr || r ~= ruleComplAnd = return "a complement rule" + | r ~= ruleNotNot = return "double negation" + | r ~= ruleDefImpl = return "implication elimination" + | r ~= ruleDefEquiv = return "equivalence elimination" + | r `inGroup`"Commutativity" = return "commutativity" + | r `inGroup`"Aasociativity" = return "associativity" + | r `inGroup`"DistributionOrOverAnd" = return "distribution of or over and" + | r `inGroup`"DistributionAndOverOr" = return "distribution of and over or" + | r `inGroup`"Idempotency" = return "idempotency" + | r `inGroup`"Absorption" = return "absorption" + | r `inGroup`"De Morgan" = return "De Morgan" + | r `inGroup`"InverseDeMorgan" = return "De Morgan" + | r `inGroup`"InverseDistr" = return "distributivity" + -- TODO Josje: aanvullen met alle regels (ook die ook in de DWA strategie voorkomen) + | otherwise = Nothing +------------------------------------------------------------------------- +-- General text + +incorrect :: Bool -> String -> String +incorrect ready s = "This is incorrect. " ++ s ++ backAndHint ready + +okay :: String -> String +okay s = "Well done! " ++ s + +backAndHint :: Bool -> String +backAndHint ready = "Press the Back button and try again." ++ + if ready then "" else " You may ask for a hint." + +------------------------------------------------------------------------- +-- Helper functions + +(~=) :: Rule a -> Rule b -> Bool +r1 ~= r2 = name r1 == name r2 + +-- Quick and dirty fix! +inGroup :: Rule a -> String -> Bool +inGroup r n = + let rs = filter (~= r) (logicRules ++ buggyRules) + in n `elem` concatMap ruleGroups rs + +showToken :: Token -> String +showToken token = tokenText token ++ " at position " ++ tokenPos token + +tokenPos :: Token -> String +tokenPos token = + let p@(l, c) = toPosition token + in if l==1 then show c else show p + diff --git a/src/Domain/Logic/Formula.hs b/src/Domain/Logic/Formula.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Formula.hs @@ -0,0 +1,174 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Formula where + +import Common.Uniplate (Uniplate(..), universe) +import Common.Rewriting +import Common.Utils +import Data.List +import Data.Maybe + +infixr 2 :<->: +infixr 3 :->: +infixr 4 :||: +infixr 5 :&&: + +-- | The data type Logic is the abstract syntax for the domain +-- | of logic expressions. +data Logic a = Var a + | Logic a :->: Logic a -- implication + | Logic a :<->: Logic a -- equivalence + | Logic a :&&: Logic a -- and (conjunction) + | Logic a :||: Logic a -- or (disjunction) + | Not (Logic a) -- not + | T -- true + | F -- false + deriving (Show, Eq, Ord) + +-- | For simple use, we assume the variables to be strings +type SLogic = Logic String + +instance Functor Logic where + fmap f = foldLogic (Var . f, (:->:), (:<->:), (:&&:), (:||:), Not, T, F) + +-- | The type LogicAlg is the algebra for the data type Logic +-- | Used in the fold for Logic. +type LogicAlg b a = (b -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a, a) + +-- | foldLogic is the standard fold for Logic. +foldLogic :: LogicAlg b a -> Logic b -> a +foldLogic (var, impl, equiv, and, or, not, true, false) = rec + where + rec logic = + case logic of + Var x -> var x + p :->: q -> rec p `impl` rec q + p :<->: q -> rec p `equiv` rec q + p :&&: q -> rec p `and` rec q + p :||: q -> rec p `or` rec q + Not p -> not (rec p) + T -> true + F -> false + +-- | evalLogic takes a function that gives a logic value to a variable, +-- | and a Logic expression, and evaluates the boolean expression. +evalLogic :: (a -> Bool) -> Logic a -> Bool +evalLogic env = foldLogic (env, impl, (==), (&&), (||), not, True, False) + where + impl p q = not p || q + +-- | eqLogic determines whether or not two Logic expression are logically +-- | equal, by evaluating the logic expressions on all valuations. +eqLogic :: Eq a => Logic a -> Logic a -> Bool +eqLogic p q = all (\f -> evalLogic f p == evalLogic f q) fs + where + xs = varsLogic p `union` varsLogic q + fs = map (flip elem) (subsets xs) + +-- | Functions noNot, noOr, and noAnd determine whether or not a Logic +-- | expression contains a not, or, and and constructor, respectively. +noNot, noOr, noAnd :: Logic a -> Bool +noNot = foldLogic (const True, (&&), (&&), (&&), (&&), const False, True, True) +noOr = foldLogic (const True, (&&), (&&), (&&), \_ _ -> False, id, True, True) +noAnd = foldLogic (const True, (&&), (&&), \_ _ -> False, (&&), id, True, True) + +-- | A Logic expression is atomic if it is a variable or a constant True or False. +isAtomic :: Logic a -> Bool +isAtomic logic = + case logic of + Var _ -> True + Not (Var _) -> True + T -> True + F -> True + _ -> False + +-- | Functions isDNF, and isCNF determine whether or not a Logix expression +-- | is in disjunctive normal form, or conjunctive normal form, respectively. +isDNF, isCNF :: Logic a -> Bool +isDNF = all isAtomic . concatMap conjunctions . disjunctions +isCNF = all isAtomic . concatMap disjunctions . conjunctions + +-- | Function disjunctions returns all Logic expressions separated by an or +-- | operator at the top level. +disjunctions :: Logic a -> [Logic a] +disjunctions = collectWithOperator orOperator + +-- | Function conjunctions returns all Logic expressions separated by an and +-- | operator at the top level. +conjunctions :: Logic a -> [Logic a] +conjunctions = collectWithOperator andOperator + +-- | Count the number of implicationsations :: Logic -> Int +countImplications :: Logic a -> Int +countImplications p = length [ () | _ :->: _ <- universe p ] + +-- | Count the number of equivalences +countEquivalences :: Logic a -> Int +countEquivalences p = length [ () | _ :<->: _ <- universe p ] + +-- | Count the number of binary operators +countBinaryOperators :: Logic a -> Int +countBinaryOperators = foldLogic (const 0, binop, binop, binop, binop, id, 0, 0) + where binop x y = x + y + 1 + +-- | Count the number of double negations +countDoubleNegations :: Logic a -> Int +countDoubleNegations p = length [ () | Not (Not _) <- universe p ] + +-- | Function varsLogic returns the variables that appear in a Logic expression. +varsLogic :: Eq a => Logic a -> [a] +varsLogic p = nub [ s | Var s <- universe p ] + +instance Uniplate (Logic a) where + uniplate p = + case p of + p :->: q -> ([p, q], \[a, b] -> a :->: b) + p :<->: q -> ([p, q], \[a, b] -> a :<->: b) + p :&&: q -> ([p, q], \[a, b] -> a :&&: b) + p :||: q -> ([p, q], \[a, b] -> a :||: b) + Not p -> ([p], \[a] -> Not a) + _ -> ([], \[] -> p) + +instance Eq a => ShallowEq (Logic a) where + shallowEq expr1 expr2 = + case (expr1, expr2) of + (Var a, Var b) -> a==b + (_ :->: _ , _ :->: _ ) -> True + (_ :<->: _, _ :<->: _) -> True + (_ :&&: _ , _ :&&: _ ) -> True + (_ :||: _ , _ :||: _ ) -> True + (Not _ , Not _ ) -> True + (T , T ) -> True + (F , F ) -> True + _ -> False + +instance MetaVar a => MetaVar (Logic a) where + isMetaVar (Var a) = isMetaVar a + isMetaVar _ = Nothing + metaVar = Var . metaVar + +logicOperators :: Operators (Logic a) +logicOperators = [andOperator, orOperator] + +-- The "and" operator is also commutative, but not (yet) in the equational theory +andOperator :: Operator (Logic a) +andOperator = associativeOperator (:&&:) isAnd + where + isAnd (p :&&: q) = Just (p, q) + isAnd _ = Nothing + +-- The "or" operator is also commutative, but not (yet) in the equational theory +orOperator :: Operator (Logic a) +orOperator = associativeOperator (:||:) isOr + where + isOr (p :||: q) = Just (p, q) + isOr _ = Nothing diff --git a/src/Domain/Logic/GeneralizedRules.hs b/src/Domain/Logic/GeneralizedRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/GeneralizedRules.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Generalized rules, and inverse rules, for De Morgan and distributivity +-- +----------------------------------------------------------------------------- +module Domain.Logic.GeneralizedRules + ( generalRules, inverseRules + , generalRuleDeMorganOr, generalRuleDeMorganAnd + , generalRuleAndOverOr, generalRuleOrOverAnd + , inverseDeMorganOr, inverseDeMorganAnd + , inverseAndOverOr, inverseOrOverAnd + ) where + +-- Note: the generalized rules do not take AC-unification into account, +-- and perhaps they should. +import Domain.Logic.Formula +import Common.Transformation +import Control.Monad + +generalRules :: [Rule SLogic] +generalRules = + [ generalRuleDeMorganOr, generalRuleDeMorganAnd + , generalRuleAndOverOr, generalRuleOrOverAnd + ] + +inverseRules :: [Rule SLogic] +inverseRules = + [ inverseDeMorganOr, inverseDeMorganAnd + , inverseAndOverOr, inverseOrOverAnd + ] + +----------------------------------------------------------------------------- +-- Inverse rules + +-- generalized (works for multiple terms) +inverseDeMorganOr :: Rule SLogic +inverseDeMorganOr = makeSimpleRule "InvDeMorganOr" $ \p -> do + let xs = conjunctions p + guard (length xs > 1) + ys <- mapM isNot xs + return (Not $ foldr1 (:||:) ys) + +-- generalized (works for multiple terms) +inverseDeMorganAnd :: Rule SLogic +inverseDeMorganAnd = makeSimpleRule "InvDeMorganAnd" $ \p -> do + let xs = disjunctions p + guard (length xs > 1) + ys <- mapM isNot xs + return (Not $ foldr1 (:&&:) ys) + +inverseAndOverOr :: Rule SLogic +inverseAndOverOr = makeSimpleRule "InvAndOverOr" $ \p -> do + let xs = disjunctions p + guard (length xs > 1) + do pairs <- mapM isAndHead xs + let (as, ys) = unzip pairs + guard (allSame as) + return (head as :&&: foldr1 (:||:) ys) + `mplus` do + pairs <- mapM isAndLast xs + let (ys, as) = unzip pairs + guard (allSame as) + return (foldr1 (:||:) ys :&&: head as) + +inverseOrOverAnd :: Rule SLogic +inverseOrOverAnd = makeSimpleRule "InvOrOverAnd" $ \p -> do + let xs = conjunctions p + guard (length xs > 1) + do pairs <- mapM isOrHead xs + let (as, ys) = unzip pairs + guard (allSame as) + return (head as :||: foldr1 (:&&:) ys) + `mplus` do + pairs <- mapM isOrLast xs + let (ys, as) = unzip pairs + guard (allSame as) + return (foldr1 (:&&:) ys :||: head as) + +isNot :: SLogic -> Maybe SLogic +isNot (Not p) = Just p +isNot _ = Nothing + +isAndHead, isAndLast, isOrHead, isOrLast :: SLogic -> Maybe (SLogic, SLogic) +isAndHead = useHead (:&&:) . conjunctions +isAndLast = useLast (:&&:) . conjunctions +isOrHead = useHead (:||:) . disjunctions +isOrLast = useLast (:||:) . disjunctions + +useHead, useLast :: (a -> a -> a) -> [a] -> Maybe (a, a) +useHead op (x:xs) | not (null xs) = + Just (x, foldr1 op xs) +useHead _ _ = Nothing + +useLast op = fmap (\(x, y) -> (y, x)) . useHead (flip op) . reverse + + +allSame :: Eq a => [a] -> Bool +allSame [] = True +allSame (x:xs) = all (==x) xs + +----------------------------------------------------------------------------- +-- Generalized rules + +generalRuleDeMorganOr :: Rule SLogic +generalRuleDeMorganOr = makeSimpleRule "GenDeMorganOr" f + where + f (Not e) = do + let xs = disjunctions e + guard (length xs > 2) + return (foldr1 (:&&:) (map Not xs)) + f _ = Nothing + +generalRuleDeMorganAnd :: Rule SLogic +generalRuleDeMorganAnd = makeSimpleRule "GenDeMorganAnd" f + where + f (Not e) = do + let xs = conjunctions e + guard (length xs > 2) + return (foldr1 (:||:) (map Not xs)) + f _ = Nothing + +generalRuleAndOverOr :: Rule SLogic +generalRuleAndOverOr = makeSimpleRule "GenAndOverOr" f + where + f (x :&&: y) = + case (disjunctions x, disjunctions y) of + (xs, _) | length xs > 2 -> + return (foldr1 (:||:) (map (:&&: y) xs)) + (_, ys) | length ys > 2 -> + return (foldr1 (:||:) (map (x :&&:) ys)) + _ -> Nothing + f _ = Nothing + +generalRuleOrOverAnd :: Rule SLogic +generalRuleOrOverAnd = makeSimpleRule "GenOrOverAnd" f + where + f (x :||: y) = + case (conjunctions x, conjunctions y) of + (xs, _) | length xs > 2 -> + return (foldr1 (:&&:) (map (:||: y) xs)) + (_, ys) | length ys > 2 -> + return (foldr1 (:&&:) (map (x :||:) ys)) + _ -> Nothing + f _ = Nothing diff --git a/src/Domain/Logic/Generator.hs b/src/Domain/Logic/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Generator.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Generator + ( generateLogic, generateLevel, equalLogicA, Level(..) + ) where + +import Domain.Logic.Formula +import Control.Monad +import Data.Char +import Test.QuickCheck hiding (defaultConfig) +import Common.Rewriting +import Common.Uniplate + +------------------------------------------------------------- +-- Code that doesn't belong here, but the arbitrary instance +-- is needed for the Rewrite instance. + +instance Rewrite SLogic where + operators = logicOperators + +-- | Equality modulo associativity of operators +equalLogicA:: SLogic -> SLogic -> Bool +equalLogicA = equalWith operators + +----------------------------------------------------------- +-- Logic generator + +data Level = Easy | Normal | Difficult + deriving Show + +generateLogic :: Gen SLogic +generateLogic = normalGenerator + +generateLevel :: Level -> (Gen SLogic, (Int, Int)) +generateLevel level = + case level of + Easy -> (easyGenerator, (3, 6)) + Normal -> (normalGenerator, (4, 12)) + Difficult -> (difficultGenerator, (7, 18)) + +-- Use the propositions with 3-6 steps +easyGenerator :: Gen SLogic +easyGenerator = do + n <- oneof [return 2, return 4] -- , return 8] + sizedGen True varGen n + +-- Use the propositions with 4-12 steps +normalGenerator :: Gen SLogic +normalGenerator = do + n <- return 4 -- oneof [return 4, return 8] + p0 <- sizedGen False varGen n + p1 <- preventSameVar varList p0 + return (removePartsInDNF p1) + +-- Use the propositions with 7-18 steps +difficultGenerator :: Gen SLogic +difficultGenerator = do + let vars = "s" : varList + n <- return 4 -- oneof [return 4, return 8] + p0 <- sizedGen False (oneof $ map return vars) n + p1 <- preventSameVar vars p0 + return (removePartsInDNF p1) + +varList :: [String] +varList = ["p", "q", "r"] + +varGen :: Gen String +varGen = oneof $ map return varList + +sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a) +sizedGen constants gen = go + where + go n + | n > 0 = + let rec = go (n `div` 2) + op2 f = liftM2 f rec rec + in frequency + [ (2, go 0) + , (2, op2 (:->:)) + , (1, op2 (:<->:)) + , (3, op2 (:&&:)) + , (3, op2 (:||:)) + , (3, liftM Not rec) + ] + | constants = frequency + [(5, liftM Var gen), (1, return T), (1, return F)] + | otherwise = liftM Var gen + +----------------------------------------------------------------- +-- Simple tricks for creating for "nice" logic propositions + +preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a) +preventSameVar xs = transformM $ \p -> + case uniplate p of + ([Var a, Var b], f) | a==b -> do + c <- oneof $ map return $ filter (/=a) xs + return $ f [Var a, Var c] + _ -> return p + +removePartsInDNF :: SLogic -> SLogic +removePartsInDNF = buildOr . filter (not . simple) . disjunctions + where + buildOr [] = T + buildOr xs = foldl1 (:||:) xs + + simple = all f . conjunctions + where + f (Not p) = null (children p) + f p = null (children p) + +----------------------------------------------------------- +--- QuickCheck generator + +instance Arbitrary SLogic where + arbitrary = sized (sizedGen True varGen) + coarbitrary logic = + case logic of + Var x -> variant 0 . coarbitrary (map ord x) + p :->: q -> variant 1 . coarbitrary p . coarbitrary q + p :<->: q -> variant 2 . coarbitrary p . coarbitrary q + p :&&: q -> variant 3 . coarbitrary p . coarbitrary q + p :||: q -> variant 4 . coarbitrary p . coarbitrary q + Not p -> variant 5 . coarbitrary p + T -> variant 6 + F -> variant 7 diff --git a/src/Domain/Logic/Parser.hs b/src/Domain/Logic/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Parser.hs @@ -0,0 +1,182 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Parser + ( parseLogic, parseLogicPars, parseLogicUnicodePars + , ppLogic, ppLogicPrio, ppLogicPars, ppLogicUnicodePars + ) where + +import Text.Parsing +import Control.Arrow +import Domain.Logic.Formula + +logicScanner :: Scanner +logicScanner = (makeCharsSpecial "~" defaultScanner) + { keywords = ["T", "F"] + , keywordOperators = "~" : concatMap (map fst . snd) operatorTable + } + +logicUnicodeScanner :: Scanner +logicUnicodeScanner = (makeCharsSpecial (concat unicodeSyms) defaultScanner) + { keywords = ["T", "F"] + , keywordOperators = unicodeSyms + } + +operatorTable :: OperatorTable SLogic +operatorTable = + [ (RightAssociative, [("<->", (:<->:))]) + , (RightAssociative, [("||", (:||:))]) + , (RightAssociative, [("/\\", (:&&:))]) + , (RightAssociative, [("->", (:->:))]) + ] + +----------------------------------------------------------- +--- Parser + +-- | Parser for logic formulas that respects all associativity and priority laws +-- | of the constructors +parseLogic :: String -> Either SyntaxError (Ranged SLogic) +parseLogic = analyseAndParse pLogic . scanWith logicScanner + where + pLogic = pOperators operatorTable (basicWithPos pLogic) + +-- | Parser for logic formulas that insists on more parentheses: "and" and "or" are associative, +-- | but implication and equivalence are not. Priorities of the operators are unknown, and thus +-- | parentheses have to be written explicitly. No parentheses are needed for Not (Not p). Superfluous +-- | parentheses are permitted +parseLogicPars :: String -> Either SyntaxError (Ranged SLogic) +parseLogicPars s + = either Left suspiciousVariable + $ left (ambiguousOperators parseLogic s) + $ analyseAndParse (pLogicGen asciiTuple) + $ scanWith logicScanner s + +parseLogicUnicodePars :: String -> Either SyntaxError (Ranged SLogic) +parseLogicUnicodePars s + = either Left suspiciousVariable + $ left (ambiguousOperators (parseLogic . concatMap f) s) + $ analyseAndParse (pLogicGen unicodeTuple) + $ scanWith logicUnicodeScanner s + where + -- quick fix (since we only need to know whether the parser succeeds) + f c | [c] == andUSym = andASym + | [c] == orUSym = orASym + | [c] == notUSym = notASym + | [c] == implUSym = implASym + | [c] == equivUSym = equivASym + | otherwise = [c] + +pLogicGen (impl, equiv, and, or, nt, tr, fl) = pLogic + where + pLogic = flip ($) <$> basic <*> optional composed id + basic = basicWithPosGen (nt, tr, fl) pLogic + composed = flip (binaryOp (:<->:)) <$ pKey equiv <*> basic + <|> flip (binaryOp (:->:)) <$ pKey impl <*> basic + <|> (\xs p -> foldr1 (binaryOp (:&&:)) (p:xs)) <$> pList1 (pKey and *> basic) + <|> (\xs p -> foldr1 (binaryOp (:||:)) (p:xs)) <$> pList1 (pKey or *> basic) + +basicWithPos :: Parser Token (Ranged SLogic) -> Parser Token (Ranged SLogic) +basicWithPos = basicWithPosGen ("~", "T", "F") + +basicWithPosGen t@(nt, tr, fl) p = + (\(s, r) -> toRanged (Var s) r) <$> pVarid + <|> pParens p + <|> toRanged T <$> pKey tr + <|> toRanged F <$> pKey fl + <|> unaryOp Not <$> pKey nt <*> basicWithPosGen t p + +----------------------------------------------------------- +--- Helper-functions for syntax warnings + +-- analyze parentheses +analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a +analyseAndParse p ts = + case checkParentheses ts of + Just err -> Left err + Nothing -> case parse p ts of + (_, m:_) -> Left (fromMessage m) + (a, _) -> Right a + +ambiguousOperators :: (String -> Either a b) -> String -> SyntaxError -> SyntaxError +ambiguousOperators p s err = + let msg = ErrorMessage "Ambiguous use of operators (write parentheses)" + in either (const err) (const msg) (p s) + +-- Report variables +suspiciousVariable :: Ranged SLogic -> Either SyntaxError (Ranged SLogic) +suspiciousVariable r = + case filter p (varsLogic (fromRanged r)) of + v:_ -> Left $ ErrorMessage $ "Unexpected variable " ++ v + ++ ". Did you forget an operator?" + _ -> Right r + where + p xs = length xs > 1 && all (`elem` "pqrst") xs + +----------------------------------------------------------- +--- Pretty-Printer + +ppLogic :: SLogic -> String +ppLogic = ppLogicPrio 0 + +ppLogicPrio :: Int -> SLogic -> String +ppLogicPrio n p = foldLogic (var, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, var "T", var "F") p n "" + where + binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio) + var = const . (++) + nott p _ = ("~"++) . p 4 + parIf b f = if b then ("("++) . f . (")"++) else f + +-- | Pretty printer that produces extra parentheses: also see parseLogicPars +ppLogicPars :: SLogic -> String +ppLogicPars = ppLogicParsGen asciiTuple + +-- | Pretty printer with unicode characters +ppLogicUnicodePars :: SLogic -> String +ppLogicUnicodePars = ppLogicParsGen unicodeTuple + +ppLogicParsGen (impl, equiv, and, or, nt, tr, fl) p = foldLogic alg p 0 "" + where + alg = (var, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, var tr, var fl) + binop prio op p q n = parIf (n/=0 && (n==3 || prio/=n)) + (p prio . ((" "++op++" ")++) . q prio) + var = const . (++) + nott p _ = (nt++) . p 3 + parIf b f = if b then ("("++) . f . (")"++) else f + +----------------------------------------------------------- +--- Ascii symbols + +--asciiSyms :: [String] +--asciiSyms = [implASym, equivASym, andASym, orASym, notASym] + +asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F") + +implASym, equivASym, andASym, orASym, notASym :: String +implASym = "->" +equivASym = "<->" +andASym = "/\\" +orASym = "||" +notASym = "~" + +----------------------------------------------------------- +--- Unicode symbols + +unicodeSyms :: [String] +unicodeSyms = [implUSym, equivUSym, andUSym, orUSym, notUSym] + +unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F") + +implUSym, equivUSym, andUSym, orUSym, notUSym :: String +implUSym = "\8594" +equivUSym = "\8596" +andUSym = "\8743" +orUSym = "\8744" +notUSym = "\172" diff --git a/src/Domain/Logic/Rules.hs b/src/Domain/Logic/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Rules.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Rewrite rules in the logic domain (including all the rules from the +-- DWA course) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Rules where + +import Domain.Logic.Formula +import Common.Transformation +import Common.Rewriting +import Domain.Logic.Generator() +import Domain.Logic.GeneralizedRules + +logicRules :: [Rule SLogic] +logicRules = concat + [ groupCommutativity, groupAssociativity, groupIdempotency + , groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation + , groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, groupAdditional + , groupDistributionOrOverAnd, groupDistributionAndOverOr + , groupInverseDeMorgan,groupInverseDistr + ] + +----------------------------------------------------------------------------- +-- Grouping DWA rules + +makeGroup :: String -> [Rule SLogic] -> [Rule SLogic] +makeGroup = map . addRuleToGroup + +groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, groupDistributionAndOverOr,groupIdempotency, + groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation, + groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination :: [Rule SLogic] + +groupCommutativity = makeGroup "Commutativity" + [ruleCommOr, ruleCommAnd] +groupAssociativity = makeGroup "Associativity" + [ruleAssocOr, ruleAssocAnd] + +groupIdempotency = makeGroup "Idempotency" + [ruleIdempOr, ruleIdempAnd] +groupAbsorption = makeGroup "Absorption" + [ruleAbsorpOr, ruleAbsorpAnd] +groupTrueProperties = makeGroup "True Properties" + [ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue] +groupFalseProperties = makeGroup "False Properties" + [ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse] +groupDoubleNegation = makeGroup "Double Negation" + [ruleNotNot] +groupDeMorgan = makeGroup "De Morgan" + [ruleDeMorganOr, ruleDeMorganAnd, generalRuleDeMorganOr, generalRuleDeMorganAnd ] +groupImplicationEliminatinon = makeGroup "Implication Elimination" + [ruleDefImpl] +groupEquivalenceElimination = makeGroup "Equivalence Elimination" + [ruleDefEquiv] +groupDistributionOrOverAnd = makeGroup "DistributionOrOverAnd" + [generalRuleOrOverAnd, ruleOrOverAnd ] +groupDistributionAndOverOr = makeGroup "DistributionAndOverOr" + [generalRuleAndOverOr, ruleAndOverOr ] +groupInverseDeMorgan = makeGroup "InverseDeMorgan" + [ inverseDeMorganOr, inverseDeMorganAnd] +groupInverseDistr = makeGroup "InverseDistr" + [ inverseAndOverOr, inverseOrOverAnd] + +----------------------------------------------------------------------------- +-- Commutativity + +ruleCommOr :: Rule SLogic +ruleCommOr = rule "CommOr" $ + \x y -> x :||: y :~> y :||: x + +ruleCommAnd :: Rule SLogic +ruleCommAnd = rule "CommAnd" $ + \x y -> x :&&: y :~> y :&&: x + +----------------------------------------------------------------------------- +-- Associativity (implicit) + +ruleAssocOr :: Rule SLogic +ruleAssocOr = minorRule $ rule "AssocOr" $ + \x y z -> (x :||: y) :||: z :~> x :||: (y :||: z) + +ruleAssocAnd :: Rule SLogic +ruleAssocAnd = minorRule $ rule "AssocAnd" $ + \x y z -> (x :&&: y) :&&: z :~> x :&&: (y :&&: z) + +----------------------------------------------------------------------------- +-- Distributivity + +ruleAndOverOr :: Rule SLogic + +ruleAndOverOr = ruleList "AndOverOr" + [ \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: (x :&&: z) + , \x y z -> (x :||: y) :&&: z :~> (x :&&: z) :||: (y :&&: z) + ] + +ruleOrOverAnd :: Rule SLogic +ruleOrOverAnd = ruleList "OrOverAnd" + [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: (x :||: z) + , \x y z -> (x :&&: y) :||: z :~> (x :||: z) :&&: (y :||: z) + ] + +----------------------------------------------------------------------------- +-- Idempotency + +ruleIdempOr, ruleIdempAnd :: Rule SLogic + +ruleIdempOr = rule "IdempOr" $ + \x -> x :||: x :~> x + +ruleIdempAnd = rule "IdempAnd" $ + \x -> x :&&: x :~> x + +----------------------------------------------------------------------------- +-- Absorption + +ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic + +ruleAbsorpOr = ruleList "AbsorpOr" + [ \x y -> x :||: (x :&&: y) :~> x + , \x y -> x :||: (y :&&: x) :~> x + , \x y -> (x :&&: y) :||: x :~> x + , \x y -> (y :&&: x) :||: x :~> x + ] + +ruleAbsorpAnd = ruleList "AbsorpAnd" + [ \x y -> x :&&: (x :||: y) :~> x + , \x y -> x :&&: (y :||: x) :~> x + , \x y -> (x :||: y) :&&: x :~> x + , \x y -> (y :||: x) :&&: x :~> x + ] + +----------------------------------------------------------------------------- +-- True-properties + +ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue :: Rule SLogic + +ruleTrueZeroOr = ruleList "TrueZeroOr" + [ \x -> T :||: x :~> T + , \x -> x :||: T :~> T + ] + +ruleTrueZeroAnd = ruleList "TrueZeroAnd" + [ \x -> T :&&: x :~> x + , \x -> x :&&: T :~> x + ] + +ruleComplOr = ruleList "ComplOr" + [ \x -> x :||: Not x :~> T + , \x -> Not x :||: x :~> T + ] + +ruleNotTrue = rule "NotTrue" $ + Not T :~> F + +----------------------------------------------------------------------------- +-- False-properties + +ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse :: Rule SLogic + +ruleFalseZeroOr = ruleList "FalseZeroOr" + [ \x -> F :||: x :~> x + , \x -> x :||: F :~> x + ] + +ruleFalseZeroAnd = ruleList "FalseZeroAnd" + [ \x -> F :&&: x :~> F + , \x -> x :&&: F :~> F + ] + +ruleComplAnd = ruleList "ComplAnd" + [ \x -> x :&&: Not x :~> F + , \x -> Not x :&&: x :~> F + ] + +ruleNotFalse = rule "NotFalse" $ + Not F :~> T + +----------------------------------------------------------------------------- +-- Double negation + +ruleNotNot :: Rule SLogic +ruleNotNot = rule "NotNot" $ + \x -> Not (Not x) :~> x + +----------------------------------------------------------------------------- +-- De Morgan + +ruleDeMorganOr :: Rule SLogic +ruleDeMorganOr = rule "DeMorganOr" $ + \x y -> Not (x :||: y) :~> Not x :&&: Not y + +ruleDeMorganAnd :: Rule SLogic +ruleDeMorganAnd = rule "DeMorganAnd" $ + \x y -> Not (x :&&: y) :~> Not x :||: Not y + +----------------------------------------------------------------------------- +-- Implication elimination + +ruleDefImpl :: Rule SLogic +ruleDefImpl = rule "DefImpl" $ + \x y -> x :->: y :~> Not x :||: y + +----------------------------------------------------------------------------- +-- Equivalence elimination + +ruleDefEquiv :: Rule SLogic +ruleDefEquiv = rule "DefEquiv" $ + \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&: Not y) + +----------------------------------------------------------------------------- +-- Additional rules, not in the DWA course + +groupAdditional :: [Rule SLogic] +groupAdditional = makeGroup "Additional rules" + [ ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl + , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame + ] + +ruleFalseInEquiv :: Rule SLogic +ruleFalseInEquiv = ruleList "FalseInEquiv" + [ \x -> F :<->: x :~> Not x + , \x -> x :<->: F :~> Not x + ] + +ruleTrueInEquiv :: Rule SLogic +ruleTrueInEquiv = ruleList "TrueInEquiv" + [ \x -> T :<->: x :~> x + , \x -> x :<->: T :~> x + ] + +ruleFalseInImpl :: Rule SLogic +ruleFalseInImpl = ruleList "FalseInImpl" + [ \x -> F :->: x :~> T + , \x -> x :->: F :~> Not x + ] + +ruleTrueInImpl :: Rule SLogic +ruleTrueInImpl = ruleList "TrueInImpl" + [ \x -> T :->: x :~> x + , \x -> x :->: T :~> T + ] + +ruleCommEquiv :: Rule SLogic +ruleCommEquiv = rule "CommEquiv" $ + \x y -> x :<->: y :~> y :<->: x + +ruleDefEquivImpls :: Rule SLogic +ruleDefEquivImpls = rule "DefEquivImpls" $ + \x y -> x :<->: y :~> (x :->: y) :&&: (y :->: x) + +ruleEquivSame :: Rule SLogic +ruleEquivSame = rule "EquivSame" $ + \x -> x :<->: x :~> T + +ruleImplSame :: Rule SLogic +ruleImplSame = rule "ImplSame" $ + \x -> x :->: x :~> T diff --git a/src/Domain/Logic/Strategies.hs b/src/Domain/Logic/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Logic/Strategies.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Logic.Strategies + ( dnfStrategy, dnfStrategyDWA) where + +import Prelude hiding (repeat) +import Domain.Logic.Rules +import Domain.Logic.GeneralizedRules +import Domain.Logic.Formula +import Common.Context (Context, liftToContext, currentFocus) +import Common.Rewriting (isOperator) +import Common.Transformation +import Common.Strategy + +----------------------------------------------------------------------------- +-- To DNF, with priorities (the "DWA" approachs) + +dnfStrategyDWA :: LabeledStrategy (Context SLogic) +dnfStrategyDWA = label "Bring to dnf (DWA)" $ + repeat $ toplevel <|> somewhereOr + ( label "Simplify" simplify + |> label "Eliminate implications/equivalences" eliminateImplEquiv + |> label "Eliminate nots" eliminateNots + |> label "Move ors to top" orToTop + ) + where + toplevel = useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr + , ruleAbsorpOr, ruleComplOr + ] + simplify = somewhere $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse + , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd + , ruleComplOr, ruleComplAnd + ] + eliminateImplEquiv = somewhere $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = somewhere $ useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr + , ruleDeMorganAnd, ruleDeMorganOr + ] + orToTop = somewhere $ useRules + [ generalRuleAndOverOr, ruleAndOverOr ] + +-- A specialized variant of the somewhere traversal combinator. Apply +-- the strategy only at (top-level) disjuncts +somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic) +somewhereOr s = + let isOr = maybe False (isOperator orOperator) . currentFocus + in fix $ \this -> check (Prelude.not . isOr) <*> s + <|> check isOr <*> once this + +----------------------------------------------------------------------------- +-- To DNF, in four steps + +dnfStrategy :: LabeledStrategy (Context SLogic) +dnfStrategy = label "Bring to dnf" + $ label "Eliminate constants" eliminateConstants + <*> label "Eliminate implications/equivalences" eliminateImplEquiv + <*> label "Eliminate nots" eliminateNots + <*> label "Move ors to top" orToTop + where + eliminateConstants = repeat $ topDown $ useRules + [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd + , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv + , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl + ] + eliminateImplEquiv = repeat $ bottomUp $ useRules + [ ruleDefImpl, ruleDefEquiv + ] + eliminateNots = repeat $ topDown $ + useRules + [ generalRuleDeMorganAnd, generalRuleDeMorganOr ] + |> useRules + [ ruleDeMorganAnd, ruleDeMorganOr + , ruleNotNot + ] + orToTop = repeat $ somewhere $ + liftToContext generalRuleAndOverOr |> + liftToContext ruleAndOverOr + +-- local helper function +useRules :: [Rule SLogic] -> Strategy (Context SLogic) +useRules = alternatives . map liftToContext diff --git a/src/Domain/Math/Approximation.hs b/src/Domain/Math/Approximation.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Approximation.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Selection of numerical algorithms for approximations +-- +----------------------------------------------------------------------------- +module Domain.Math.Approximation where + +import Data.List + +type Function = Double -> Double + +type Approximation = [Double] + +------------------------------------------------------------ +-- Stop criteria + +within :: Double -> Approximation -> Double +within _ [] = error "within []" +within _ [x] = x +within d (x:xs@(y:_)) + | abs (x-y) <= d = x + | otherwise = within d xs + +relative :: Double -> Approximation -> Double +relative _ [] = error "relative []" +relative _ [x] = x +relative d (x:xs@(y:_)) + | abs (x-y) <= d*abs y = x + | otherwise = relative d xs + +------------------------------------------------------------ +-- Root-finding algorithms + +-- http://en.wikipedia.org/wiki/Bisection_method +bisection :: Function -> [Double] -> Approximation +bisection f ds = + case partition ((<= 0) . f) ds of + (lo:_, hi:_) -> run hi lo + _ -> [] + where + run hi lo + | fm <= 0 = mid : run hi mid + | otherwise = mid : run mid lo + where + mid = (hi+lo) / 2 + fm = f mid + +-- http://en.wikipedia.org/wiki/Newton's_method +newton :: Function -> Function -> Double -> Approximation +newton f df x0 = iterate next x0 + where + next a + | dfa == 0 = a + | otherwise = a - f a / dfa + where + dfa = df a + +------------------------------------------------------------ +-- Finding the derivative of a function + +derivative :: Double -> Function -> Function +derivative delta f x = (f (x+delta) - f (x-delta)) / (2*delta) + +-- Test code +{- +same f g = sum [ abs (f x - g x) | x <- [0,0.01..6] ] + +test1 = same (derivative 0.01 sin) cos +test2 = same (derivative 0.01 cos) (negate . sin) -} diff --git a/src/Domain/Math/Data/Equation.hs b/src/Domain/Math/Data/Equation.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/Equation.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Mathematical equations +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Equation where + +import Common.Uniplate +import Common.Rewriting +import Common.Traversable +import Test.QuickCheck +import Control.Monad + +infix 1 :==: + +type Equations a = [Equation a] + +data Equation a = a :==: a + deriving (Eq, Ord) + +instance Functor Equation where + fmap f (x :==: y) = f x :==: f y + +instance Once Equation where + onceM f (lhs :==: rhs) = + liftM (:==: rhs) (f lhs) `mplus` liftM (lhs :==:) (f rhs) + +instance Switch Equation where + switch (ma :==: mb) = liftM2 (:==:) ma mb + +instance Crush Equation where + crush (a :==: b) = [a, b] + +instance Show a => Show (Equation a) where + show (x :==: y) = show x ++ " == " ++ show y + +getLHS, getRHS :: Equation a -> a +getLHS (x :==: _) = x +getRHS (_ :==: y) = y + +evalEquation :: Eq a => Equation a -> Bool +evalEquation = evalEquationWith id + +evalEquationWith :: Eq b => (a -> b) -> Equation a -> Bool +evalEquationWith f (x :==: y) = f x == f y + +substEquation :: (Uniplate a, MetaVar a) => Substitution a -> Equation a -> Equation a +substEquation sub (x :==: y) = (sub |-> x) :==: (sub |-> y) + +substEquations :: (Uniplate a, MetaVar a) => Substitution a -> Equations a -> Equations a +substEquations = map . substEquation + +combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a +combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2 + +flipSides :: Equation a -> Equation a +flipSides (x :==: y) = y :==: x + +----------------------------------------------------- +-- QuickCheck generators + +instance Arbitrary a => Arbitrary (Equation a) where + arbitrary = liftM2 (:==:) arbitrary arbitrary + coarbitrary (x :==: y) = coarbitrary x . coarbitrary y diff --git a/src/Domain/Math/Data/OrList.hs b/src/Domain/Math/Data/OrList.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/OrList.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.OrList + ( OrList + , orList, (\/), true, false + , isTrue, isFalse + , disjunctions, normalize, idempotent + ) where + +import Control.Monad +import Common.Traversable +import Test.QuickCheck +import Data.List (intersperse, nub, sort) + +------------------------------------------------------------ +-- Data type + +data OrList a = T | OrList [a] + deriving (Ord, Eq) + +------------------------------------------------------------ +-- Functions + +orList :: [a] -> OrList a +orList = OrList + +true, false :: OrList a +true = T +false = OrList [] + +isTrue :: OrList a -> Bool +isTrue T = Prelude.True +isTrue _ = False + +isFalse :: OrList a -> Bool +isFalse (OrList []) = True +isFalse _ = False + +disjunctions :: OrList a -> Maybe [a] +disjunctions T = Nothing +disjunctions (OrList xs) = Just xs + +(\/) :: OrList a -> OrList a -> OrList a +p \/ q = maybe T orList (liftM2 (++) (disjunctions p) (disjunctions q)) + +-- | Sort the propositions and remove duplicates +normalize :: Ord a => OrList a -> OrList a +normalize T = T +normalize (OrList xs) = OrList (nub $ sort xs) + +-- | Remove duplicates +idempotent :: Eq a => OrList a -> OrList a +idempotent T = T +idempotent (OrList xs) = OrList (nub xs) + +------------------------------------------------------------ +-- Instances + +-- local helper +joinOr :: OrList (OrList a) -> OrList a +joinOr = maybe T (foldr (\/) false) . disjunctions + +instance Functor OrList where + fmap _ T = T + fmap f (OrList xs) = OrList (map f xs) + +instance Monad OrList where + return = OrList . return + m >>= f = joinOr (fmap f m) + +instance Once OrList where + onceM = useOnceJoin + +instance Switch OrList where + switch T = return T + switch (OrList xs) = liftM orList (sequence xs) + +instance Crush OrList where + crush T = [] + crush (OrList xs) = xs + +instance OnceJoin OrList where + onceJoinM _ T = mzero + onceJoinM f (OrList xs) = rec xs + where + rec [] = mzero + rec (x:xs) = liftM (\/ orList xs) (f x) `mplus` + liftM (return x \/) (rec xs) + +instance Arbitrary a => Arbitrary (OrList a) where + arbitrary = do + n <- choose (1, 3) + xs <- vector n + return (OrList xs) + coarbitrary T = variant 0 + coarbitrary (OrList xs) = variant 1 . coarbitrary xs + +instance Show a => Show (OrList a) where + show T = "true" + show (OrList xs) + | null xs = "false" + | otherwise = unwords (intersperse "or" (map show xs)) diff --git a/src/Domain/Math/Data/Polynomial.hs b/src/Domain/Math/Data/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/Polynomial.hs @@ -0,0 +1,208 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.Polynomial + ( Polynomial, var, con, raise, power, scale + , degree, coefficient, terms + , isMonic, toMonic, isRoot, positiveRoots, negativeRoots + , derivative, eval, division, longDivision, polynomialGCD + , factorize + ) where + +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Char +import Control.Monad +import Common.Traversable +import Data.List (nub) +import Data.Ratio (approxRational) +import Domain.Math.Approximation (newton, within) + +-- Invariants: all keys are non-negative, all values are non-zero +newtype Polynomial a = P (IM.IntMap a) deriving Eq + +instance Num a => Show (Polynomial a) where + show (P m) = + let f (n, a) = sign (one (show a ++ g n)) + g n = concat $ [ "x" | n > 0 ] ++ [ '^' : show n | n > 1 ] + one ('1':xs@('x':_)) = xs + one ('-':'1':xs@('x':_)) = xs + one xs = xs + sign ('-':xs) = " - " ++ xs + sign xs = " + " ++ xs + fix xs = case dropWhile isSpace xs of + '+':ys -> dropWhile isSpace ys + '-':ys -> '-':dropWhile isSpace ys + ys -> ys + in "f(x) = " ++ + if IM.null m then "0" else + fix (concatMap f (reverse (IM.toList m))) + +-- the Functor instance does not maintain the invariant +instance Functor Polynomial where + fmap f (P m) = P (IM.map f m) + +instance Once Polynomial where + onceM f (P m) = liftM P (onceM f m) + +instance Switch Polynomial where + switch (P m) = liftM P (switch m) + +instance Num a => Num (Polynomial a) where + P m1 + P m2 = P (IM.filter (/= 0) (IM.unionWith (+) m1 m2)) + p * P m2 = IM.foldWithKey op 0 m2 + where op n a m = raise n (scale a p) + m + negate = fmap negate + fromInteger n + | n == 0 = P IM.empty + | otherwise = P (IM.singleton 0 (fromInteger n)) + -- not defined for polynomials + abs = error "abs not defined for polynomials" + signum = error "signum not defined for polynomials" + +-- a single variable (such as "x") +var :: Num a => Polynomial a +var = P (IM.singleton 1 1) + +con :: a -> Polynomial a +con = P . IM.singleton 0 + +-- | Raise all powers by a constant (discarding negative exponents) +raise :: Int -> Polynomial a -> Polynomial a +raise i p@(P m) + | i > 0 = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m ] + | i == 0 = p + | otherwise = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m, n+i>=0 ] + +power :: Num a => Polynomial a -> Int -> Polynomial a +power _ 0 = 1 +power p n = p * power p (n-1) + +scale :: Num a => a -> Polynomial a -> Polynomial a +scale a p = if a==0 then 0 else fmap (*a) p + +------------------------------------------------ + +degree :: Polynomial a -> Int +degree (P m) + | IS.null is = 0 + | otherwise = IS.findMax is + where is = IM.keysSet m + +coefficient :: Num a => Int -> Polynomial a -> a +coefficient n (P m) = IM.findWithDefault 0 n m + +terms :: Polynomial a -> [(a, Int)] +terms (P m) = [ (a, n) | (n, a) <- IM.toList m ] + +isMonic :: Num a => Polynomial a -> Bool +isMonic p = coefficient (degree p) p == 1 + +toMonic :: Fractional a => Polynomial a -> Polynomial a +toMonic p = scale (recip a) p + where a = coefficient (degree p) p + +isRoot :: Num a => Polynomial a -> a -> Bool +isRoot p a = eval p a == 0 + +-- Returns the maximal number of positive roots (Descartes theorem) +-- Multiple roots are counted separately +positiveRoots :: Num a => Polynomial a -> Int +positiveRoots (P m) = signChanges (IM.elems m) + +-- Returns the maximal number of negative roots (Descartes theorem) +-- Multiple roots are counted separately +negativeRoots :: Num a => Polynomial a -> Int +negativeRoots (P m) = signChanges (flipOdd (IM.elems m)) + where + flipOdd (x:y:zs) = x:negate y:flipOdd zs + flipOdd xs = xs + +signChanges :: Num a => [a] -> Int +signChanges = f . map signum + where + f (x:xs@(hd:_)) = if x==hd then f xs else 1 + f xs + f _ = 0 + +------------------------------------------------ + +derivative :: Num a => Polynomial a -> Polynomial a +derivative (P m) = P $ IM.fromAscList + [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList m, n > 0 ] + +eval :: Num a => Polynomial a -> a -> a +eval (P m) x = sum [ a * x^n | (n, a) <- IM.toList m ] + +-- polynomial division, no remainder +division :: Fractional a => Polynomial a -> Polynomial a -> Maybe (Polynomial a) +division p1 p2 = if b==0 then return a else Nothing + where (a, b) = longDivision p1 p2 + +-- polynomial long division +longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) +longDivision p1 p2 = monicLongDivision (scale (recip a) p1) (scale (recip a) p2) + where a = coefficient (degree p2) p2 + +-- polynomial long division, where p2 is monic +monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) +monicLongDivision p1 p2 + | d1 >= d2 && isMonic p2 = (toP quot, toP rem) + | otherwise = error "invalid monic division" + where + d1 = degree p1 + d2 = degree p2 + xs = map (`coefficient` p1) [d1, d1-1 .. 0] + ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0] + + (quot, rem) = rec [] xs + toP = P . IM.filter (/= 0) . IM.fromAscList . zip [0..] + + rec acc (a:as) | length as >= length ys = + rec (a:acc) (zipWith (+) (map (*a) ys ++ repeat 0) as) + rec acc as = (acc, reverse as) + +-- use polynomial long division to compute the greatest common factor +-- of the polynomials +polynomialGCD :: Fractional a => Polynomial a -> Polynomial a -> Polynomial a +polynomialGCD x y + | degree y > degree x = rec y x + | otherwise = rec x y + where + rec a b + | b == 0 = a + | otherwise = rec b (snd (longDivision a b)) + +------------------------ + +factorize :: Polynomial Rational -> [Polynomial Rational] +factorize p + | degree p <= 1 = [p] + | l > 0 = power var l : factorize (raise (-l) p) + | otherwise = + case pairs of + (p1,p2):_ -> factorize p1 ++ factorize p2 + [] -> [p] + where + l = snd (head (terms p)) + pairs = [ (p1, p2) + | a <- candidateRoots p + , isRoot p a + , let p1 = var - con a + , Just p2 <- [division p p1] + ] + + candidateRoots :: Polynomial Rational -> [Rational] + candidateRoots p = nub (map (`approxRational` 0.0001) xs) + where + f = eval (fmap fromRational p) + df = eval (fmap fromRational (derivative p)) + xs = nub (map (within 0.0001 . take 10 . newton f df) startList) + startList = [0, 3, -3, 10, -10, 100, -100] diff --git a/src/Domain/Math/Data/PrimeFactors.hs b/src/Domain/Math/Data/PrimeFactors.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/PrimeFactors.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.PrimeFactors + ( PrimeFactors + , factors, multiplicity, coprime + , square, power, splitPower + , primes + ) where + +import qualified Data.IntMap as IM + +------------------------------------------------------------- +-- Representation + +-- Invariants: +-- * Keys in map are prime numbers only (exception: representation of 0) +-- * Elements in map are positive (non-zero) +-- * Zero is represented by [(0,1)] (since 0^1 equals 0) +-- * The number can be negative, in which case we use the factors of +-- its absolute value +data PrimeFactors = PF Integer Factors + +type Factors = IM.IntMap Int + +------------------------------------------------------------- +-- Conversion to and from factors + +toFactors :: Integer -> Factors +toFactors n + | n > 0 = rec primes n + | n < 0 = rec primes (-n) + | otherwise = IM.singleton 0 1 + where + rec [] n = IM.singleton (fromIntegral n) 1 + rec (p:ps) n + | n <= 1 = IM.empty + | otherwise = f 0 n + where + p2 = fromIntegral p + f i m + | r == 0 = f (i+1) q + | i > 0 = IM.insert p i (rec ps m) + | otherwise = rec ps m + where + (q, r) = quotRem m p2 + + +fromFactors :: Factors -> Integer +fromFactors = product . map f . IM.toList + where f (a, i) = fromIntegral a ^ fromIntegral i + +-- For practical reasons, the list of prime numbers is cut-off after +-- 1000 elements (last primes gives 7919). +primes :: [Int] +primes = take 1000 $ rec [2..] + where + rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs) + +------------------------------------------------------------- +-- Type class instances + +instance Show PrimeFactors where + show (PF a m) = show a ++ " (factors = " ++ show (IM.toList m) ++ ")" + +instance Eq PrimeFactors where + PF a _ == PF b _ = a==b + +instance Ord PrimeFactors where + PF a _ `compare` PF b _ = a `compare` b + +instance Num PrimeFactors where + PF a m1 + PF b m2 + | a==0 = PF b m2 -- prevent recomputing prime factors + | b==0 = PF a m1 + | otherwise = fromInteger (a+b) + a - b = a + negate b + PF a m1 * PF b m2 + | a==0 || b==0 = 0 + | otherwise = PF (a*b) (IM.unionWith (+) m1 m2) + negate (PF a m) = PF (negate a) m + abs (PF a m) = PF (abs a) m + signum (PF a _) = fromInteger (signum a) + fromInteger n = PF n (toFactors n) + +instance Enum PrimeFactors where + toEnum = fromIntegral + fromEnum = fromIntegral . toInteger + +instance Real PrimeFactors where + toRational = toRational . toInteger + +instance Integral PrimeFactors where + toInteger (PF a _) = a + quotRem = quotRemPF + +------------------------------------------------------------- +-- Utility functions + +factors :: PrimeFactors -> [(Int, Int)] +factors (PF _ m) = IM.toList m + +multiplicity :: Int -> PrimeFactors -> Int +multiplicity i (PF _ m) = IM.findWithDefault 0 i m + +-- no prime in common +coprime :: PrimeFactors -> PrimeFactors -> Bool +coprime (PF _ m1) (PF _ m2) = IM.null (IM.intersection m1 m2) + +square :: PrimeFactors -> PrimeFactors +square = (`power` 2) + +power :: PrimeFactors -> Int -> PrimeFactors +power (PF a m) i = PF (a^i) (IM.map (*i) m) + +-- splitPower i a = (b,c) +-- => b^i * c = a +splitPower :: Int -> PrimeFactors -> (PrimeFactors, PrimeFactors) +splitPower i (PF a m) = (PF b p1, PF c p2) + where + pairs = IM.map (`quotRem` i) m + p1 = IM.filter (>0) (fmap fst pairs) + p2 = IM.filter (>0) (fmap snd pairs) + b = fromFactors p1 + c = a `div` (b^i) + +quotRemPF :: PrimeFactors -> PrimeFactors -> (PrimeFactors, PrimeFactors) +quotRemPF (PF a m1) (PF b m2) + | b==0 = error "division by zero" + | a==0 = (0,0) + | otherwise = sign $ + case (IM.null up, IM.null dn) of + (True, True) -> (1, 0) + (False, True) -> (PF (fromFactors up) up, 0) + (True, False) -> (0, PF a m1) + _ -> (fromInteger qn, fromInteger rn) + where + (up, dn) = IM.partition (>0) $ IM.filter (/=0) $ IM.unionWith (+) m1 (IM.map negate m2) + (qn, rn) = fromFactors up `quotRem` fromFactors (IM.map negate dn) + sign (q, r) = ( fromInteger (signum a*signum b) * q + , fromInteger (signum a) * r + ) diff --git a/src/Domain/Math/Data/SquareRoot.hs b/src/Domain/Math/Data/SquareRoot.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Data/SquareRoot.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Data.SquareRoot + ( SquareRoot + , imaginary, imaginaryUnit + , con, toList, scale, fromSquareRoot + , sqrt, sqrtRational, isqrt, eval + ) where + +import Prelude hiding (sqrt) +import Data.Ratio +import qualified Domain.Math.Data.PrimeFactors as P +import qualified Data.Map as M +import qualified Prelude +import Control.Monad + +------------------------------------------------------------- +-- Representation + +-- Sum of square roots (possibly imaginary) that are normalized +-- +-- Invariants: +-- * all keys are normalized (sqrt 8 -> 2*(sqrt 2)) +-- * all values are non-zero +-- * We maintain the "imaginary" property since sqrt(-1)*sqrt(-1) may or may not +-- be equal to sqrt(1) +-- +-- Note on the Ord instance: comparison does not follow the value (semantic +-- interpretation); it can be used though for sorting and storing in maps + +data SquareRoot a = S + { imaginary :: Bool + , squareRootMap :: SqMap a + } deriving (Eq, Ord) + +type SqMap a = M.Map P.PrimeFactors a + +------------------------------------------------------------- +-- Primitive operations on maps + +-- re-establish invariants +makeMap :: Num a => SqMap a -> SqMap a +makeMap = M.filter (/=0) . M.foldWithKey f M.empty + where + f k a m + | a == 0 = m + | otherwise = M.unionWith (+) (fmap (*a) (sqrtPF k)) m + +plusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +plusSqMap m1 m2 = M.filter (/=0) (M.unionWith (+) m1 m2) + +minusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +minusSqMap m1 m2 = m1 `plusSqMap` negateSqMap m2 + +negateSqMap :: Num a => SqMap a -> SqMap a +negateSqMap = fmap negate + +timesSqMap :: Num a => SqMap a -> SqMap a -> SqMap a +timesSqMap m1 m2 = + case (M.toList m1, M.toList m2) of + ([], _) -> M.empty + (_, []) -> M.empty + ([(n, a)], _) | n==1 -> if a==0 then M.empty else fmap (*a) m2 + (_, [(n, a)]) | n==1 -> if a==0 then M.empty else fmap (*a) m1 + _ -> + let op n a = M.unionWith (+) (f n (fmap (a *) m1)) + f i = M.mapKeys (*i) + in makeMap (M.foldWithKey op M.empty m2) + +recipSqMap :: Fractional a => SqMap a -> SqMap a +recipSqMap m = + case M.toList m of + [] -> error "division by zero" + [(n, x)] -> M.singleton n (recip (x Prelude.* fromIntegral n)) + _ -> (a-b) * recipSqMap (makeMap ((a*a) - (b*b))) + where + (ys, zs) = splitAt (length xs `div` 2) xs + (a, b) = (M.fromList ys, M.fromList zs) + xs = M.toList m + (*) = timesSqMap + (-) = minusSqMap + +sqrtPF :: Num a => P.PrimeFactors -> SqMap a +sqrtPF n + | n == 0 = M.empty + | otherwise = M.singleton b (fromIntegral a) + where + (a, b) = P.splitPower 2 n + +------------------------------------------------------------- +-- Type class instances + +instance Num a => Show (SquareRoot a) where + show (S b m) = g (map f (M.toList m)) ++ imPart + where + f (n, a) = ( signum a == -1 + , times (guard (abs a /= 1) >> Just (show (abs a))) + (guard (n /= 1) >> Just ("sqrt(" ++ show (toInteger n) ++ ")")) + ) + imPart = if b then " (imaginary number)" else "" + g [] = "0" + g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs + h (b, x) = (if b then " - " else " + ") ++ x + + times (Just a) (Just b) = a ++ "*" ++ b + times (Just a) Nothing = a + times Nothing (Just b) = b + times Nothing Nothing = "1" + +-- the Functor instance does not maintain the invariant (non-zero) +instance Functor SquareRoot where + fmap f (S b m) = S b (M.map f m) + +instance Num a => Num (SquareRoot a) where + S b1 m1 + S b2 m2 = S (b1 || b2) (plusSqMap m1 m2) + S b1 m1 - S b2 m2 = S (b1 || b2) (minusSqMap m1 m2) + S b1 m1 * S b2 m2 = S (b1 || b2) (timesSqMap m1 m2) + negate (S b m) = S b (negateSqMap m) + fromInteger = con . fromInteger + + -- not defined for square roots + abs = error "abs not defined for square roots" + signum = error "signum not defined for square roots" + +instance Fractional a => Fractional (SquareRoot a) where + recip (S b m) = S b (recipSqMap m) + fromRational = con . fromRational + +------------------------------------------------------------- +-- Utility functions + +imaginaryUnit :: Num a => SquareRoot a +imaginaryUnit = S True (M.singleton (-1) 1) + +toList :: SquareRoot a -> [(a, Integer)] +toList = map (\(k, r) -> (r, toInteger k)) . M.toList . squareRootMap + +fromSquareRoot :: Num a => SquareRoot a -> Maybe a +fromSquareRoot a = + case toList a of + [(a, n)] | n==1 -> Just a + [] -> Just 0 + _ -> Nothing + +con :: Num a => a -> SquareRoot a +con a = S False (if a==0 then M.empty else M.singleton 1 a) + +sqrt :: Num a => Integer -> SquareRoot a +sqrt n + | n < 0 = S True (M.mapKeys negate m) + | otherwise = S False m + where + m = sqrtPF (fromIntegral (abs n)) + +scale :: Num a => a -> SquareRoot a -> SquareRoot a +scale a sr = if a==0 then 0 else fmap (*a) sr + +isqrt :: Integer -> Integer +isqrt = floor . Prelude.sqrt . fromInteger + +sqrtRational :: Fractional a => Rational -> SquareRoot a +sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b)) + where + (a, b) = (numerator r, denominator r) + +eval :: Floating a => SquareRoot a -> a +eval (S _ m) = M.foldWithKey f 0 m + where f n a b = a * Prelude.sqrt (fromIntegral n) + b diff --git a/src/Domain/Math/DerivativeExercise.hs b/src/Domain/Math/DerivativeExercise.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/DerivativeExercise.hs @@ -0,0 +1,66 @@ +{-# OPTIONS -fno-case-merge #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.DerivativeExercise where + +import Common.Uniplate (universe) +import Prelude hiding (repeat, (^)) +import Domain.Math.DerivativeRules +import Common.Strategy (Strategy, somewhere, (<*>), alternatives, label, LabeledStrategy, try) +import qualified Common.Strategy +import Common.Context (Context, liftToContext) +import Common.Exercise +import Common.Transformation +import Control.Monad +import Domain.Math.Simplification +import Domain.Math.Expr +import Domain.Math.Expr.Symbols +import Domain.Math.Expr.Parser + +derivativeExercise :: Exercise Expr +derivativeExercise = makeExercise + { description = "Derivative" + , exerciseCode = makeCode "math" "derivative" + , status = Experimental + , parser = parseExpr + , isReady = noDiff + , extraRules = map liftToContext derivativeRules ++ [tidyup] + , strategy = derivativeStrategy + , examples = [ex1, ex2, ex3, ex4] + } + +noDiff :: Expr -> Bool +noDiff e = null [ () | Sym s _ <- universe e, s == diffSymbol ] + +derivativeStrategy :: LabeledStrategy (Context Expr) +derivativeStrategy = + label "Derivative" $ + try tidyup <*> Common.Strategy.repeat (derivative <*> try tidyup) + +tidyup :: Rule (Context Expr) +tidyup = liftToContext $ makeSimpleRule "Tidy-up rule" $ \old -> + let new = simplify old + in if old==new then Nothing else Just new + +derivative :: Strategy (Context Expr) +derivative = somewhere $ alternatives (map liftToContext derivativeRules) + +ex1, ex2, ex3 :: Expr +ex1 = diff $ lambda (Var "x") $ Var "x" ^ 2 +ex2 = diff $ lambda (Var "x") $ ((1/3) :*: (x ^ fromInteger 3)) :+: (fromInteger (-3) :*: (x ^ fromInteger 2)) :+: x :+: fromInteger (-5) + where x = Var "x" +ex3 = diff $ lambda (Var "x") (2 * Var "x") +ex4 = diff $ lambda (Var "x") (ln (Var "x")) + +main :: IO () +main = forM_ [ex1, ex2, ex3, ex4] $ + printDerivation derivativeExercise diff --git a/src/Domain/Math/DerivativeRules.hs b/src/Domain/Math/DerivativeRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/DerivativeRules.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.DerivativeRules where + +import Prelude hiding ((^)) +import Common.Transformation +import Domain.Math.Expr +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols +import Common.Rewriting + +derivativeRules :: [Rule Expr] +derivativeRules = + [ ruleDerivCon, ruleDerivPlus, ruleDerivMin + , ruleDerivMultiple, ruleDerivPower, ruleDerivVar + , ruleDerivProduct, ruleDerivQuotient {-, ruleDerivChain-}, ruleDerivChainPowerExprs + , ruleSine, ruleLog + ] + +diff :: Expr -> Expr +diff = unary diffSymbol + +ln :: Expr -> Expr +ln = unary lnSymbol + +lambda :: Expr -> Expr -> Expr +lambda = binary lambdaSymbol + +fcomp :: Expr -> Expr -> Expr +fcomp = binary fcompSymbol + +----------------------------------------------------------------- +-- Rules for Diffs + +ruleSine :: Rule Expr +ruleSine = rule "Sine" $ + \x -> diff (lambda x (sin x)) :~> lambda x (cos x) + +ruleLog :: Rule Expr +ruleLog = rule "Logarithmic" $ + \x -> diff (lambda x (ln x)) :~> lambda x (1/x) + +ruleDerivPlus :: Rule Expr +ruleDerivPlus = rule "Sum" $ + \x f g -> diff (lambda x (f + g)) :~> diff (lambda x f) + diff (lambda x g) + +ruleDerivMin :: Rule Expr +ruleDerivMin = rule "Sum" $ + \x f g -> diff (lambda x (f - g)) :~> diff (lambda x f) - diff (lambda x g) + +ruleDerivVar :: Rule Expr +ruleDerivVar = rule "Var" $ + \x -> diff (lambda x x) :~> 1 + +ruleDerivProduct :: Rule Expr +ruleDerivProduct = rule "Product" $ + \x f g -> diff (lambda x (f * g)) :~> f*diff (lambda x g) + g*diff (lambda x f) + +ruleDerivQuotient :: Rule Expr +ruleDerivQuotient = rule "Quotient" $ + \x f g -> diff (lambda x (f/g)) :~> (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2) + +{- ruleDerivChain :: Rule Expr +ruleDerivChain = rule "Chain Rule" f + where f (Diff x (f :.: g)) = return $ (Diff x f :.: g) :*: Diff x g + f _ = Nothing -} + +----------------------------------- +-- Special rules (not defined with unification) + +ruleDerivCon :: Rule Expr +ruleDerivCon = makeSimpleRule "Constant Term" f + where + f (Sym d [Sym l [Var v, e]]) + | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars e = return 0 + f _ = Nothing + +ruleDerivMultiple :: Rule Expr +ruleDerivMultiple = makeSimpleRule "Constant Multiple" f + where + f (Sym d [Sym l [x@(Var v), n :*: e]]) + | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = + return $ n * diff (lambda x e) + f (Sym d [Sym l [x@(Var v), e :*: n]]) + | d == diffSymbol && l == lambdaSymbol && v `notElem` collectVars n = + return $ n * diff (lambda x e) + f _ = Nothing + +ruleDerivPower :: Rule Expr +ruleDerivPower = makeSimpleRule "Power" f + where + f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) + | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && x==x1 && v `notElem` collectVars n = + return $ n * (x ^ (n-1)) + f _ = Nothing + +ruleDerivChainPowerExprs :: Rule Expr +ruleDerivChainPowerExprs = makeSimpleRule "Chain Rule for Power Exprs" f + where + f (Sym d [Sym l [x@(Var v), Sym p [g, n]]]) + | d == diffSymbol && l == lambdaSymbol && p == powerSymbol && v `notElem` collectVars n = + return $ n * (g ^ (n-1)) * diff (lambda x g) + f _ = Nothing diff --git a/src/Domain/Math/Equation/CoverUpExercise.hs b/src/Domain/Math/Equation/CoverUpExercise.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Equation/CoverUpExercise.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.CoverUpExercise (coverUpExercise) where + +import Common.Context +import Common.Exercise +import Common.Strategy hiding (replicate) +import Common.Transformation +import Common.Uniplate (transform) +import Common.View +import Control.Monad +import Data.Ratio +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.Equation.CoverUpRules +import Domain.Math.Equation.Views +import Domain.Math.Examples.DWO1 +import Domain.Math.Numeric.Views +import Domain.Math.Expr +import Prelude hiding (repeat) + +------------------------------------------------------------ +-- Exercise + +coverUpExercise :: Exercise (OrList (Equation Expr)) +coverUpExercise = makeExercise + { description = "solve an equation by covering up" + , exerciseCode = makeCode "math" "coverup" + , status = Provisional + , parser = parseWith (pOrList (pEquation pExpr)) + , equivalence = \_ _ -> True + , isReady = solvedEquations + , extraRules = map ignoreContext coverUpRulesOr + , strategy = coverUpStrategy + , examples = map (orList . return) (concat (fillInResult ++ coverUpEquations)) + } + +------------------------------------------------------------ +-- Strategy and rules + +coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) +coverUpStrategy = label "Cover-up" $ + repeat (alternatives $ map (ignoreContext . cleanUp) coverUpRulesOr) + +cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) +cleanUp = doAfter $ fmap $ fmap cleanUpExpr + +cleanUpExpr :: Expr -> Expr +cleanUpExpr = transform (simplify (makeView f fromRational)) + where + f (Negate a) = liftM negate (f a) + f (Sqrt a) = match rationalView a >>= rootedRational 2 + f (Sym s [Nat n, a]) | s == rootSymbol = + match rationalView a >>= rootedRational n + f e = match rationalView e + +rootedInt :: Integer -> Integer -> Maybe Integer +rootedInt a b = do + guard (a > 0) + let d = fromInteger b ** Prelude.recip (fromInteger a) :: Double + n = round d :: Integer + guard (n Prelude.^ a == b) + return n + +rootedRational :: Integer -> Rational -> Maybe Rational +rootedRational a r = do + x <- rootedInt a (numerator r) + y <- rootedInt a (denominator r) + return (fromInteger x / fromInteger y) + +------------------------------------------------------------ +-- Testing + +{- +main = map test (concat (fillInResult ++ coverUpEquations)) + +test e = case apply coverUpStrategy (inContext (OrList [e])) of + Just a | solvedList (fromContext a) -> True + | otherwise -> error (show (e, a)) + _ -> error (show e) -} diff --git a/src/Domain/Math/Equation/CoverUpRules.hs b/src/Domain/Math/Equation/CoverUpRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Equation/CoverUpRules.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.CoverUpRules + ( coverUpRules, coverUpRulesOr + , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight + , coverUpTimes, coverUpNegate + , coverUpNumerator, coverUpDenominator, coverUpSqrt + -- parameterized rules + , ConfigCoverUp, configName, predicateCovered, predicateCombined + , coverLHS, coverRHS, configCoverUp, varConfig + , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith + , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith + , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith + ) where + +import Common.View +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Control.Monad.Identity +import Common.Transformation +import Domain.Math.Expr.Symbols +import Domain.Math.Data.OrList +import Common.Traversable +import Domain.Math.Expr.Symbolic + +--------------------------------------------------------------------- +-- Constructors for cover-up rules + +coverUpBinary2Rule :: (OnceJoin f, Switch f) => String -> (Expr -> [(Expr, Expr)]) + -> (Expr -> Expr -> [f Expr]) + -> ConfigCoverUp -> Rule (f (Equation Expr)) +coverUpBinary2Rule opName fm fb cfg = + makeSimpleRuleList name $ onceJoinM $ \eq -> + (guard (coverLHS cfg) >> coverLeft eq) ++ + (guard (coverRHS cfg) >> coverRight eq) + where + name = coverUpRuleName opName (configName cfg) + coverRight = map (fmap flipSides) . coverLeft . flipSides + + coverLeft (lhs :==: rhs) = do + (e1, e2) <- fm lhs + guard (predicateCovered cfg e1) + new <- fb rhs e2 + switch $ fmap (guard . predicateCombined cfg) new + return (fmap (e1 :==:) new) + +coverUpBinaryRule :: String -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) + -> ConfigCoverUp -> Rule (Equation Expr) +coverUpBinaryRule opName fm fb = + let lp = makeLiftPair (return . Identity) (const . runIdentity) + fbi x y = [Identity (fb x y)] + in lift lp . coverUpBinary2Rule opName fm fbi + +coverUpUnaryRule :: String -> (Expr -> [Expr]) -> (Expr -> Expr) + -> ConfigCoverUp -> Rule (Equation Expr) +coverUpUnaryRule opName fm fb = + coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb) + +coverUpRuleName :: String -> Maybe String -> String +coverUpRuleName opName viewName = + "cover-up " ++ opName ++ maybe "" (\s -> " [" ++ s ++ "]") viewName + +--------------------------------------------------------------------- +-- Configuration for cover-up rules + +data ConfigCoverUp = Config + { configName :: Maybe String + , predicateCovered :: Expr -> Bool + , predicateCombined :: Expr -> Bool + , coverLHS :: Bool + , coverRHS :: Bool + } + +configCoverUp :: ConfigCoverUp +configCoverUp = Config + { configName = Nothing + , predicateCovered = const True + , predicateCombined = const True + , coverLHS = True + , coverRHS = True + } + +-- default configuration +varConfig :: ConfigCoverUp +varConfig = configCoverUp + { configName = Just "vars" + , predicateCovered = hasVars + , predicateCombined = noVars + } + +--------------------------------------------------------------------- +-- Parameterized cover-up rules + +coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr)) +coverUpPowerWith = coverUpBinary2Rule "power" (isBinary powerSymbol) fb + where + fb rhs e2 = do + n <- isNat e2 + guard (n > 0) + new1 <- canonicalM identity (makeRoot n rhs) + new2 <- canonicalM identity (negate (makeRoot n rhs)) + return $ orList $ new1 : [ new2 | new1 /= new2, even n ] + +coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-) + +coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpMinusLeftWith = coverUpBinaryRule "minus left" isMinus (+) + +coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpMinusRightWith = coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-)) + +-- | Negations are pushed inside +coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpTimesWith = coverUpBinaryRule "times" (map signs . commOp . matchM timesView) (/) + where + signs (Negate x, y) = (x, neg y) -- puts negation at combined term + signs (x, y) = (x, y) + +coverUpNegateWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpNegateWith = coverUpUnaryRule "negate" isNegate negate + +-- | Negations are pushed inside +coverUpNumeratorWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpNumeratorWith = coverUpBinaryRule "numerator" (matchM divView) (*) + +-- | Negations are pushed inside +coverUpDenominatorWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/)) + +coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr) +coverUpSqrtWith = coverUpUnaryRule "square root" isSqrt (\x -> x*x) + where + isSqrt (Sqrt a) = return a + isSqrt _ = [] + +--------------------------------------------------------------------- +-- Cover-up rules for variables + +coverUpRulesOr :: [Rule (OrList (Equation Expr))] +coverUpRulesOr = coverUpPower : map ruleOnce coverUpRules + +coverUpRules :: [Rule (Equation Expr)] +coverUpRules = + [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate + , coverUpTimes, coverUpNumerator, coverUpDenominator, coverUpSqrt + ] + +coverUpPower :: Rule (OrList (Equation Expr)) +coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate, + coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr) + +coverUpPower = coverUpPowerWith varConfig +coverUpPlus = coverUpPlusWith varConfig +coverUpMinusLeft = coverUpMinusLeftWith varConfig +coverUpMinusRight = coverUpMinusRightWith varConfig +coverUpTimes = coverUpTimesWith varConfig +coverUpNegate = coverUpNegateWith varConfig +coverUpNumerator = coverUpNumeratorWith varConfig +coverUpDenominator = coverUpDenominatorWith varConfig +coverUpSqrt = coverUpSqrtWith varConfig + +--------------------------------------------------------------------- +-- Some helper-functions + +commOp :: MonadPlus m => m (a, a) -> m (a, a) +commOp m = do + (a, b) <- m + return (a, b) `mplus` return (b, a) + +flipOp :: Monad m => m (a, a) -> m (a, a) +flipOp = liftM (\(x, y) -> (y, x)) + +isNat :: MonadPlus m => Expr -> m Integer +isNat (Nat n) = return n +isNat _ = mzero + +makeRoot :: Integer -> Expr -> Expr +makeRoot n a + | n == 1 = a + | n == 2 = sqrt a + | otherwise = root (fromInteger n) a diff --git a/src/Domain/Math/Equation/Views.hs b/src/Domain/Math/Equation/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Equation/Views.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Equation.Views + ( equationSolvedForm, solvedEquation, solvedEquations ) where + +import Domain.Math.Expr +import Domain.Math.Data.OrList +import Domain.Math.Data.Equation +import Common.View +import Common.Traversable + +------------------------------------------------------------- +-- Views on equations + +solvedEquations :: OrList (Equation Expr) -> Bool +solvedEquations = all solvedEquation . crush + +solvedEquation :: Equation Expr -> Bool +solvedEquation eq@(lhs :==: rhs) = + (eq `belongsTo` equationSolvedForm) || (noVars lhs && noVars rhs) + +equationSolvedForm :: View (Equation Expr) (String, Expr) +equationSolvedForm = makeView f g + where + f (Var x :==: e) | x `notElem` collectVars e = + return (x, e) + f _ = Nothing + g (s, e) = Var s :==: e diff --git a/src/Domain/Math/Examples/DWO1.hs b/src/Domain/Math/Examples/DWO1.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Examples/DWO1.hs @@ -0,0 +1,516 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO) +-- +----------------------------------------------------------------------------- +module Domain.Math.Examples.DWO1 + ( calculateResults, fillInResult + , coverUpEquations, linearEquations + , quadraticEquations, higherDegreeEquations + , modulusEquations, sqrtEquations, sqrtSubstEquations, brokenEquations + , simplerSqrt, simplerSqrt2, simplerSqrt3 + ) where + +import Prelude hiding ((^)) +import Domain.Math.Data.Equation +import Domain.Math.Expr +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols + +calculateResults :: [[Expr]] +calculateResults = [level1, level2, level3] + where + level1 = + [ -8*(-3) + , -3-9 + , 55/(-5) + , -6*9 + , -11- (-3) + , 6-(-9) + , -10+3 + , 6+(-5) + ] + + level2 = + [ -3-(6*(-3)) + , -12/3 - 3 + , -4*(2+3) + , 2-6*6 + , -27/(4-(-5)) + , (-24/(-6)) - 3 + , 8-(-77/(-11)) + , 4/(-4+5) + ] + + level3 = + [ 4*(3-(6-2)) + , (-16-9)/5 - 3 + , 4- (4-13)/(-3) + , (3*(-3))-5-4 + , -55/(3*(-5)+4) + , -4*(-2+ (-4)+7) + , -8 - (140/4*5) + , (13-(2-1)) / 3 + ] + +fillInResult :: [[Equation Expr]] +fillInResult = [level1, level2, level3] + where + level1 = + let x = variable "x" in + [ x-2 :==: 2 + , -4*x :==: -28 + , -8*x :==: 72 + , x+4 :==: 09 + , 4+x :==: 2 + , -10-x :==: -7 + , x/(-8) :==: -3 + , 11-x :==: 14 + ] + + level2 = + let x = variable "x" in + [ -5-3*x :==: -23 + , 21/x - 4 :==: 3 + , -3*(x+3) :==: -27 + , 2-5*x :==: 47 + , 18/(7-x) :==: 6 + , -77/x + 4 :==: -7 + , -7-(x/(-5)) :==: -15 + , -18/(-3+x) :==: 3 + ] + + level3 = + let x = variable "x" in + [ -5*(5-(3-x)) :==: -20 + , (-20-x)/(-5)-2 :==: 3 + , 4-(x-14)/(-3) :==: 1 + , 3*x - 3 - 7 :==: 8 + , -42/(-2*x+2) :==: 7 + , 3*(4+x+2) :==: 12 + , -6-(-54/(-3*x)) :==: -12 + , 14-(x-3)/4 :==: 3 + ] + +coverUpEquations :: [[Equation Expr]] +coverUpEquations = [level1, level2] + where + level1 = + let x = variable "x" in + [ 38-7*x :==: 3 + , sqrt (125/x) :==: 5 + , 4*(12-x) + 7 :==: 35 + , 5*x^2 :==: 80 + , 5*(5-x) :==: 35 + , 32/sqrt x :==: 8 + , (21/x)-8 :==: -1 + , 180/x^2 :==: 5 + , 3*(x-8)^2 :==: 12 + , (8-x)/3 + 7 :==: 9 + ] + + level2 = + let x = variable "x" in + [ sqrt (x+9)/2 :==: 3 + , (4*x-18)^2 :==: 4 + , 3*(13-2*x)^2 - 20 :==: 55 + , 5*((x/3) - 8)^2 :==: 20 + , (6/sqrt (x-7))^3 :==: 8 + , 8-(15/sqrt (31-x)) :==: 5 + , sqrt (4*(x^2-21)) :==: 4 + , 3 + (44/sqrt (87 + x)) :==: 7 + , 13-(56 / (21 + (70/(3+x)))) :==: 12 + , 12/(2+(24/(8+(28/(2+9/x))))) :==: 3 + ] + +linearEquations :: [[Equation Expr]] +linearEquations = [level1, level2, level3, level4, level5] + where + level1 :: [Equation Expr] + level1 = + let x = variable "x" in + [ 5*x + 3 :==: 18 + , 11*x - 12 :==: 21 + , 19 - 3*x :==: -5 + , -12 + 5*x :==: 33 + , 15 - 9*x :==: 6 + , 4*x + 18 :==: 0 + , 11*x - 12 :==: -34 + , -2*x - 3 :==: -4 + , 6*x - 12 :==: 2 + , -4*x - 13 :==: -11 + ] + + level2 :: [Equation Expr] + level2 = + let x = variable "x" in + [ 6*x-2 :==: 2*x+14 + , 3+6*x :==: 3*x+24 + , 5*x+7 :==: 2*x - 10 + , 2*x-8 :==: 18 - x + , 4*x - 6 :==: 7*x - 14 + , -1 -5*x :==: 3*x - 20 + , 4*x - 7 :==: -5*x - 24 + , 4*x - 18 :==: 14 + 11*x + , 17 :==: 4 - 10*x + , -5*x + 6 :==: 2 - 3*x + ] + + level3 :: [Equation Expr] + level3 = + let x = variable "x" in + [ 4*(x-1) :==: 11*x - 12 + , 4*(x-4) :==: 5*(2*x+1) + , 2*(5-3*x) :==: 6-x + , 4*x - (x-2) :==: 12 + 5*(x-1) + , -3*(x-2) :==: 3*(x+4) - 7 + , 3*(4*x-1) + 3 :==: 7*x - 14 + , 4*(4*x - 1) - 2 :==: -3*x + 3*(2*x -5) + , 2*x - (3*x + 5) :==: 10 + 5*(x-1) + , -5*(x+1) :==: 9*(x+4)-5 + , 18 - 2*(4*x + 2) :==: 7*x - 4*(4*x -2) + ] + + level4 :: [Equation Expr] + level4 = + let x = variable "x" in + [ (1/2)*x - 4 :==: 2*x + 2+(1/2) + , (1/4)*x + (1/2) :==: (5/2)*x + 2 + , (1/4)*x - (3/4) :==: 2*x + (1/2) + , -(1/2)*x + (3/4) :==: (5/2)*x + 3 + , -(1/2)*x + 1+(1/2) :==: 2*x - 5 + , -(1/3)*x + (3/4) :==: (1/4)*x + (1/6) + , (3/4)*x - (1/3) :==: (2/3)*x - (3/4) + , (2/5)*x - (1/4) :==: (1/2)*x + (3/4) + , (2/3)*x - 2 :==: (1/5)*x - (3/5) + , (-1+(2/5))*x + 3+(1/2) :==: (3/5)*x + (9/10) + ] + + level5 :: [Equation Expr] + level5 = + let x = variable "x" in + [ (1/4)*(x-3) :==: (1/2)*x - 4 + , (x+3)/2 :==: 5*((1/2)*x + 1 + (1/2)) + , (1/2)*(7-(2/3)*x) :==: 2 + (1/9)*x + , (3/4)*x - (x-1) :==: 3 + (2+(1/2))*(x-1) + , -(5/4)*(x-7) :==: (3/4)*(x+2) - (4+(1/2)) + , 3*((1/5)*x - 1) + 5 :==: 7*x - 14 + , ((5*x - 1) / 6) - 2 :==: -4*x + (3*x - 6)/2 + , 2*x - ((2*x+2)/5) :==: 12 + (x-1)/6 + , (-3*(x+2))/6 :==: 9*((2/3)*x + (1/3)) - (5/3) + , 1 - ((4*x + 2)/3) :==: 3*x - ((5*x - 1) / 4) + ] + +quadraticEquations :: [[Equation Expr]] +quadraticEquations = [level1, level2, level3, level4, level5, level6] + where + level1 = + let x = variable "x" in + [ x^2 :==: 2 + , x^2+3 :==: 52 + , x^2-7 :==: 0 + , 9*x^2 - 6 :==: 75 + , 32 - 2*x^2 :==: 14 + , 2*(x^2 - 3) :==: 12 + , (1/4)*x^2 + 12 :==: 16 + , (x-1)^2 :==: 100 + , 14 - 2*x^2 :==: 6 + , (1/4)*(17-x^2) :==: 2 + ] + + level2 = + let x = variable "x" in + [ (x-7)^2 + 3 :==: 11 + , (6-2*x)^2 :==: 81 + , (1/2)*(x+9)^2 :==: 4 + , (3-x^2)/10 :==: 2 + , 5*x^2 + 3*x :==: 3*x + 2 + , 11 - (2*x + 1)^2 :==: 5 + , (6*x - 3)^2 + 6 :==: 12 + , (7+2*x)^2 :==: 7 + , 4 - (x^2 / 10) :==: 6 + , 12 - (2*x + 3)^2 :==: 6 + ] + + level3 = + let x = variable "x" in + [ x^2 :==: 5*x + , x^2 - 6*x :==: 0 + , 6*x + x^2 :==: 0 + , x*(x+4) :==: 0 + , x*(2*x-4) :==: 0 + , 3*x^2 :==: 6*x + , 3*x :==: 2*x^2 + , x*(1-6*x) :==: 0 + , (x+5)*(x-8) :==: 0 + , (3*x-1)*(x+3) :==: 0 + ] + + level4 = + let x = variable "x" in + [ x^2-2*x :==: 3 + , x^2+12*x+20 :==: 0 + , x^2-x :==: 30 + , x*(x+2) :==: 8 + , x*(x-3) :==: 4 + , 2*x+15 :==: x^2 + , 4*x :==: 12 - x^2 + , x^2 :==: 15 - 8*x + , x^2-9*x+18 :==: 0 + , x^2+14*x+24 :==: 0 + ] + + level5 = + let x = variable "x" in + [ (3*x+5)^2+(x-5)^2 :==: 40 + , 4*(10-x^2) :==: -2*x*(2*x + 10) + , x*(x+12) :==: 2*x^2 + , 3*(x-2)*(x+6) :==: 12*x + , 8*x^2+4*x-24 :==: (x+3)*(x-8) + , 3*x^2 - 11 :==: (3+2*x)^2 + , 2*x*(x-3)-3 :==: (x+2)*(x+6) + , 12*(x^2-3*x)+8 :==: 56 + , 4*x^2-6*x :==: x^2+9 + , (x+1)*(x-5) :==: (x-2)*(x-3) + ] + + level6 = + let x = variable "x" in + [ x^2+4*x-4 :==: 0 + , x^2-6*x :==: 4 + , x^2-12*x+34 :==: 0 + , 2*x^2+4*x-8 :==: 0 + , (x-4)*(x-1) :==: 11 + , (x-(7/2))^2 :==: 2*(x+4) + , x^2-3*x :==: 3*(x-2) + , (4-x)*(1-x) :==: 3*x + , 2*x^2 :==: x*(x+2)+7 + , (1-x)^2 :==: x+2 + ] + +higherDegreeEquations :: [Equation Expr] +higherDegreeEquations = + let x = variable "x" in + [ x^3 + x^2 :==: 0 + , x^3 - 5*x :==: 0 + , x^3 - 11*x^2 + 18*x :==: 0 + , x^3 + 36*x :==: 13*x^2 + , x^3 + 2*x^2 :==: 24*x + , 7*x^3 :==: 8*x^2 + , x^4 :==: 9*x^2 + , 64*x^7 :==: x^5 + , x^3 - 4*x^2 - 9*x :==: 0 + , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2 + ] + +modulusEquations :: [[Equation Expr]] +modulusEquations = + let x = variable "x" in + [ [ abs (2*x + 3) :==: 2 + , abs (5 - 2*x) :==: 1 + , abs (4*x + 7) :==: 3 + , abs (11 - 3*x) :==: 15 + ] + , [ abs (x^2 + 3) :==: 9 + , abs (x^2 - 7) :==: 2 + , abs (3-x^2) :==: 6 + , abs (9-x^2) :==: 7 + ] + , [ abs (2*x^2+3) :==: 19 + , abs (3*x^2-2) :==: 1 + , abs (6-2*x^2) :==: 2 + , abs (3-(1/2)*x^2) :==: 15 + ] + , [ abs (4*x^3-72) :==: 36 + , abs (0.2*x^4 - 112) :==: 13 + , abs (2*x^4-4.25) :==: 3.75 + , abs (1.75 - 0.5*x^3) :==: 2.25 + ] + ] + +sqrtEquations :: [[Equation Expr]] +sqrtEquations = + let x = variable "x" in + [ [ 5 - 2*sqrt x :==: 1 + , 7 - 3 * sqrt x :==: 5 + , 4 - 2*sqrt x :==: -3 + , 6 - 3*sqrt x :==: 2 + ] + , [ 2*sqrt x :==: x + , 2*sqrt x :==: 3*x + , x-3*sqrt x :==: 0 + , 3*x - 5*sqrt x :==: 0 + ] + , [ x :==: sqrt (2*x + 3) + , x :==: sqrt (3*x+10) + , x :==: sqrt (4*x + 21) + , x :==: sqrt (3*x + 4) + ] + , [ 5*x :==: sqrt (50*x + 75) + , 2*x :==: sqrt (24*x + 28) + , 3*x :==: sqrt (27*x - 18) + , 2*x :==: sqrt (28*x - 40) + , 3*x :==: sqrt (3*x + 42) + , 5*x :==: sqrt (49*x + 2) + , 3*x :==: sqrt (10*x -1) + , 5*x :==: sqrt (30*x - 5) + ] + , [ x - sqrt x :==: 6 + , x - 4*sqrt x :==: 12 + , x - sqrt x :==: 12 + , x - sqrt x :==: 2 + , 2*x + sqrt x :==: 3 + , 3*x + 4*sqrt x :==: 20 + , 2*x + sqrt x :==: 15 + , 2*x - 3*sqrt x :==: 27 + ] + ] + +sqrtSubstEquations :: [[Equation Expr]] +sqrtSubstEquations = + let x = variable "x" in + [ [ 8*x^3 + 1 :==: 9*x * sqrt x + , 27*x^3 :==: 28*x*sqrt x - 1 + , x^3 + 3 :==: 4*x*sqrt x + , x^3 :==: 10*x*sqrt x - 16 + ] + , [ x^3 :==: 6*x*sqrt x + 16 + , x^3 - 24*x*sqrt x :==: 81 + , x^3 + x*sqrt x :==: 20 + , x^3 - 15 :==: 2*x*sqrt x + ] + , [ x^5 +32 :==: 33*x^2*sqrt x + , 243*x^5 - 244*x^2*sqrt x + 1 :==: 0 + , 32*x^5 + 31*x^2*sqrt x :==: 1 + , x^5 :==: 242*x^2*sqrt x + 243 + ] + , [ x^5 + 8 :==: 6*x^2*sqrt x + , x^5 :==: 9*x^2 * sqrt x - 18 + , x^5 :==: 5*x^2*sqrt x + 24 + , x^5 + 4*x^2 * sqrt x :==: 12 + ] + ] + +brokenEquations :: [[Equation Expr]] +brokenEquations = + let x = variable "x" in + [ [ (2*x^2 - 10) / (x^2+3) :==: 0 + , (7*x^2 - 21) / (2*x^2 - 5) :==: 0 + , (3*x^2 - 6) / (4*x^2+1) :==: 0 + , (4*x^2 - 24) / (6*x^2 - 2) :==: 0 + , x^2 / (x+4) :==: (3*x+4) / (x+4) + , (x^2 + 2) / (x-2) :==: (x+8) / (x-2) + , (x^2 + 6*x - 6) / (x^2 - 1) :==: (4*x + 9) / (x^2 - 1) + , (x^2 + 6) / (x^2 - 2) :==: (7*x) / (x^2 - 2) + ] + , [ (x^2 + 6*x) / (x^2 - 1) :==: (3*x + 4) / (x^2 - 1) + , (x^2 + 6) / (x - 3) :==: (5*x) / (x - 3) + , (x^2 + 4*x) / (x^2 - 4) :==: (3*x + 6) / (x^2 - 4) + , (x^2 + 2*x - 4) / (x-5) :==: (4*x + 11) / (x - 5) + , (5*x+2) / (2*x - 1) :==: (5*x + 2) / (3*x + 5) + , (x^2-9) / (4*x - 1) :==: (x^2 - 9) / (2*x + 7) + , (3*x - 2) / (2*x^2) :==: (3*x - 2) / (x^2 + 4) + , (2*x + 1) / (x^2+3*x) :==: (2*x + 1) / (5*x + 8) + ] + , [ (x^2 - 1) / (2*x + 2) :==: (x^2-1) / (x+8) + , (x^2 - 4) / (3*x - 6) :==: (x^2-4) / (2*x+1) + , (x^2 + 5*x) / (2*x^2) :==: (x^2 + 5*x) / (x^2 + 4) + , (x^2 - 3*x) / (2*x - 6) :==: (x^2 - 3*x) / (4*x + 2) + , x/(x+1) :==: 1+3/4 + , (x+2)/(3*x) :==: 1+1/3 + , (2*x+3) / (x-1) :==: 3+1/2 + , (x-3)/(1-x) :==: 1+2/5 + ] + , [ (x+4)/(x+3) :==: (x+1)/(x+2) + , (2*x+3)/(x-1) :==: (2*x-1) / (x-2) + , (3*x+6)/(3*x-1) :==: (x+4) / (x+1) + , (x+2)/(2*x+5) :==: (x+4)/(2*x-3) + , (x+5)/(2*x) +2 :==: 5 + , (3*x+4)/(x+2) - 3 :==: 2 + , (x^2)/(5*x+6) +4 :==: 5 + , (x^2)/(2*x-3) + 3 :==: 7 + ] + , [ (x-2) / (x-3) :==: x/2 + , (x+9) / (x-5) :==: 2/x + , (x+2) / (x+4) :==: 2/(x+1) + , (-3) / (x-5) :==: (x+3)/(x-1) + , (x+1)/(x+2) :==: (7*x+1) / (2*x-4) + , (2*x-7)/(5-x) :==: (x+1) / (3*x-7) + , (x+1)/(x-1) :==: (3*x-7)/(x-2) + , (3*x-7)/(x-2) :==: (7-x) / (3*x-3) + ] + ] + +infix 9 *| + +-- short-hand notation for a product with a square-root +(*|) :: Expr -> Expr -> Expr +a *| b = a * sqrt b + +simplerSqrt :: [[Expr]] +simplerSqrt = + let a = Var "a" in + [ [ 9*|5 * 7*|3, 3*|2 * 2*|5, 5*|2 * 6*|7, 4*|6 * 2*|7, (6*a)*|3 * 9*|2 + , 5*|5 * (2*a)*|7, a*|6 * 7*|5, 8*|7 * a*|3 + ] + , [ sqrt 15 / 6*|3, 5*|30/sqrt 5, 4*|10 / 5*|2, 5*|21 / 2*|7, (6*a)*|35 / 3*|5 + , (5*a)*|14 / 9*|2, a*|6 / 7*|3, (a*3)*|42 / 7*|7 + ] + , [ 5/2*|2, 2/5*|3, 3/2*|5, 8/7*|6, (2*a)/3*|7, (6*a)/7*|10, (5*a)/3*|11 + , (6*a)/5*|13 + ] + , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2) + , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2) + ] + , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2) + , ((1/3)*|2)^2, ((1/2)*|3)^2, ((2/7)*|5)^2, ((2/3)*|7)^2 + ] + ] + +simplerSqrt2 :: [[Expr]] +simplerSqrt2 = + let a = Var "a" in + [ [ (((1/7)*a)*|2)^2, (((3/5)*a)*|3)^2, (((1/3)*a)*|5)^2, (((4/7)*a)*|6)^2 + , sqrt 8 + sqrt 2, sqrt 2 + sqrt 18, sqrt 12 - sqrt 3, sqrt 7 - sqrt 28 + ] + , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45 + , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2) + , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2) + ] + , [ sqrt 27 + 1 / sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72- 7/ sqrt 2 + , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2) + , sqrt 75 - sqrt (1+1/3) + , sqrt (1+2/3) + sqrt 60 + ] + ] + +simplerSqrt3 :: [[Expr]] +simplerSqrt3 = + let a = Var "a" in + [ [ (2*|7 + 7*|3)^2, (sqrt 2 + 6*|3)^2, (4*|3 + 3*|2)^2, (2*|5 + sqrt 7)^2 + , (3*|6 - 4*|5)^2, (5*|3 - sqrt 2)^2, (4*|6 - 2*|7)^2, (sqrt 5 - 2*|3)^2 + ] + , [ (2*|3 - 2)^2, (5*|2 - 1)^2, (3+4*|3)^2, (2+3*|6)^2, (4*|2+3)*(4*|2 - 3) + , (sqrt 7 + sqrt 3)*(sqrt 7 - sqrt 3), (2*|2 - sqrt 5)*(2*|2 + sqrt 5) + , (6-3*|3)*(6+3*|3) + ] + , [ (a-sqrt 3)^2, (2*|6 + a)^2, (2*a + a*|5)^2, (a*|3 - (2*a)*|2)^2 + , (a-sqrt 7)*(a+sqrt 7), (3*a + 2*|3)*(3*a - 2*|3) + , (2*a + a*|2)*(2*a - a*|2), ((3*a)*|5 - a)*((3*a)*|5 + a) + ] + , [ 4/(sqrt 2 + 2), 3/(sqrt 5 + 1), 2/(sqrt 3 - 3), 5/(sqrt 6 - 2) + , 6/(sqrt 7 + sqrt 5), 4/(2*|3 + sqrt 6), 5/(3*|2 - sqrt 3) + , 2/(sqrt 11-sqrt 2) + ] + , [ 2*|3 / (sqrt 5 + sqrt 2), 6*|5 / (sqrt 7 + sqrt 3) + , 4*|3 / (sqrt 5 - sqrt 3), 8*|7 / (sqrt 6 - sqrt 5) + ] + ] diff --git a/src/Domain/Math/Examples/DWO2.hs b/src/Domain/Math/Examples/DWO2.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Examples/DWO2.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Example exercises from the Digital Mathematics Environment (DWO) +-- +----------------------------------------------------------------------------- +module Domain.Math.Examples.DWO2 where + +import Prelude hiding ((^)) +import Domain.Math.Expr +import Domain.Math.Data.Equation + +data InEq a = a :<: a | a :>: a + +infix 1 :<:, :>: + +-------------------------------------------------------------------- +-- Havo applets + +-- Havo B Voorkennis: lineaire ongelijkheden +ineqLin1 :: [[InEq Expr]] +ineqLin1 = + let a = Var "a" in + let x = Var "x" in + [ [ 7*x - 12 :<: 5*x + 3 + , 4*(x-3) :>: 3*(x-4) + , 6*(a+1) :<: 3*(a-2)+4 + , 5 - 2*(a-3) :>: 5*(3-a) + ] + , [ 4*x+5 :<: 5*x - 3 + , (1/3)*x+10 :>: (1/2)*x + , 3*x+1 :<: 7*x + 5 + , x+6 :>: 2 - (3/4)*x + ] + , [ 5*(x-1) :<: 7*x - 1 + , -3*(4*x-1) :>: 2-(x-1) + , 2*(3*x-1) :<: 5-(2-9*x) + , 2*(x-1)-3*(x-2) :>: 6 + ] + ] + +-- Havo B Voorkennis: kwadratische ongelijkheden +-- (door eerst gelijkheid op te lossen) +-- (level 2 uit Hoofdstuk 3) +ineqKwad1 :: [[InEq Expr]] +ineqKwad1 = + let x = Var "x" in + [ [ x^2 +3*x-4 :<: 0 + , x^2-4*x-12 :>: 0 + , -x^2 - 4*x + 5 :<: 0 + , -x^2 + 3*x + 18 :>: 0 + , (1/2)*x^2 - 3*x - 8 :<: 0 + , -2*x^2 + 10*x :>: 0 + ] + , [ x^2 + 9*x :<: 3*x - 5 + , x^2 - x :>: 12 + , x^2 - 4.5*x :<: 7-3*x + , 2*x^2 - 10*x :>: x^2 - 3*x + , 4*x^2 + 6*x :<: x^2 + 3*x + 18 + , 2*x^2 + 6*x - 10 :>: x^2 + 2*x - 5 + ] + ] + +-- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact +-- (door eerst gelijkheid op te lossen) +ineqHigh :: [InEq Expr] +ineqHigh = + let x = Var "x" in + [ 2*x^3 :>: 54 + , -0.5*x^4 :<: -40.5 + , 1 - 2*x^5 :<: -485 + , (2*x-3)^4 :>: 1 + , -(0.5*x+2)^3 :<: -1 + , 0.25*(0.5*x-2)^4 :<: 4 + ] + +-- Havo B hoofdstuk 3, Hogeregraadsvgl. +higherEq1 :: [[Equation Expr]] +higherEq1 = + let x = Var "x" in + [ [ (1/3)*x^3 :==: 9 + , x^5 - 12 :==: 20 + , 1 - 8*x^3 :==: -124 + , 16 - 32*x^5 :==: - 227 + ] + , [ 3*x^4 :==: 48 + , (1/9)*x^6 + 12 :==: 93 + , 39 - 8*x^2 :==: 21 + , (1/2)*x^4 - 13 :==: 27.5 + ] + , [ 3*(2*x-1)^3 + 11 :==: 659 + , 0.5*(3*x-4)^5 + 7 :==: 23 + , 2*(0.5*x+3)^7 - 11 :==: -9 + , 5*(1-4*x)^3 + 4 :==: -621 + ] + , [ 3*(2*x + 5)^2 + 9 :==: 21 + , 2*(3*x-6)^6 - 24 :==: -22 + , -2*(4*x-5)^4 + 192 :==: -8000 + , (3-2*x)^4 + 23 :==: 279 + ] + ] + +-------------------------------------------------------------------- +-- VWO A/C applets + +-- hoofdstuk 2 +ineqKwad2 :: [InEq Expr] +ineqKwad2 = + let x = Var "x" in + [ x^2 + 9*x :<: 3*x - 5 + , x^2 - x :>: 12 + , x^2 - 4.5*x :<: 7 - 3*x + , 2*x^2 - 10*x :>: x^2 - 3*x + , 4*x^2 + 6*x :<: x^2 + 3*x + 18 + , 2*x^2 + 6*x - 10 :>: x^2 +2*x - 5 + ] + +-------------------------------------------------------------------- +-- VWO B applets + +-- hoofdstuk 1 +higherEq2 :: [[Equation Expr]] +higherEq2 = + let x = Var "x" in + [ [ 2*x^3 + 9 :==: 19 + , 4*x^5 - 17 :==: 27 + , 3*x^7 + 9 :==: 62 + , 5*x^3 - 1 :==: 9 + , 6 - 5*x^3 :==: 76 + , 11 - 7*x^5 :==: 53 + , 4 - 0.2*x^7 :==: 9 + , 18 - 11*x^7 :==: 62 + ] + , [ 0.5*x^4 + 5 :==: 12 + , 5*x^6 - 37 :==: 68 + , 4*x^8 - 19 :==: 9 + , 5*x^6 + 7 :==: 97 + , 18 - 7*x^4 :==: -38 + , 3 + (1/3)*x^6 :==: 7 + , 1 - (1/9)*x^8 :==: -4 + , 47 + 15*x^8 :==: 77 + ] + , [ 18*x^8 - 11 :==: 7 + , (1/4)*x^6 + 14 :==: 30 + , 5*x^4 + 67 :==: 472 + , 5*x^4 - 1 :==: 4 + , (1/8)*x^7 + 24 :==: 40 + , 0.2*x^3 + 27 :==: 52 + , 32*x^3 + 18 :==: 22 + , 4*x^3 - 8 :==: 100 + ] + , [ 14 -2*x^3 :==: 700 + , 4-3*x^5 :==: 100 + , 14 - 11*x^7 :==: 25 + , 1 - 3*x^5 :==: 97 + , 3*(x-2)^4 + 7 :==: 37 + , 6 - (2*x-1)^3 :==: 1 + , (1/3)*(x+5)^6 - 4 :==: 3 + , 6 - 0.5*(x-1)^5 :==: 10 + ] + , [ (1/2)*(3*x-1)^4 :==: 8 + , 100-(1/3)*(4*x-3)^5 :==: 19 + , 4*(0.5*x+2)^6 + 5 :==: 9 + , 3*(2*x + 7)^3 + 11 :==: 35 + ] + -- (Ontbinden applet) + , [ x^3 - 5*x^2 + 4*x :==: 0 + , x^3 :==: 3*x^2 + 10*x + , 14*x :==: x^3 + 5*x^2 + , (1/2)*x^3 + 3*x^2 + 4*x :==: 0 + , x^3 + 6*x^2 + 9*x :==: 0 + , 5*x^2 :==: x^3 + 6*x + , x^3 - 5*x^2 :==: 6*x + , x^3 :==: 4*x^2 + 12*x + ] + , [ x^4 + 36 :==: 13*x^2 + , x^4 - 9*x^2 + 20 :==: 0 + , x^4 :==: 2*x^2 + 3 + , x^4 + 2*x^2 :==: 24 + , 7*x^2 + 18 :==: x^4 + , x^4 :==: x^2 + 12 + , 29*x^2 :==: x^4 + 100 + , 2*x^4 + 2*x^2 :==: 12 + ] + -- (abc-form applet) + , [ 4*x^4 + 4 :==: 17*x^2 + , 16*x^4 + 225 :==: 136*x^2 + , 2*x^4 - 15*x^2 + 25 :==: 0 + , 9*x^4 - 28*x^2 + 3 :==: 0 + , 3*x^4 - 14*x^2 - 5 :==: 0 + , 2*x^4 :==: x^2 + 3 + , 9*x^4 + 14*x^2 :==: 8 + , 4*x^4 - 29*x^2 - 24 :==: 0 + ] + , [ 8*x^6 - 9*x^3 + 1 :==: 0 + , 27*x^6 + 8 :==: 217*x^3 + , 2*x^6 + x^3 - 1 :==: 0 + , 8*x^6 + 31*x^3 :==: 4 + , 3*x^6 - 80*x^3 - 27 :==: 0 + , 5*x^6 :==: 39*x^3 + 8 + , 7*x^6 + 8*x^3 + 1 :==: 0 + , 4*x^6 + 2 :==: -9*x^3 + ] + ] diff --git a/src/Domain/Math/Expr.hs b/src/Domain/Math/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr + ( module Domain.Math.Expr.Data + , module Domain.Math.Expr.Parser + , module Domain.Math.Expr.Symbolic + , module Domain.Math.Expr.Symbols + , module Domain.Math.Expr.Views + , module Domain.Math.Expr.Conversion + ) where + +import Domain.Math.Expr.Data +import Domain.Math.Expr.Parser +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols +import Domain.Math.Expr.Views +import Domain.Math.Expr.Conversion diff --git a/src/Domain/Math/Expr/Conversion.hs b/src/Domain/Math/Expr/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Conversion.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Conversion where + +import Domain.Math.Expr.Data +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Text.OpenMath.Object +import Common.View +import Control.Monad +import Data.Maybe +import Data.List + +----------------------------------------------------------------------- +-- Type class for expressions + +class IsExpr a where + toExpr :: a -> Expr + fromExpr :: MonadPlus m => Expr -> m a + exprView :: View Expr a + + -- default definitions + toExpr = build exprView + fromExpr = maybe (fail "not an expression") return . match exprView + exprView = makeView fromExpr toExpr + +instance IsExpr Expr where + exprView = identity + +instance IsExpr a => IsExpr [a] where + toExpr = function listSymbol . map toExpr + fromExpr expr = isSymbol listSymbol expr >>= mapM fromExpr + +instance (IsExpr a, IsExpr b) => IsExpr (Either a b) where + toExpr = either toExpr toExpr + fromExpr expr = + liftM Left (fromExpr expr) `mplus` + liftM Right (fromExpr expr) + +------------------------------------------------------------- +-- Conversions to the Expr data type + +instance IsExpr a => IsExpr (Equation a) where + toExpr (x :==: y) = binary eqSymbol (toExpr x) (toExpr y) + fromExpr expr = do + (e1, e2) <- isBinary eqSymbol expr + liftM2 (:==:) (fromExpr e1) (fromExpr e2) + +instance IsExpr a => IsExpr (OrList a) where + toExpr ors = + case disjunctions ors of + Just [] -> symbol falseSymbol + Just [x] -> toExpr x + Just xs -> function orSymbol (map toExpr xs) + Nothing -> symbol trueSymbol + + fromExpr expr = do + xs <- isSymbol orSymbol expr + ys <- mapM fromExpr xs + return (orList ys) + `mplus` do + guard (isConst falseSymbol expr) >> return false + `mplus` do + guard (isConst trueSymbol expr) >> return true + `mplus` + liftM return (fromExpr expr) + +------------------------------------------------------------- +-- Symbol Conversion to/from OpenMath + +toOMOBJ :: Expr -> OMOBJ +toOMOBJ (Var x) = OMV x +toOMOBJ (Nat n) = OMI n +toOMOBJ expr = + case getFunction expr of + Just (s, []) -> + OMS s + Just (s, [Var x, e]) | s == lambdaSymbol -> + OMBIND (OMS lambdaSymbol) [x] (toOMOBJ e) + Just (s, xs) -> + OMA (OMS s:map toOMOBJ xs) + Nothing -> + error $ "toOMOBJ: " ++ show expr + +fromOMOBJ :: OMOBJ -> Expr +fromOMOBJ omobj = + case omobj of + OMI n -> fromInteger n + OMV x -> Var x + OMS s -> symbol s + OMA (OMS s:xs) -> function s (map fromOMOBJ xs) + OMBIND (OMS s) [x] body -> + binary s (Var x) (fromOMOBJ body) + _ -> symbol $ Symbol Nothing $ show omobj diff --git a/src/Domain/Math/Expr/Data.hs b/src/Domain/Math/Expr/Data.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Data.hs @@ -0,0 +1,239 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Data where + +import Data.Char (isDigit, isAlphaNum) +import Data.Ratio +import Test.QuickCheck +import Control.Monad +import Common.Uniplate +import Common.Rewriting hiding (operators, match) +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols + +----------------------------------------------------------------------- +-- Expression data type + +data Expr = -- Num + Expr :+: Expr + | Expr :*: Expr + | Expr :-: Expr + | Negate Expr + | Nat Integer + -- Fractional & Floating + | Expr :/: Expr + | Sqrt Expr + -- Symbolic + | Var String + | Sym Symbol [Expr] + deriving (Eq, Ord) + +----------------------------------------------------------------------- +-- Numeric instances (and symbolic) + +instance Num Expr where + (+) = (:+:) + (*) = (:*:) + (-) = (:-:) + fromInteger n + | n < 0 = negate $ Nat $ abs n + | otherwise = Nat n + negate = Negate + abs = unary absSymbol + signum = unary signumSymbol + +instance Fractional Expr where + (/) = (:/:) + fromRational r + | denominator r == 1 = + fromIntegral (numerator r) + | numerator r < 0 = + Negate (fromIntegral (abs (numerator r)) :/: fromIntegral (denominator r)) + | otherwise = + fromIntegral (numerator r) :/: fromIntegral (denominator r) + +instance Floating Expr where + pi = symbol piSymbol + sqrt = Sqrt + (**) = binary powerSymbol + logBase = binary logSymbol + exp = unary expSymbol + log = unary logSymbol + sin = unary sinSymbol + tan = unary tanSymbol + cos = unary cosSymbol + asin = unary asinSymbol + atan = unary atanSymbol + acos = unary acosSymbol + sinh = unary sinhSymbol + tanh = unary tanhSymbol + cosh = unary coshSymbol + asinh = unary asinhSymbol + atanh = unary atanhSymbol + acosh = unary acoshSymbol + +instance Symbolic Expr where + variable = Var + + getVariable (Var s) = return s + getVariable _ = mzero + + function s [a, b] + | s == plusSymbol = a :+: b + | s == timesSymbol = a :*: b + | s == minusSymbol = a :-: b + | s == divideSymbol = a :/: b + | s == rootSymbol && b == Nat 2 = Sqrt a + function s [a] + | s == negateSymbol = Negate a + function s as = + Sym s as + + getFunction expr = + case expr of + a :+: b -> return (plusSymbol, [a, b]) + a :*: b -> return (timesSymbol, [a, b]) + a :-: b -> return (minusSymbol, [a, b]) + Negate a -> return (negateSymbol, [a]) + a :/: b -> return (divideSymbol, [a, b]) + Sqrt a -> return (rootSymbol, [a, Nat 2]) + Sym s as -> return (s, as) + _ -> mzero + +----------------------------------------------------------------------- +-- Uniplate instance + +instance Uniplate Expr where + uniplate expr = + case getFunction expr of + Just (s, as) -> (as, function s) + _ -> ([], const expr) + +----------------------------------------------------------------------- +-- Arbitrary instance + +instance Arbitrary Expr where + arbitrary = natGenerator + -- before changing this instance, check that the + -- Gaussian elimination exercise still works (with checkExercise) + {- + let syms = [plusSymbol, timesSymbol, minusSymbol, negateSymbol, divSymbol] + in sized (symbolGenerator (const [natGenerator]) syms) -} + coarbitrary expr = + case expr of + a :+: b -> variant 0 . coarbitrary a . coarbitrary b + a :*: b -> variant 1 . coarbitrary a . coarbitrary b + a :-: b -> variant 2 . coarbitrary a . coarbitrary b + Negate a -> variant 3 . coarbitrary a + Nat n -> variant 4 . coarbitrary n + a :/: b -> variant 5 . coarbitrary a . coarbitrary b + Sqrt a -> variant 6 . coarbitrary a + Var s -> variant 7 . coarbitrary s + Sym f xs -> variant 8 . coarbitrary (show f) . coarbitrary xs + +symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr +symbolGenerator extras syms = f + where + f n = oneof $ map (g n) (filter (\(_, a) -> n > 0 || a == Just 0) syms) + ++ extras n + g n (s, arity) = do + i <- case arity of + Just i -> return i + Nothing -> choose (0, 5) + as <- replicateM i (f (n `div` i)) + return (function s as) + +natGenerator :: Gen Expr +natGenerator = liftM (Nat . abs) arbitrary + +varGenerator :: [String] -> Gen Expr +varGenerator vars + | null vars = error "varGenerator: empty list" + | otherwise = oneof [ return (Var x) | x <- vars ] + +----------------------------------------------------------------------- +-- Pretty printer + +instance Show Expr where + show = showExpr operatorTable + +showExpr :: OperatorTable -> Expr -> String +showExpr table = rec 0 + where + rec _ (Nat n) = show n + rec _ (Var s) + | all isAlphaNum s = s + | otherwise = "\"" ++ s ++ "\"" + rec i expr = + case getFunction expr of + -- To do: remove special case for sqrt + Just (s, [a, b]) | s == rootSymbol && b == Nat 2 -> + parIf (i>10000) $ unwords ["sqrt", rec 10001 a] + Just (s, as) -> + case (lookup s symbolTable, as) of + (Just (InfixLeft, n, op), [x, y]) -> + parIf (i>n) $ concat [rec n x, op, rec (n+1) y] + (Just (InfixRight, n, op), [x, y]) -> + parIf (i>n) $ concat [rec (n+1) x, op, rec n y] + (Just (Prefix, n, op), [x]) -> -- i>=5 prevents "3--5" + parIf (i>=n) $ concat [op, rec (n+1) x] + _ -> + parIf (not (null as) && i>10000) $ unwords (show s : map (rec 10001) as) + Nothing -> + error "showExpr" + + symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ] + + parIf b = if b then par else id + par s = "(" ++ s ++ ")" + +instance MetaVar Expr where + metaVar n = Var ('_' : show n) + isMetaVar (Var ('_':is)) | not (null is) && all isDigit is = Just (read is) + isMetaVar _ = Nothing + +instance ShallowEq Expr where + shallowEq (Nat a) (Nat b) = a == b + shallowEq (Var a) (Var b) = a == b + shallowEq expr1 expr2 = + case (getFunction expr1, getFunction expr2) of + (Just (s1, as), Just (s2, bs)) -> + s1 == s2 && length as == length bs + _ -> False + +instance Rewrite Expr + +----------------------------------------------------------------------- +-- AC Theory for expression +{- +exprACs :: Operators Expr +exprACs = [plusOperator, timesOperator] + +plusOperator, timesOperator :: Operator Expr +plusOperator = acOperator (+) isPlus +timesOperator = acOperator (*) isTimes + +collectPlus, collectTimes :: Expr -> [Expr] +collectPlus = collectWithOperator plusOperator +collectTimes = collectWithOperator timesOperator + +size :: Expr -> Int +size e = 1 + compos 0 (+) size e +-} +collectVars :: Expr -> [String] +collectVars e = [ s | Var s <- universe e ] + +hasVars :: Expr -> Bool +hasVars = not . noVars + +noVars :: Expr -> Bool +noVars = null . collectVars diff --git a/src/Domain/Math/Expr/Parser.hs b/src/Domain/Math/Expr/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Parser.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Parser + ( scannerExpr, parseExpr, parseWith, pExpr + , pEquations, pEquation, pOrList, pFractional + ) where + +import Prelude hiding ((^)) +import Text.Parsing hiding (pParens) +import Control.Monad +import Data.List +import Data.Maybe +import Common.Transformation +import Domain.Math.Data.Equation +import Domain.Math.Expr.Data +import Domain.Math.Expr.Symbolic +import Domain.Math.Expr.Symbols +import Domain.Math.Data.OrList +import Test.QuickCheck (arbitrary) + +import Text.OpenMath.Dictionary.Arith1 +import Text.OpenMath.Dictionary.Logic1 +import Text.OpenMath.Dictionary.Relation1 +import Text.OpenMath.Dictionary.Calculus1 +import Text.OpenMath.Dictionary.Fns1 +import Text.OpenMath.Dictionary.Transc1 + +symbols :: [Symbol] +symbols = nubBy (\x y -> symbolName x == symbolName y) $ + concat dictionaries + +dictionaries :: [[Symbol]] +dictionaries = + [ arith1List, logic1List, relation1List, calculus1List + , fns1List, transc1List + ] + +dictionaryNames :: [String] +dictionaryNames = mapMaybe dictionary (concatMap (take 1) dictionaries) + +scannerExpr :: Scanner +scannerExpr = defaultScanner + { keywords = "sqrt" : map symbolName symbols ++ dictionaryNames + , keywordOperators = ["==" ] + , specialCharacters = "+-*/^()[]{},." + } + +parseWith :: TokenParser a -> String -> Either SyntaxError a +parseWith p = f . parse p . scanWith scannerExpr + where + f (e, []) = Right e + f (_, xs) = Left $ ErrorMessage $ unlines $ map show xs + +parseExpr :: String -> Either SyntaxError Expr +parseExpr = parseWith pExpr + +pExpr :: TokenParser Expr +pExpr = expr6 + +-- This expression could have a fraction at top-level: both the numerator +-- and denominator are atoms, optionally preceded by a (unary) minus +pFractional :: TokenParser Expr +pFractional = expr6u -- flip ($) <$> expr6u <*> optional (flip (/) <$ pKey "/" <*> expr6u) id + +expr6, expr6u, expr7, expr8, term, atom :: TokenParser Expr +expr6 = pChainl ((+) <$ pKey "+" <|> (-) <$ pKey "-") expr6u +expr6u = optional (Negate <$ pKey "-") id <*> expr7 +expr7 = pChainl ((*) <$ pKey "*" <|> (/) <$ pKey "/") expr8 +expr8 = pChainr ((^) <$ pKey "^") term +term = symb <*> pList atom + <|> atom +atom = fromInteger <$> pInteger + <|> (Var . fst) <$> pVarid + <|> pParens pExpr + +symb :: TokenParser ([Expr] -> Expr) +symb = unqualifiedSymb + <|> qualifiedSymb + -- To fix: sqrt expects exactly one argument + <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" + +unqualifiedSymb :: TokenParser ([Expr] -> Expr) +unqualifiedSymb = pChoice (map (\s -> function s <$ pKey (symbolName s)) symbols) + +qualifiedSymb :: TokenParser ([Expr] -> Expr) +qualifiedSymb = pChoice (map f dictionaries) + where + f xs = case map dictionary xs of + Just d:_ -> pKey d <* pSpec '.' *> pChoice (map g xs) + _ -> pFail + g s = function s <$ pKey (symbolName s) + +pEquations :: TokenParser a -> TokenParser (Equations a) +pEquations = pLines True . pEquation + +pEquation :: TokenParser a -> TokenParser (Equation a) +pEquation p = (:==:) <$> p <* pKey "==" <*> p + +pOrList :: TokenParser a -> TokenParser (OrList a) +pOrList p = (join . orList) <$> pSepList pTerm (pKey "or") + where + pTerm = return <$> p + <|> true <$ pKey "true" + <|> false <$ pKey "false" + pSepList p q = (:) <$> p <*> pList (q *> p) + +pParens :: TokenParser a -> TokenParser a +pParens p = pKey "(" *> p <* pKey ")" + +----------------------------------------------------------------------- +-- Argument descriptor (for parameterized rules) + +instance Argument Expr where + makeArgDescr = exprArgDescr + +exprArgDescr :: String -> ArgDescr Expr +exprArgDescr descr = ArgDescr descr Nothing (either (const Nothing) Just . parseExpr) show arbitrary diff --git a/src/Domain/Math/Expr/Symbolic.hs b/src/Domain/Math/Expr/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Symbolic.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Symbolic + ( Symbol(..) + , module Domain.Math.Expr.Symbolic + ) where + +import Control.Monad +import Text.OpenMath.Symbol + +------------------------------------------------------------------- +-- Type class for symbolic representations + +class Symbolic a where + -- constructing + variable :: String -> a + symbol :: Symbol -> a + function :: Symbol -> [a] -> a + -- matching + getVariable :: MonadPlus m => a -> m String + getSymbol :: MonadPlus m => a -> m Symbol + getFunction :: MonadPlus m => a -> m (Symbol, [a]) + isSymbol :: MonadPlus m => Symbol -> a -> m [a] + -- default definition + symbol s = function s [] + getSymbol a = do + (t, as) <- getFunction a + guard (null as) + return t + isSymbol s a = do + (t, as) <- getFunction a + guard (s==t) + return as + +unary :: Symbolic a => Symbol -> a -> a +unary f a = function f [a] + +binary :: Symbolic a => Symbol -> a -> a -> a +binary f a b = function f [a, b] + +isConst :: Symbolic a => Symbol -> a -> Bool +isConst s = maybe False null . isSymbol s + +isUnary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m a +isUnary s a = + case isSymbol s a of + Just [x] -> return x + _ -> mzero + +isBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a) +isBinary s a = + case isSymbol s a of + Just [x, y] -> return (x, y) + _ -> mzero + +-- left-associative by default +isAssoBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a) +isAssoBinary s a = + case isSymbol s a of + Just [x, y] -> return (x, y) + Just (x:xs) | length xs > 1 -> return (x, function s xs) + _ -> mzero diff --git a/src/Domain/Math/Expr/Symbols.hs b/src/Domain/Math/Expr/Symbols.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Symbols.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Symbols + ( module Domain.Math.Expr.Symbols + -- arith1 + , plusSymbol, timesSymbol, minusSymbol, divideSymbol + , rootSymbol, powerSymbol + -- logic1 + , orSymbol, trueSymbol, falseSymbol + -- list1 + , listSymbol + -- relation1 + , eqSymbol + -- calculus1 + , diffSymbol + -- nusm1 + , piSymbol + -- fns1 + , lambdaSymbol + -- transc1 + , sinSymbol, cosSymbol, lnSymbol + ) where + +import Control.Monad +import Domain.Math.Expr.Symbolic +import Text.OpenMath.Symbol +import Text.OpenMath.Dictionary.Arith1 +import Text.OpenMath.Dictionary.Logic1 +import Text.OpenMath.Dictionary.List1 +import Text.OpenMath.Dictionary.Relation1 +import Text.OpenMath.Dictionary.Calculus1 +import Text.OpenMath.Dictionary.Nums1 +import Text.OpenMath.Dictionary.Fns1 +import Text.OpenMath.Dictionary.Transc1 + +-- Check (rationalSymbol , oms "nums1" "rational") + +------------------------------------------------------------- +-- Operator fixities + +type OperatorTable = [(Associativity, [(Symbol, String)])] + +data Associativity = InfixLeft | InfixRight | Prefix -- InfixNon | Postfix + deriving (Show, Eq) + +operatorTable :: OperatorTable +operatorTable = + [ (InfixLeft, [(plusSymbol, "+"), (minusSymbol, "-")]) -- 6 + , (Prefix, [(negateSymbol, "-")]) -- 6+ + , (InfixLeft, [(timesSymbol, "*"), (divideSymbol, "/")]) -- 7 + , (InfixRight, [(powerSymbol, "^")]) -- 8 + ] + +------------------------------------------------------------- +-- Extra math symbols + +-- rename +negateSymbol = unaryMinusSymbol + +absSymbol = extraSymbol "abs" +signumSymbol = extraSymbol "signum" +logSymbol = extraSymbol "log" -- in Haskell, logbase e = log +expSymbol = extraSymbol "exp" -- exp 1 ~= 2.718 +tanSymbol = extraSymbol "tan" +asinSymbol = extraSymbol "asin" +atanSymbol = extraSymbol "atan" +acosSymbol = extraSymbol "acos" +sinhSymbol = extraSymbol "sinh" +tanhSymbol = extraSymbol "tanh" +coshSymbol = extraSymbol "cosh" +asinhSymbol = extraSymbol "asinh" +atanhSymbol = extraSymbol "atanh" +acoshSymbol = extraSymbol "acosh" +bottomSymbol = extraSymbol "error" +fcompSymbol = extraSymbol "compose" + +------------------------------------------------------------- +-- Some match functions + +isPlus, isTimes, isMinus, isDivide :: + (Symbolic a, MonadPlus m) => a -> m (a, a) +isNegate :: (Symbolic a, MonadPlus m) => a -> m a + +isPlus = isAssoBinary plusSymbol +isTimes = isAssoBinary timesSymbol +isMinus = isBinary minusSymbol +isDivide = isBinary divideSymbol +isNegate = isUnary negateSymbol + +infixr 8 ^ + +(^) :: Symbolic a => a -> a -> a +(^) = binary powerSymbol + +root :: Symbolic a => a -> a -> a +root = binary rootSymbol diff --git a/src/Domain/Math/Expr/Views.hs b/src/Domain/Math/Expr/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Expr/Views.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Expr.Views where + +import Prelude hiding (recip, (^)) +import Common.View +import Domain.Math.Expr.Data +import Domain.Math.Expr.Symbols +import Control.Monad +import Data.List (nub) + +------------------------------------------------------------ +-- Smart constructors + +(.+.) :: Expr -> Expr -> Expr +Nat 0 .+. b = b +a .+. Nat 0 = a +a .+. Negate b = a .-. b +a .+. b = a :+: b + +(.-.) :: Expr -> Expr -> Expr +Nat 0 .-. b = neg b +a .-. Nat 0 = a +a .-. Negate b = a .+. b +a .-. b = a :-: b + +neg :: Expr -> Expr +neg (Nat 0) = 0 +neg (Negate a) = a +neg (a :+: b) = neg a .-. b +neg (a :-: b) = neg a .+. b +neg a = Negate a + +(.*.) :: Expr -> Expr -> Expr +Nat 0 .*. _ = Nat 0 +_ .*. Nat 0 = Nat 0 +Nat 1 .*. b = b +a .*. Nat 1 = a +Negate a .*. b = neg (a .*. b) +a .*. Negate b = neg (a .*. b) +a .*. (Nat 1 :/: b) = a ./. b +a .*. b = a :*: b + +(./.) :: Expr -> Expr -> Expr +a ./. Nat 1 = a +Negate a ./. b = neg (a ./. b) +a ./. Negate b = neg (a ./. b) +a ./. b = a :/: b + +recip :: Expr -> Expr +recip (Nat 1 :/: a) = a +recip a = Nat 1 :/: a + +(.^.) :: Expr -> Expr -> Expr +Nat 0 .^. _ = Nat 0 +Nat 1 .^. _ = Nat 1 +_ .^. Nat 0 = Nat 1 +a .^. Nat 1 = a +a .^. b = a ^ b + +------------------------------------------------------------ +-- Views of binary constructors + +plusView :: View Expr (Expr, Expr) +plusView = makeView matchPlus (uncurry (.+.)) + where + matchPlus :: Match Expr (Expr, Expr) + matchPlus (a :+: b) = Just (a, b) + matchPlus (a :-: b) = Just (a, neg b) + matchPlus (Negate a) = do (x, y) <- matchPlus a + Just (neg x, neg y) + matchPlus _ = Nothing + +timesView :: View Expr (Expr, Expr) +timesView = makeView matchTimes (uncurry (.*.)) + where + matchTimes :: Match Expr (Expr, Expr) + matchTimes (a :*: b) = Just (a, b) + matchTimes (Negate a) = do (x, y) <- matchTimes a + Just (neg x, y) + matchTimes _ = Nothing + +divView :: View Expr (Expr, Expr) +divView = makeView matchDiv (uncurry (./.)) + where + matchDiv :: Match Expr (Expr, Expr) + matchDiv (a :/: b) = Just (a, b) + matchDiv (Negate a) = do (x, y) <- matchDiv a + Just (neg x, y) + matchDiv _ = Nothing + +------------------------------------------------------------ +-- Some constant views + +conView :: View Expr Integer +conView = makeView f fromInteger + where + f (Nat n) = return n + f (Negate e) = fmap negate (f e) + f _ = Nothing + +fractionView :: View Expr (Integer, Integer) -- second component is positive +fractionView = divView >>> signs >>> (conView *** conView) + where + signs = makeView (Just . f) id + f (a, Negate b) = f (neg a, b) + f (a, b) = (a, b) + +------------------------------------------------------------- +-- Sums and products + +sumView :: View Expr [Expr] +sumView = makeView (return . ($ []) . f False) (foldl (.+.) 0) + where + f n (a :+: b) = f n a . f n b + f n (a :-: b) = f n a . f (not n) b + f n (Negate a) = f (not n) a + f n e = if n then (neg e:) else (e:) + +simpleProductView :: View Expr (Bool, [Expr]) +simpleProductView = makeView (Just . second ($ []) . f) g + where + f (a :*: b) = f a &&& f b + f (Negate a) = first not (f a) + f e = (False, (e:)) + + (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2) + + g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) + +productView :: View Expr (Bool, [Expr]) +productView = makeView (Just . second ($ []) . f False) g + where + f r (a :*: b) = f r a &&& f r b + f r (a :/: b) = f r a &&& f (not r) b + f r (Negate a) = first not (f r a) + f r e = (False, if r then (recip e:) else (e:)) + + (n1, g1) &&& (n2, g2) = (n1 /= n2, g1 . g2) + + g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs) + +-- helper to determine the name of the variable (move to a different module?) +selectVar :: Expr -> Maybe String +selectVar = f . nub . collectVars + where + f [] = Just "x" -- exceptional case (e.g., for constants) + f [a] = Just a + f _ = Nothing diff --git a/src/Domain/Math/Numeric/Exercises.hs b/src/Domain/Math/Numeric/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Exercises.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Exercises + ( naturalExercise, integerExercise + , rationalExercise, fractionExercise + ) where + +import Common.Exercise +import Common.Strategy +import Common.View +import Domain.Math.Expr +import Domain.Math.Expr.Parser +import Domain.Math.Numeric.Strategies +import Domain.Math.Numeric.Views +import Domain.Math.Numeric.Generators +import Domain.Math.Examples.DWO1 (calculateResults) +import Common.Context + +------------------------------------------------------------ +-- Exercises + +numericExercise :: LabeledStrategy Expr -> Exercise Expr +numericExercise s = makeExercise + { status = Provisional + , parser = parseExpr + , equivalence = viewEquivalent rationalView + , strategy = liftToContext s + } + +naturalExercise :: Exercise Expr +naturalExercise = (numericExercise naturalStrategy) + { description = "simplify expression (natural numbers)" + , exerciseCode = makeCode "math" "natural" + , isReady = (`belongsTo` integerNormalForm) + , examples = concat calculateResults + } + +integerExercise :: Exercise Expr +integerExercise = (numericExercise integerStrategy) + { description = "simplify expression (integers)" + , exerciseCode = makeCode "math" "integer" + , isReady = (`belongsTo` integerNormalForm) + , examples = concat calculateResults + } + +rationalExercise :: Exercise Expr +rationalExercise = (numericExercise rationalStrategy) + { description = "simplify expression (rational numbers)" + , exerciseCode = makeCode "math" "rational" + , isReady = (`belongsTo` rationalNormalForm) + , randomExercise = simpleGenerator (rationalGenerator 5) + } + +fractionExercise :: Exercise Expr +fractionExercise = (numericExercise fractionStrategy) + { description = "simplify expression (fractions)" + , exerciseCode = makeCode "math" "fraction" + , isReady = (`belongsTo` rationalNormalForm) + , randomExercise = simpleGenerator (rationalGenerator 5) + } diff --git a/src/Domain/Math/Numeric/Generators.hs b/src/Domain/Math/Numeric/Generators.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Generators.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Generators + ( integerGenerator, rationalGenerator, numGenerator + , ratioGen, ratioExprGen, ratioExprGenNonZero, nonZero + ) where + +import Control.Monad +import Common.View +import Common.Utils (ratioGen) +import Domain.Math.Numeric.Views +import Test.QuickCheck +import Domain.Math.Expr +import Domain.Math.Expr.Symbols +import Domain.Math.Expr.Symbolic + +------------------------------------------------------------------- +-- Generators + +-- tailored towards generating "int" expressions (also prevents +-- division by zero) +integerGenerator :: Int -> Gen Expr +integerGenerator = symbolGenerator extras numSymbols + where + extras n = natGenerator : [ divGen n | n > 0 ] + divGen n = do + e1 <- integerGenerator (n `div` 2) + e2 <- integerGenerator (n `div` 2) + case (match integerView e1, match integerView e2) of + (Just a, Just b) + | b == 0 -> oneof $ map return + [ e1 :/: (e2 + 1), e1 :/: (e2 - 1) + , e1 :/: (1 + e2), e1 :/: (1 - e2) + ] + | a `mod` b == 0 -> + return (e1 :/: e2) + | otherwise -> do -- change numerator + i <- arbitrary + let m1 = fromInteger ((a `mod` b) + i*b) + m2 = fromInteger (b - (a `mod` b) + i*b) + oneof $ map return + [ (e1 - m1) :/: e2, (m1 - e1) :/: e2 + , (e1 + m2) :/: e2, (m2 + e1) :/: e2 + ] + _ -> error "integerGenerator" + +-- Prevents division by zero +rationalGenerator :: Int -> Gen Expr +rationalGenerator = symbolGenerator extras numSymbols + where + extras n = natGenerator : [ divGen n | n > 0 ] + divGen n = do + e1 <- rationalGenerator (n `div` 2) + e2 <- rationalGenerator (n `div` 2) + case match rationalView e2 of + Just b | b == 0 -> return e1 + _ -> return (e1 :/: e2) + +-- Also generates "division-by-zero" expressions +numGenerator :: Int -> Gen Expr +numGenerator = symbolGenerator (const [natGenerator]) $ + (divideSymbol, Just 2):numSymbols + +ratioExprGen :: Int -> Gen Expr +ratioExprGen n = liftM fromRational $ ratioGen n (n `div` 4) + +ratioExprGenNonZero :: Int -> Gen Expr +ratioExprGenNonZero n = liftM fromRational $ nonZero $ ratioGen n (n `div` 4) + +nonZero :: Num a => Gen a -> Gen a +nonZero = liftM (\a -> if a==0 then 1 else a) + +numSymbols :: [(Symbol, Maybe Int)] +numSymbols = + (negateSymbol, Just 1) : + zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2)) diff --git a/src/Domain/Math/Numeric/Laws.hs b/src/Domain/Math/Numeric/Laws.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Laws.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Algebraic laws, for testing purposes +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Laws + ( numLaws, testNumLaws, testNumLawsWith + , fracLaws, testFracLaws, testFracLawsWith + ) where + +import Test.QuickCheck + +testNumLaws :: Num a => String -> Gen a -> IO () +testNumLaws = testNumLawsWith (==) + +testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> IO () +testNumLawsWith eq s g = do + putStrLn $ "Testing Num instance for " ++ s + mapM_ ($ g) (numLaws eq) + +testFracLaws :: Fractional a => String -> Gen a -> IO () +testFracLaws = testFracLawsWith (==) + +testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> IO () +testFracLawsWith eq s g = do + putStrLn $ "Testing Fractional instance for " ++ s + mapM_ ($ g) (fracLaws eq) + +numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> IO ()] +numLaws eq = + [ law1 "plus zero left" $ \a -> 0+a == a + , law1 "plus zero right" $ \a -> a+0 == a + , law2 "plus comm" $ \a b -> a+b == b+a + , law3 "plus trans" $ \a b c -> a+(b+c) == (a+b)+c + , law1 "negate zero" $ \a -> -0 == 0 `asTypeOf` a + , law1 "negate double" $ \a -> -(-a) == a + , law1 "minus zero left" $ \a -> 0-a == -a + , law1 "minus zero right" $ \a -> a-0 == a + , law2 "negate plus" $ \a b -> -(a+b) == -a-b + , law2 "negate minus" $ \a b -> -(a-b) == -a+b + , law2 "plus negate" $ \a b -> a+(-b) == a-b + , law1 "times zero left" $ \a -> 0*a == 0 + , law1 "times zero right" $ \a -> a*0 == 0 + , law1 "times one left" $ \a -> 1*a == a + , law1 "times one right" $ \a -> a*1 == a + , law2 "times comm" $ \a b -> a*b == b*a + , law3 "times trans" $ \a b c -> a*(b*c) == (a*b)*c + , law2 "times negate left" $ \a b -> (-a)*b == -(a*b) + , law2 "times negate right" $ \a b -> a*(-b) == -(a*b) + , law3 "times plus left" $ \a b c -> (a+b)*c == a*c + b*c + , law3 "times plus right" $ \a b c -> a*(b+c) == a*b + a*c + , law3 "times minus left" $ \a b c -> (a-b)*c == a*c - b*c + , law3 "times minus right" $ \a b c -> a*(b-c) == a*b - a*c + ] + where + infix 4 == + a == b = property (a `eq` b) + +fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> IO ()] +fracLaws eq = + [ law3 "division numerator" $ \a b c -> (a/b)/c == a/(b*c) <| b/=0 && c/=0 + , law3 "division denominator" $ \a b c -> a/(b/c) == a*(c/b) <| b/=0 && c/=0 + , law1 "zero numerator" $ \a -> 0/a == 0 <| a/=0 + , law1 "one numerator" $ \a -> 1/a == recip a <| a/=0 + , law1 "one denominator" $ \a -> a/1 == a + , law1 "division is one" $ \a -> a/a == 1 <| a/=0 + , law1 "recip double" $ \a -> a == recip (recip a) <| a/=0 + , law3 "times division left" $ \a b c -> (a/b)*c == (a*c)/b <| b/=0 + , law3 "times division right" $ \a b c -> a*(b/c) == (a*b)/c <| c/=0 + , law3 "plus division left" $ \a b c -> (a/b)+c == (a+c*b)/b <| b/=0 + , law3 "plus division right" $ \a b c -> a+(b/c) == (a*c+b)/c <| c/=0 + , law3 "minus division left" $ \a b c -> (a/b)-c == (a-c*b)/b <| b/=0 + , law3 "minus division right" $ \a b c -> a-(b/c) == (a*c-b)/c <| c/=0 + , law2 "negate numerator" $ \a b -> a/(-b) == -(a/b) <| b/=0 + , law2 "negate denominator" $ \a b -> (-a)/b == -(a/b) <| b/=0 + , law2 "recip times" $ \a b -> recip (a*b) == recip a*recip b <| a/=0 && b/=0 + , law2 "recip division" $ \a b -> recip (a/b) == b/a <| a/=0 && b/=0 + ] + where + infix 4 == + a == b = property (a `eq` b) + infix 1 <| + p <| b = b ==> p + +-- local helper-functions +report :: String -> Property -> IO () +report s p = putStr (take 30 ("- " ++ s ++ repeat ' ')) >> quickCheck p + +law1 :: Show a => String -> (a -> Property) -> Gen a -> IO () +law1 s p g = report s (make g id p) + +law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> IO () +law2 s p g = report s (make g (make g id) p) + +law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> IO () +law3 s p g = report s (make g (make g (make g id)) p) + +make g c p = forAll g (c . p) diff --git a/src/Domain/Math/Numeric/Rules.hs b/src/Domain/Math/Numeric/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Rules.hs @@ -0,0 +1,162 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Rules where + +import Common.Transformation +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Expr.Symbols +import Domain.Math.Numeric.Views +import Common.View + +------------------------------------------------------------ +-- Rules + +calcRuleName :: String -> String -> String +calcRuleName opName viewName = + "calculate " ++ opName ++ " [" ++ viewName ++ "]" + +calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e +calcBinRule opName op m viewName v = + makeSimpleRule (calcRuleName opName viewName) $ \e -> + do (e1, e2) <- m e + a <- match v e1 + b <- match v e2 + return (build v (op a b)) + +calcPlusWith :: Num a => String -> View Expr a -> Rule Expr +calcPlusWith = calcBinRule "plus" (+) isPlus + +calcMinusWith :: Num a => String -> View Expr a -> Rule Expr +calcMinusWith = calcBinRule "minus" (-) isMinus + +calcTimesWith :: Num a => String -> View Expr a -> Rule Expr +calcTimesWith = calcBinRule "times" (*) isTimes + +calcDivisionWith :: Integral a => String -> View Expr a -> Rule Expr +calcDivisionWith viewName v = + makeSimpleRule (calcRuleName "division" viewName) $ \e -> + do (e1, e2) <- isDivide e + a <- match v e1 + b <- match v e2 + let (d, m) = divMod a b + guard (b /= 0 && m == 0) + return (build v d) + +negateZero :: Rule Expr +negateZero = makeSimpleRule "negate zero" f + where + f (Negate (Nat n)) | n == 0 = Just 0 + f _ = Nothing + +doubleNegate :: Rule Expr +doubleNegate = makeSimpleRule "double negate" f + where + f (Negate (Negate a)) = Just a + f _ = Nothing + +plusNegateLeft :: Rule Expr +plusNegateLeft = makeSimpleRule "plus negate left" f + where + f (Negate a :+: b) = Just (b :-: a) + f _ = Nothing + +plusNegateRight :: Rule Expr +plusNegateRight = makeSimpleRule "plus negate right" f + where + f (a :+: Negate b) = Just (a :-: b) + f _ = Nothing + +minusNegateLeft :: Rule Expr +minusNegateLeft = makeSimpleRule "minus negate left" f + where + f (Negate a :-: b) = Just (Negate (a :+: b)) + f _ = Nothing + +minusNegateRight :: Rule Expr +minusNegateRight = makeSimpleRule "minus negate right" f + where + f (a :-: Negate b) = Just (a :+: b) + f _ = Nothing + +timesNegateLeft :: Rule Expr +timesNegateLeft = makeSimpleRule "times negate left" f + where + f (Negate a :*: b) = Just (Negate (a :*: b)) + f _ = Nothing + +timesNegateRight :: Rule Expr +timesNegateRight = makeSimpleRule "times negate right" f + where + f (a :*: Negate b) = Just (Negate (a :*: b)) + f _ = Nothing + +divisionNegateLeft :: Rule Expr +divisionNegateLeft = makeSimpleRule "division negate left" f + where + f (Negate a :/: b) = Just (Negate (a :/: b)) + f _ = Nothing + +divisionNegateRight :: Rule Expr +divisionNegateRight = makeSimpleRule "division negate right" f + where + f (a :/: Negate b) = Just (Negate (a :/: b)) + f _ = Nothing + +divisionNumerator :: Rule Expr +divisionNumerator = makeSimpleRule "division numerator" f + where + f ((a :/: b) :/: c) = Just (a :/: (b :*: c)) + f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c))) + f _ = Nothing + +divisionDenominator :: Rule Expr +divisionDenominator = makeSimpleRule "division denominator" f + where + f (a :/: (b :/: c)) = Just ((a :*: c) :/: b) + f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b)) + f _ = Nothing + +simplerFraction :: Rule Expr +simplerFraction = makeSimpleRule "simpler fraction" $ \expr -> do + new <- canonical rationalRelaxedForm expr + guard (expr /= new) + return new + +fractionPlus :: Rule Expr -- also minus +fractionPlus = makeSimpleRule "fraction plus" $ \expr -> do + (e1, e2) <- match plusView expr + (a, b) <- match fractionForm e1 + (c, d) <- match fractionForm e2 + guard (b == d) + return (build fractionForm (a+c, b)) + +fractionPlusScale :: Rule Expr -- also minus +fractionPlusScale = makeSimpleRuleList "fraction plus scale" $ \expr -> do + (e1, e2) <- matchM plusView expr + (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) + (c, d) <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2)) + guard (b /= 0 && d /= 0) + let bd = lcm b d + e1n = build fractionForm (a * (bd `div` b), bd) + e2n = build fractionForm (c * (bd `div` d), bd) + [ build plusView (e1n, e2) | b /= bd ] ++ [ + build plusView (e1, e2n) | d /= bd ] + +fractionTimes :: Rule Expr +fractionTimes = makeSimpleRule "fraction times" f + where + f (e1 :*: e2) = do + (a, b) <- (matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e1)) + (c, d) <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2)) + return (build fractionForm (a*c, b*d)) + f _ = Nothing diff --git a/src/Domain/Math/Numeric/Strategies.hs b/src/Domain/Math/Numeric/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Strategies.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Strategies + ( naturalStrategy, integerStrategy + , rationalStrategy, fractionStrategy + , testAll + ) where + +import Common.Apply +import Common.Strategy +import Common.Transformation +import Common.Uniplate +import Common.View +import Domain.Math.Expr +import Domain.Math.Numeric.Rules +import Domain.Math.Numeric.Views +import Domain.Math.Numeric.Generators +import Prelude hiding (repeat) +import Test.QuickCheck hiding (label) + +------------------------------------------------------------ +-- Strategies + +naturalStrategy :: LabeledStrategy Expr +naturalStrategy = label "simplify" $ repeat $ alternatives $ map swRule + [ calcPlusWith "nat" natView + , calcMinusWith "nat" natView + , calcTimesWith "nat" natView + , calcDivisionWith "nat" natView + , doubleNegate + , negateZero + , plusNegateLeft + , plusNegateRight + , minusNegateLeft + , minusNegateRight + , timesNegateLeft + , timesNegateRight + , divisionNegateLeft + , divisionNegateRight + ] + where + natView = makeView f fromInteger + where + f (Nat n) = Just n + f _ = Nothing + +integerStrategy :: LabeledStrategy Expr +integerStrategy = label "simplify" $ repeat $ alternatives $ map swRule + [ calcPlusWith "int" integerNormalForm + , calcMinusWith "int" integerNormalForm + , calcTimesWith "int" integerNormalForm + , calcDivisionWith "int" integerNormalForm + , doubleNegate + , negateZero + ] + +rationalStrategy :: LabeledStrategy Expr +rationalStrategy = label "simplify" $ repeat $ alternatives $ map swRule + [ calcPlusWith "rational" rationalRelaxedForm + , calcMinusWith "rational" rationalRelaxedForm + , calcTimesWith "rational" rationalRelaxedForm + , calcDivisionWith "int" integerNormalForm + , doubleNegate + , negateZero + , divisionDenominator + , divisionNumerator + , simplerFraction + ] + +fractionStrategy :: LabeledStrategy Expr +fractionStrategy = label "simplify" $ repeat $ alternatives $ map swRule + [ fractionPlus, fractionPlusScale, fractionTimes + , calcPlusWith "int" integerNormalForm + , calcMinusWith "int" integerNormalForm + , calcTimesWith "int" integerNormalForm -- not needed? + , calcDivisionWith "int" integerNormalForm + , doubleNegate + , negateZero + , divisionDenominator + , divisionNumerator + , simplerFraction -- only apply when fractionPlusScale is not applicable + ] + +swRule :: Uniplate a => Rule a -> Rule a +swRule r = makeSimpleRuleList (name r) (somewhereM (applyAll r)) + +------------------------------------------------------------ +-- Test code + +testAll :: IO () +testAll = sequence_ [test1, test2, test3, test4] + +test1 = quickCheck $ forAll (sized integerGenerator) $ \e -> + Prelude.not (e `belongsTo` integerView) || + applyD naturalStrategy e `belongsTo` integerNormalForm + +test2 = quickCheck $ forAll (sized integerGenerator) $ \e -> + Prelude.not (e `belongsTo` integerView) || + applyD integerStrategy e `belongsTo` integerNormalForm + +test3 = quickCheck $ forAll (sized rationalGenerator) $ \e -> + Prelude.not (e `belongsTo` rationalView) || + applyD rationalStrategy e `belongsTo` rationalNormalForm + +test4 = quickCheck $ forAll (sized rationalGenerator) $ \e -> + Prelude.not (e `belongsTo` rationalView) || + applyD fractionStrategy e `belongsTo` rationalNormalForm + +{- testC = quickCheck $ forAll (sized rationalGenerator) $ \e -> + let a = cleanUp e + in a == cleanUp a -} diff --git a/src/Domain/Math/Numeric/Views.hs b/src/Domain/Math/Numeric/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Numeric/Views.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Numeric.Views + ( integralView, realView + , integerView, rationalView, doubleView + , integerNormalForm, rationalNormalForm, rationalRelaxedForm, fractionForm + , intDiv, fracDiv, exprToNum + ) where + +import Common.View +import Control.Monad +import Data.Ratio +import Domain.Math.Expr + +------------------------------------------------------------------- +-- Numeric views + +integralView :: Integral a => View Expr a +integralView = makeView (exprToNum f) fromIntegral + where + f s [x, y] + | s == divideSymbol = + intDiv x y + | s == powerSymbol = do + guard (y >= 0) + return (x Prelude.^ y) + f _ _ = Nothing + +realView :: RealFrac a => View Expr a +realView = makeView (exprToNum f) (fromRational . toRational) + where + f s [x, y] + | s == divideSymbol = + fracDiv x y + | s == powerSymbol = do + let ry = toRational y + guard (denominator ry == 1) + return (x Prelude.^ numerator ry) + f _ _ = Nothing + +integerView :: View Expr Integer +integerView = integralView + +rationalView :: View Expr Rational +rationalView = makeView (match realView) fromRational + +-- No floating view +doubleView :: View Expr Double +doubleView = makeView (exprToNum doubleSym) + (fromRational . flip approxRational 0.0001) + +------------------------------------------------------------------- +-- Numeric views in normal form + +-- N or -N (where n is a natural number) +integerNormalForm :: View Expr Integer +integerNormalForm = makeView (optionNegate f) fromInteger + where + f (Nat n) = Just n + f _ = Nothing + +rationalNormalForm :: View Expr Rational +rationalNormalForm = makeView (optionNegate f) fromRational + where + f (Nat a :/: Nat b) = do + guard (a > 0 && b > 1 && gcd a b == 1) + Just (fromInteger a / fromInteger b) + f (Nat n) = Just (fromInteger n) + f _ = Nothing + +fractionForm :: View Expr (Integer, Integer) +fractionForm = makeView f (\(a, b) -> (fromInteger a :/: fromInteger b)) + where + f (Negate a) = liftM (first negate) (g a) + f a = g a + g (e1 :/: e2) = do + a <- match integerNormalForm e1 + b <- match integerNormalForm e2 + guard (b /= 0) + return (a, b) + g _ = Nothing + +rationalRelaxedForm :: View Expr Rational +rationalRelaxedForm = makeView (optionNegate f) fromRational + where + f (e1 :/: e2) = do + a <- match integerNormalForm e1 + b <- match integerNormalForm e2 + fracDiv (fromInteger a) (fromInteger b) + f (Nat n) = Just (fromInteger n) + f _ = Nothing + +-- helper-function +optionNegate :: (MonadPlus m, Num a) => (Expr -> m a) -> Expr -> m a +optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b) +optionNegate f a = f a + +------------------------------------------------------------------- +-- Helper functions + +doubleSym :: Symbol -> [Double] -> Maybe Double +doubleSym s [x, y] + | s == divideSymbol = fracDiv x y + | s == powerSymbol = floatingPower x y + | s == rootSymbol && x >= 0 && y >= 1 = Just (x ** (1/y)) +doubleSym _ _ = Nothing + +-- General numeric interpretation function: constructors Sqrt and +-- (:/:) are interpreted with function +exprToNum :: (Monad m, Num a) => (Symbol -> [a] -> m a) -> Expr -> m a +exprToNum f = rec + where + rec expr = + case expr of + a :+: b -> liftM2 (+) (rec a) (rec b) + a :*: b -> liftM2 (*) (rec a) (rec b) + a :-: b -> liftM2 (-) (rec a) (rec b) + Negate a -> liftM negate (rec a) + Nat n -> return (fromInteger n) + a :/: b -> do x <- rec a; y <- rec b; f divideSymbol [x, y] + Sqrt a -> do x <- rec a; f rootSymbol [x, 2] + Var _ -> fail "exprToNum: variable" + Sym s xs -> mapM rec xs >>= f s + +intDiv :: Integral a => a -> a -> Maybe a +intDiv x y + | y /= 0 && m == 0 = Just d + | otherwise = Nothing + where (d, m) = x `divMod` y + +fracDiv :: Fractional a => a -> a -> Maybe a +fracDiv x y + | y /= 0 = Just (x / y) + | otherwise = Nothing + +floatingPower :: (Ord a, Floating a) => a -> a -> Maybe a +floatingPower x y + | x==0 && y<0 = Nothing + | otherwise = Just (x**y) diff --git a/src/Domain/Math/Polynomial/BuggyRules.hs b/src/Domain/Math/Polynomial/BuggyRules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/BuggyRules.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Some buggy rules catching common misconceptions on the abc-formula +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.BuggyRules where + +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.Polynomial.Views +import Domain.Math.Numeric.Views +import Common.View +import Common.Transformation +import Common.Traversable +import Control.Monad + +abcBuggyRules :: [Rule (OrList (Equation Expr))] +abcBuggyRules = [ minusB, twoA, minus4AC, oneSolution ] + +abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)]) + -> Transformation (OrList (Equation Expr)) +abcMisconception f = makeTransList "abc misconception" $ + onceJoinM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs + f x a b c + +minusB :: Rule (OrList (Equation Expr)) +minusB = buggyRule $ makeRule "abc misconception minus b" $ + abcMisconception $ \x a b c -> do + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) buggy = + let minus = if buggy then id else negate + in Var x :==: (minus (fromRational b) ? discr) / (2 * fromRational a) + [ orList [ f (+) True, f (-) True ], + orList [ f (+) False, f (-) True ], + orList [ f (+) True, f (-) False ]] + + +twoA :: Rule (OrList (Equation Expr)) +twoA = buggyRule $ makeRule "abc misconception two a" $ + abcMisconception $ \x a b c -> do + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) buggy = + let twice = if buggy then id else (2*) + in Var x :==: (-fromRational b ? discr) / twice (fromRational a) + [ orList [ f (+) True, f (-) True ], + orList [ f (+) False, f (-) True ], + orList [ f (+) True, f (-) False ]] + +minus4AC :: Rule (OrList (Equation Expr)) +minus4AC = buggyRule $ makeRule "abc misconception minus 4ac" $ + abcMisconception $ \x a b c -> do + let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c))) + f (?) buggy = + let op = if buggy then (+) else (-) + in Var x :==: (-fromRational b ? discr op) / (2 * fromRational a) + [ orList [ f (+) True, f (-) True ], + orList [ f (+) False, f (-) True ], + orList [ f (+) True, f (-) False ]] + +oneSolution :: Rule (OrList (Equation Expr)) +oneSolution = buggyRule $ makeRule "abc misconception one solution" $ + abcMisconception $ \x a b c -> do + let discr = sqrt (fromRational (b*b - 4 * a * c)) + f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a) + [ return $ f (+), return $ f (-) ] diff --git a/src/Domain/Math/Polynomial/CleanUp.hs b/src/Domain/Math/Polynomial/CleanUp.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/CleanUp.hs @@ -0,0 +1,325 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.CleanUp + ( cleanUp, cleanUpExpr, cleanUpExpr2, cleanUpSimple, collectLikeTerms + , normalizeSum, normalizeProduct + ) where + +import qualified Prelude +import Prelude hiding ((^), recip) +import Domain.Math.Data.SquareRoot +import Data.Maybe +import Common.Utils +import Data.Ratio +import Data.List +import Control.Monad +import Common.View +import Domain.Math.Numeric.Views +import Domain.Math.Expr +import Domain.Math.Power.Views +import Domain.Math.SquareRoot.Views +import Common.Uniplate +import Domain.Math.Simplification (smartConstructors) +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import qualified Domain.Math.Data.SquareRoot as SQ + +---------------------------------------------------------------------- +-- Expr normalization + +collectLikeTerms :: Expr -> Expr +collectLikeTerms = simplifyWith f sumView + where + f = normalizeSum . map (simplifyWith (second normalizeProduct) productView) + +normalizeProduct :: [Expr] -> [Expr] +normalizeProduct ys = f [ (match rationalView y, y) | y <- ys ] + where + f [] = [] + f ((Nothing , e):xs) = e:f xs + f ((Just r , _):xs) = + let cs = r : [ c | (Just c, _) <- xs ] + rest = [ x | (Nothing, x) <- xs ] + in build rationalView (product cs):rest + +normalizeSum :: [Expr] -> [Expr] +normalizeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] + where + pm :: Rational -> Expr -> (Rational, Expr) + pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of + (Just r1, _) -> pm (r*r1) e2 + (_, Just r1) -> pm (r*r1) e1 + _ -> (r, e1 .*. e2) + pm r (Negate e) = pm (negate r) e + pm r e = case match rationalView e of + Just r1 -> (r*r1, Nat 1) + Nothing -> (r, e) + + rec [] = [] + rec ((Nothing, e):xs) = e:rec xs + rec ((Just (r, a), e):xs) = new:rec rest + where + (js, rest) = partition (maybe False ((==a) . snd) . fst) xs + rs = r:map fst (mapMaybe fst js) + new | null js = e + | otherwise = build rationalView (sum rs) .*. a + +------------------------------------------------------------ +-- Testing + +-- List with hard cases +hardCases = map cleanUpExpr $ let x=Var "x" in + [ -1/2*x*(x/1) + , (x/(-3)) + , (x/(-3))^2 + , (0-x)*(-x)/(-5/2) + , (x/(-1))^2 + , (x/(-1))^2-(-7/2)*x/(-1) + , (x^2+0)*3 + , -(49/9*x^2+0^2)*(3/16) + , (0*x-(-x^2))*(-3) + , x^2 - x^2 + , x^2-x^2-(x+x)*1 + , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1 + , (-7+7*x)^2-(x*0)^2/(-3) + , 1*(x+93)+4 + , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9 + ] + +------------------------------------------------------------ +-- Cleaning up + +cleanUpSimple :: Expr -> Expr +cleanUpSimple = transform (f4 . f2 . f1) + where + use v = simplifyWith (assoPlus v) sumView + f1 = simplify rationalView + f2 = use identity + f4 = smartConstructors + +cleanUp :: OrList (Equation Expr) -> OrList (Equation Expr) +cleanUp = idempotent . join . fmap (keepEquation . fmap cleanUpExpr) + +keepEquation :: Equation Expr -> OrList (Equation Expr) +keepEquation eq@(a :==: b) + | any falsity (universe a ++ universe b) = false + | a == b = true + | otherwise = + case (match rationalView a, match rationalView b) of + (Just r, Just s) + | r == s -> true + | otherwise -> false + _ -> return eq + where + falsity (Sqrt e) = maybe False (<0) (match rationalView e) + falsity (_ :/: e) = maybe False (==0) (match rationalView e) + falsity _ = False + +-- also simplify square roots +cleanUpExpr2 :: Expr -> Expr +cleanUpExpr2 = cleanUpExpr . transform (simplify (squareRootViewWith rationalView)) + +cleanUpExpr :: Expr -> Expr +cleanUpExpr = cleanUpBU2 {- e = if a1==a2 && a2==a3 && a3==a3 && a3==a4 then a1 else error $ "\n\n\n" ++ unlines (map show + [e, a1, a2, a3, a4]) + where + a1 = cleanUpFix e + a2 = cleanUpBU e + a3 = cleanUpBU2 e + a4 = cleanUpLattice e -} + +------------------------------------------------------------ +-- Technique 1: fixed points of views + +cleanUpFix :: Expr -> Expr +cleanUpFix = fixpoint (f4 . f3 . f2 . f1) + where + use v = transform (simplifyWith (assoPlus v) sumView) + + f1 = use rationalView + f2 = use (squareRootViewWith rationalView) + f3 = use (powerFactorViewWith rationalView) + f4 = smartConstructors + +assoPlus :: View Expr a -> [Expr] -> [Expr] +assoPlus v = rec . map (simplify v) + where + rec (x:y:zs) = + case canonical v (x+y) of + Just a -> assoPlus v (a:zs) + Nothing -> x:assoPlus v (y:zs) + rec xs = xs + +------------------------------------------------------------ +-- Technique 2a: one bottom-up traversal + +cleanUpBU :: Expr -> Expr +cleanUpBU = transform (f4 . f3 . f2 . f1) + where + use v = simplifyWith (assoPlus v) sumView + + f1 = simplify rationalView + f2 = simplify (squareRootViewWith rationalView) + f3 = use (powerFactorViewWith rationalView) + f4 = smartConstructors + +------------------------------------------------------------ +-- Technique 2b: one bottom-up traversal + +cleanUpBU2 :: Expr -> Expr +cleanUpBU2 = transform $ \e -> + case ( canonical rationalView e + , canonical specialSqrtOrder e + , match sumView e + ) of + (Just a, _, _) -> a + (_, Just a, _) -> -- Just simplify order of terms with square roots for now + transform smart a + (_, _, Just xs) | length xs > 1 -> + build sumView (assoPlus (powerFactorViewWith rationalView) xs) + _ -> case canonical (powerFactorViewWith rationalView) e of + Just a -> a + Nothing -> smart e + +specialSqrtOrder :: View Expr [Expr] +specialSqrtOrder = sumView >>> makeView f id + where + make = match (squareRootViewWith rationalView) + cmp (_, x) (_, y) = g x `compare` g y + g = isNothing . fromSquareRoot + f xs = do + ys <- mapM make xs + return $ map fst $ sortBy cmp $ zip xs ys + +smart :: Expr -> Expr +smart (a :*: b) = a .*. b +smart (a :/: b) = a ./. b +smart (Sym s [x, y]) | s == powerSymbol = x .^. y +smart (Negate a) = neg a +smart (a :+: b) = a .+. b +smart (a :-: b) = a .-. b +smart (Sqrt (Nat n)) | i*i == n = fromInteger i + where i = SQ.isqrt n +smart e = e + +------------------------------------------------------------ +-- Technique 3: lattice of views + +data T = R Rational + | S (SquareRoot Rational) + | P String Rational Int + | E Expr deriving Show + +cleanUpLattice :: Expr -> Expr +cleanUpLattice = fromT . toT + +fromT :: T -> Expr +fromT (R r) = fromRational r +fromT (S s) = build (squareRootViewWith rationalView) s +fromT (P x r n) = build (powerFactorViewForWith x rationalView) (r, n) +fromT (E e) = e + +toT :: Expr -> T +toT (Nat n) = R (fromInteger n) +toT (x :/: y) = divT (toT x) (toT y) +toT (x :*: y) = mulT (toT x) (toT y) +toT (Var x) = P x 1 1 +toT (Sym s [x, y]) | s == powerSymbol = + case (toT x, toT y) of + (R x, R y) | denominator y == 1 -> + R (x Prelude.^ fromInteger (numerator y)) + (P x a n, R y) | denominator y == 1 -> + P x (a Prelude.^ numerator y) (n*fromInteger (numerator y)) + (x, y) -> E (fromT x .^. fromT y) +toT e@(Sqrt _) = fromMaybe (E e) $ do -- Also here, too simplistic + s <- match (squareRootViewWith rationalView) e + return (S s) +toT (Negate e) = negT (toT e) +toT expr = + case match sumView expr of + Just xs | length xs > 1 -> sumT (map toT xs) + _ -> error $ show expr + +negT :: T -> T +negT (R r) = R (negate r) +negT (S s) = S (negate s) +negT (P x r n) = P x (negate r) n +negT (E e) = E (neg e) + +sumT :: [T] -> T +sumT = head . f (const True) . f (`elem` [1,2]) . f (==1) . concatMap g + where + g e@(E a) = case match sumView a of + Just xs | length xs > 1 -> map (upgr . E) xs + _ -> [e] + g a = [a] + + f p (a:b:xs) + | p (orderT a) && p (orderT b) = + f p (plusT a b:xs) + | otherwise = a:f p (b:xs) + f _ xs = xs + +plusT :: T -> T -> T +plusT (R 0) t = t -- ????? +plusT t (R 0) = t -- ????? +plusT (R x) (R y) = R (x+y) +plusT (S x) (S y) = S (x+y) +plusT t@(P _ _ _) b = plusT (E $ fromT t) b +plusT (E a) (E b) = E (a .+. b) +plusT a b = convTs plusT a b + +divT :: T -> T -> T +divT t (R 1) = t -- ????? +divT t (R (-1)) = negT t -- ????? +divT (R x) (R y) | y /= 0 = R (x/y) +divT t@(R _) b@(R _) = divT (E $ fromT t) b +divT (S x) (S y) = S (x/y) +divT t@(P _ _ _) b = divT (E $ fromT t) b +divT (E a) (E b) = E (a ./. b) +divT a b = convTs divT a b + +mulT :: T -> T -> T +mulT (R 0) _ = R 0 -- ????? +mulT _ (R 0) = R 0 -- ????? +mulT t (R 1) = t -- ???? +mulT (R 1) t = t -- ????? +mulT (R a) (R b) = R (a*b) +mulT (S a) (S b) = S (a*b) +mulT (P x1 r1 n1) (P x2 r2 n2) | x1==x2 = P x1 (r1*r2) (n1+n2) + | otherwise = error "" +mulT (E a) (E b) = E (a .*. b) +mulT a b = convTs mulT a b + +convTs :: (T -> T -> T) -> T -> T -> T +convTs f (R a) t@(S _) = f (S (fromRational a)) t +convTs f (R a) t@(P x _ _) = f (P x (fromRational a) 0) t +convTs f t@(R _) e@(E _) = f (E $ fromT t) e +convTs f t@(P _ _ _) e@(E _) = f (E $ fromT t) e +convTs f a b | orderT a > orderT b = convTs (flip f) b a +convTs _ x y = error $ "conv " ++ show (x, y) + +orderT :: T -> Int +orderT (R _) = 1 +orderT (S _) = 2 +orderT (P _ _ _) = 3 +orderT (E _) = 4 + +upgr :: T -> T +upgr (E e) = + case (match (squareRootViewWith rationalView) e, match (powerFactorViewWith rationalView) e) of + (Just a, _) -> upgr (S a) + (_, Just (x, a, n)) -> upgr (P x a n) + _ -> E e +upgr (S a) = maybe (S a) R (fromSquareRoot a) +upgr (P _ a n) | n==0 = R a +upgr t = t diff --git a/src/Domain/Math/Polynomial/Exercises.hs b/src/Domain/Math/Polynomial/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Exercises.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Exercises where + +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Strategies +import Domain.Math.Polynomial.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.BuggyRules +import Common.Exercise +import Common.Rewriting +import Domain.Math.Data.Equation +import Domain.Math.Equation.Views +import Domain.Math.Expr +import Domain.Math.Data.OrList +import Domain.Math.Examples.DWO1 +import Domain.Math.Expr.Parser +import Common.View +import Common.Context +import Data.List + +------------------------------------------------------------ +-- Exercises + +linearExercise :: Exercise (Equation Expr) +linearExercise = makeExercise + { description = "solve a linear equation" + , exerciseCode = makeCode "math" "lineq" + , status = Provisional + , parser = parseWith (pEquation pExpr) + , similarity = eqEquation cleanUpSimple + , equivalence = viewEquivalent linearEquationView + , isReady = solvedEquation + , extraRules = linearRules + , strategy = ignoreContext linearStrategy + , examples = concat linearEquations + } + +quadraticExercise :: Exercise (OrList (Equation Expr)) +quadraticExercise = makeExercise + { description = "solve a quadratic equation" + , exerciseCode = makeCode "math" "quadreq" + , status = Provisional + , parser = parseWith (pOrList (pEquation pExpr)) + , similarity = eqOrList cleanUpExpr2 + , equivalence = viewEquivalent quadraticEquationsView + , isReady = solvedEquations + , extraRules = map ignoreContext $ quadraticRules ++ abcBuggyRules + , strategy = ignoreContext quadraticStrategy + , examples = map (orList . return) (concat quadraticEquations) + } + +higherDegreeExercise :: Exercise (OrList (Equation Expr)) +higherDegreeExercise = makeExercise + { description = "solve an equation (higher degree)" + , exerciseCode = makeCode "math" "higherdegree" + , status = Provisional + , parser = parseWith (pOrList (pEquation pExpr)) + , similarity = eqOrList cleanUpExpr2 + , equivalence = viewEquivalent higherDegreeEquationsView + , isReady = solvedEquations + , extraRules = map ignoreContext higherDegreeRules + , strategy = ignoreContext higherDegreeStrategy + , examples = map (orList . return) higherDegreeEquations + } + +-------------------------------------------- +-- Equality + +eqOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr) -> Bool +eqOrList f x y = normOrList f x == normOrList f y + +eqEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr -> Bool +eqEquation f x y = normEquation f x == normEquation f y + +normOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr) +normOrList f = normalize . fmap (normEquation f) + +normEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr +normEquation f eq + | a <= b = a :==: b + | otherwise = b :==: a + where + a :==: b = fmap (normExpr f) eq + +normExpr :: (Expr -> Expr) -> Expr -> Expr +normExpr f = normalizeWith [plusOperator, timesOperator] . f + where + plusOperator = acOperator (+) isPlus + timesOperator = acOperator (*) isTimes diff --git a/src/Domain/Math/Polynomial/Generators.hs b/src/Domain/Math/Polynomial/Generators.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Generators.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Generators + ( polynomialGen, polynomialDegreeGen + , cubicGen, quadraticGen, linearGen + ) where + +import Prelude hiding ((^)) +import Domain.Math.Expr +import Domain.Math.Expr.Symbols +import Domain.Math.Numeric.Generators +import Test.QuickCheck +import Control.Monad + +polynomialGen :: Int -> Gen Expr +polynomialGen n = do + d <- choose (0, n `div` 5) + polynomialDegreeGen d n + +-- Random polynomial generator for (exactly) degree d +-- No division by zero +polynomialDegreeGen :: Int -> Int -> Gen Expr +polynomialDegreeGen d n + | d==0 = ratGen + | n==0 && d==1 = return (Var "x") + | n==0 = return (Var "x" ^ fromIntegral d) + | otherwise = oneof $ + [ timesGen, plusGen + , liftM2 (:/:) (rec d) ratGenNZ + ] ++ [ powerGen | d > 1 ] + where + rec i = polynomialDegreeGen i (n `div` 2) + plusGen = do + d1 <- choose (0, d) + a <- rec d1 + b <- rec d + oneof $ map return [a :+: b, b :+: a, a :-: b, b :-: a, Negate b] + timesGen = do + d1 <- choose (0, d) + a <- rec d1 + b <- rec (d-d1) + return (a :*: b) + powerGen = do + i <- oneof [ return i | i <- [2..d], d `mod` i == 0 ] + a <- rec (d `div` i) + return (a ^ fromIntegral i) + +cubicGen, quadraticGen, linearGen :: Int -> Gen Expr +cubicGen = polynomialDegreeGen 3 +quadraticGen = polynomialDegreeGen 2 +linearGen = polynomialDegreeGen 1 + +ratGen, ratGenNZ :: Gen Expr +ratGen = sized ratioExprGen +ratGenNZ = sized ratioExprGenNonZero diff --git a/src/Domain/Math/Polynomial/Rules.hs b/src/Domain/Math/Polynomial/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Rules.hs @@ -0,0 +1,425 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Rules where + +import Common.Apply +import Common.Context +import Common.Transformation +import Common.Traversable +import Common.Uniplate (universe) +import Common.Utils +import Common.View +import Control.Monad +import Data.List (nub, (\\), sort, sortBy) +import Data.Maybe +import Data.Ratio +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Domain.Math.Polynomial.CleanUp +import Domain.Math.Polynomial.Views +import Domain.Math.Power.Views +import Prelude hiding (repeat, (^), replicate) +import qualified Domain.Math.SquareRoot.Views as SQ +import qualified Prelude + +------------------------------------------------------------ +-- Rule collection + +linearRules :: [Rule (Context (Equation Expr))] +linearRules = map ignoreContext $ + [ removeDivision, ruleMulti merge, ruleMulti distributeTimes + , varToLeft, coverUpNegate, coverUpTimes + ] ++ + map ($ oneVar) + [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] + + +quadraticRules :: [Rule (OrList (Equation Expr))] +quadraticRules = + [ ruleOnce commonFactorVar, ruleOnce noLinFormula, ruleOnce niceFactors + , ruleOnce simplerA, abcFormula, mulZero, coverUpPower, squareBothSides + ] ++ + map (ruleOnce . ($ oneVar)) + [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] ++ + [ ruleOnce coverUpTimes, ruleOnce coverUpNegate, ruleOnce coverUpNumerator + , ruleOnce2 (ruleSomewhere merge), ruleOnce cancelTerms + , ruleOnce2 (ruleSomewhere distributeTimes) + , ruleOnce2 (ruleSomewhere distributionSquare), ruleOnce flipEquation + , ruleOnce moveToLeft, ruleMulti2 (ruleSomewhere simplerSquareRoot) + ] + +higherDegreeRules :: [Rule (OrList (Equation Expr))] +higherDegreeRules = + [ allPowerFactors, ruleOnce2 powerFactor, sameFactor + ] ++ quadraticRules + +------------------------------------------------------------ +-- General form rules: ax^2 + bx + c = 0 + +-- ax^2 + bx = 0 +commonFactorVar :: Rule (Equation Expr) +commonFactorVar = makeSimpleRule "common factor var" $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs + guard (c == 0 && b /= 0) + -- also search for constant factor + let d = gcdFrac a b + return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)) :==: 0) + +-- ax^2 + c = 0 +noLinFormula :: Rule (Equation Expr) +noLinFormula = makeSimpleRule "no linear term b" $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs + guard (b == 0 && c /= 0) + return $ + if a>0 then fromRational a .*. (Var x .^. 2) :==: fromRational (-c) + else fromRational (-a) .*. (Var x .^. 2) :==: fromRational c + +-- search for (X+A)*(X+B) decomposition +niceFactors :: Rule (Equation Expr) +niceFactors = makeSimpleRuleList "nice factors" $ \(lhs :==: rhs) -> do + guard (rhs == 0) + let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t + (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs) + guard (a==1) + b <- isInt rb + c <- isInt rc + let ok (i, j) = i+j == b + f (i, j) + | i == j = -- special case + (Var x + fromInteger i) ^ 2 :==: 0 + | otherwise = + (Var x + fromInteger i) * (Var x + fromInteger j) :==: 0 + map f (filter ok (factors c)) + +simplerA :: Rule (Equation Expr) +simplerA = makeSimpleRule "simpler polynomial" $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (ra, rb, rc)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs + [a, b, c] <- mapM isInt [ra, rb, rc] + let d = a `gcd` b `gcd` c + guard (d `notElem` [0, 1]) + return (build quadraticView (x, fromInteger (a `div` d), fromInteger (b `div` d), fromInteger (c `div` d)) :==: 0) + +abcFormula :: Rule (OrList (Equation Expr)) +abcFormula = makeSimpleRule "abc formula" $ onceJoinM $ \(lhs :==: rhs) -> do + guard (rhs == 0) + (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs + let discr = sqrt (fromRational (b*b - 4 * a * c)) + case compare discr 0 of + LT -> return false + EQ -> return $ return $ + Var x :==: (-fromRational b) / (2 * fromRational a) + GT -> return $ orList + [ Var x :==: (-fromRational b + discr) / (2 * fromRational a) + , Var x :==: (-fromRational b - discr) / (2 * fromRational a) + ] + +------------------------------------------------------------ +-- General form rules: expr = 0 + +-- Rule must be symmetric in side of equation +mulZero :: Rule (OrList (Equation Expr)) +mulZero = makeSimpleRuleList "multiplication is zero" $ onceJoinM bothSides + where + bothSides eq = oneSide eq `mplus` oneSide (flipSides eq) + oneSide (lhs :==: rhs) = do + guard (rhs == 0) + (_, xs) <- matchM productView lhs + guard (length xs > 1) + let f e = case match (polyNormalForm rationalView >>> second linearPolyView) e of + Just (x, (a, b)) -- special cases (simplify immediately) + | a == 1 -> + Var x :==: fromRational (-b) + | a == -1 -> + Var x :==: fromRational b + _ -> e :==: 0 + return $ orList $ map f xs + +------------------------------------------------------------ +-- Constant form rules: expr = constant + +-- Use this configuration for covering-up plus and minus symbols! +-- Prevent (x^2+3x)+5 = 0 to be covered up +oneVar :: ConfigCoverUp +oneVar = configCoverUp + { configName = Just "one var" + , predicateCovered = (==1) . length . collectVars + , predicateCombined = noVars + , coverLHS = True + , coverRHS = True + } + +------------------------------------------------------------ +-- Top form rules: expr1 = expr2 + +-- Do not simplify (5+sqrt 53)/2 +simplerSquareRoot :: Rule Expr +simplerSquareRoot = makeSimpleRule "simpler square root" $ \e -> do + xs <- f e + guard (not (null xs)) + new <- canonical (SQ.squareRootViewWith rationalView) e + ys <- f new + guard (xs /= ys) + return new + where + -- return numbers under sqrt symbol + f :: Expr -> Maybe [Rational] + f e = liftM sort $ sequence [ match rationalView e | Sqrt e <- universe e ] + + +cancelTerms :: Rule (Equation Expr) +cancelTerms = makeSimpleRule "cancel terms" $ \(lhs :==: rhs) -> do + xs <- match sumView lhs + ys <- match sumView rhs + let zs = filter (`elem` ys) (nub xs) + guard (not (null zs)) + let without as = build sumView (as \\ zs) + return (without xs :==: without ys) + +-- Two out of three "merkwaardige producten" +distributionSquare :: Rule Expr +distributionSquare = makeSimpleRule "distribution square" f + where + f (Sym s [a :+: b, Nat 2]) | s == powerSymbol = + return ((a .^. 2) .+. (2 .*. a .*. b) + (b .^. 2)) + f (Sym s [a :-: b, Nat 2]) | s == powerSymbol = + return ((a .^. 2) .-. (2 .*. a .*. b) + (b .^. 2)) + f _ = Nothing + +-- a^2 == b^2 +squareBothSides :: Rule (OrList (Equation Expr)) +squareBothSides = makeSimpleRule "square both sides" $ onceJoinM f + where + f (Sym s1 [a, Nat 2] :==: Sym s2 [b, Nat 2]) | all (==powerSymbol) [s1, s2] = + return $ orList [a :==: b, a :==: -b] + f _ = Nothing + +-- Afterwards, merge, sort, and (possibly) change sign +flipEquation :: Rule (Equation Expr) +flipEquation = makeSimpleRule "flip equation" $ \(lhs :==: rhs) -> do + guard (hasVars rhs && noVars lhs) + let new = fmap (applyListD [sortT, mergeT]) (rhs :==: lhs) + return $ applyD signT new + +-- Afterwards, merge and sort +moveToLeft :: Rule (Equation Expr) +moveToLeft = makeSimpleRule "move to left" $ \(lhs :==: rhs) -> do + guard (rhs /= 0) + let complex = case fmap (filter hasVars) $ match sumView (applyD merge lhs) of + Just xs | length xs >= 2 -> True + _ -> False + guard (hasVars lhs && (hasVars rhs || complex)) + let new = applyD mergeT $ applyD sortT $ lhs - rhs + return (new :==: 0) + +------------------------------------------------------------ +-- Helpers and Rest + +factors :: Integer -> [(Integer, Integer)] +factors n = concat [ [(a, b), (negate a, negate b)] | a <- [1..h], let b = n `div` a, a*b == n ] + where h = floor (sqrt (abs (fromIntegral n))) + +isInt :: MonadPlus m => Rational -> m Integer +isInt r = do + guard (denominator r == 1) + return (numerator r) + +gcdFrac :: Rational -> Rational -> Rational +gcdFrac r1 r2 = fromMaybe 1 $ do + a <- isInt r1 + b <- isInt r2 + return (fromInteger (gcd a b)) + +----------------------------------------------------------- +-------- Rules From HDE + +-- X*A + X*B = X*C + X*D +allPowerFactors :: Rule (OrList (Equation Expr)) +allPowerFactors = makeSimpleRule "all power factors" $ onceJoinM $ \(lhs :==: rhs) -> do + xs <- match (sumView >>> listView powerFactorView) lhs + ys <- match (sumView >>> listView powerFactorView) rhs + case unzip3 (filter ((/=0) . snd3) (xs ++ ys)) of + (s:ss, _, ns) | all (==s) ss -> do + let m = minimum ns + make = build (sumView >>> listView powerFactorView) . map f + f (s, i, n) = (s, i, n-m) + guard (m > 0 && length ns > 1) + return $ orList [Var s :==: 0, make xs :==: make ys] + _ -> Nothing + +-- Factor-out variable +powerFactor :: Rule Expr +powerFactor = makeSimpleRule "power factor" $ \e -> do + xs <- match sumView e >>= mapM (match powerFactorView) + let (vs, as, ns) = unzip3 xs + r = minimum ns + v = Var (head vs) + f a n = a*v^fromIntegral (n-r) + unless (length xs > 1 && length (nub vs) == 1 && r >= 1) Nothing + -- also search for gcd constant + case mapM (match integerView) as of + Just is | g > 1 -> + return (fromInteger g * v^fromIntegral r * foldr1 (+) (zipWith f (map (fromIntegral . (`div` g)) is) ns)) + where g = foldr1 gcd is + _ -> + return (v^fromIntegral r * build sumView (zipWith f as ns)) + +-- A*B = A*C implies A=0 or B=C +sameFactor :: Rule (OrList (Equation Expr)) +sameFactor = makeSimpleRule "same factor" $ onceJoinM $ \(lhs :==: rhs) -> do + (b1, xs) <- match productView lhs + (b2, ys) <- match productView rhs + (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasVars x ] -- equality is too strong? + return $ orList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ] + + +--------------------------------------------------------- +-- From LinearEquations + +------------------------------------------------------- +-- Transformations + +plusT, minusT :: Expr -> Transformation (Equation Expr) +plusT e = makeTrans "plus" $ return . fmap (applyD mergeT . (.+. e)) +minusT e = makeTrans "minus" $ return . fmap (applyD mergeT . (.-. e)) + +timesT :: Expr -> Transformation (Equation Expr) +timesT e = makeTrans "times" $ \eq -> do + r <- match rationalView e + guard (r /= 0) + return $ fmap (applyD mergeT . applyD distributionOldT . (e .*.)) eq + +divisionT :: Expr -> Transformation (Equation Expr) +divisionT e = makeTrans "division" $ \eq -> do + r <- match rationalView e + guard (r /= 0) + return $ fmap (applyD mergeT . applyD distributionOldT . (./. e)) eq + +-- This rule should consider the associativity of multiplication +-- Combine bottom-up, for example: 5*(x-5)*(x+5) +-- However, in -2x(2x+10) (-2x) should be seen as "one term" +distributionT :: Transformation Expr +distributionT = makeTransList "distributeT" f + where + f expr = do + (b, xs) <- matchM simpleProductView expr + ys <- rec (combine xs) + return $ build simpleProductView (b, ys) + + combine :: [Expr] -> [Expr] + combine (x:y:rest) | p x && p y = combine ((x*y):rest) + where p = maybe False ((==1) . length) . match sumView + combine [] = [] + combine (x:xs) = x : combine xs + + rec :: [Expr] -> [[Expr]] + rec (a:b:xs) = map (:xs) (g a b) ++ map (a:) (rec (b:xs)) + rec _ = [] + + g :: Expr -> Expr -> [Expr] + g a b = do + as <- matchM sumView a + bs <- matchM sumView b + guard (length as > 1 || length bs > 1) + return $ build sumView [ a .*. b | a <- as, b <- bs ] + +mergeT :: Transformation Expr +mergeT = makeTrans "merge" $ return . collectLikeTerms + +-- high exponents first, non power-factor terms at the end +sortT :: Transformation Expr +sortT = makeTrans "sort" $ \e -> do + xs <- match sumView e + let f = fmap (negate . thd3) . match powerFactorView + ps = sortBy cmp $ zip xs (map f xs) + cmp (_, ma) (_, mb) = compare ma mb + return $ build sumView $ map fst ps + +signT :: Transformation (Equation Expr) +signT = makeTrans "sign" $ \(lhs :==: rhs) -> do + a <- match sumView lhs >>= safeHead + p <- match productView a + guard (fst p) + return (-lhs :==: -rhs) + +------------------------------------------------------- +-- Rewrite Rules + +varToLeft :: Rule (Equation Expr) +varToLeft = makeRule "variable to left" $ flip supply1 minusT $ \eq -> do + (x, a, _) <- match (linearViewWith rationalView) (getRHS eq) + guard (a/=0) + return (fromRational a * Var x) + +{- +conToRight :: Rule (Equation Expr) +conToRight = makeRule "constant to right" $ flip supply1 minusT $ \eq -> do + (_, _, b) <- match (linearViewWith rationalView) (getLHS eq) + guard (b/=0) + return (fromRational b) + +scaleToOne :: Rule (Equation Expr) +scaleToOne = makeRule "scale to one" $ flip supply1 divisionT $ \eq -> do + (_, a, _) <- match (linearViewWith rationalView) (getLHS eq) + guard (a `notElem` [0, 1]) + return (fromRational a) -} + +removeDivision :: Rule (Equation Expr) +removeDivision = makeRule "remove division" $ flip supply1 timesT $ \(lhs :==: rhs) -> do + xs <- match sumView lhs + ys <- match sumView rhs + -- also consider parts without variables + zs <- mapM (fmap snd . match productView) (xs ++ ys) + let f = fmap snd . match (divView >>> second integerView) + case mapMaybe f (concat zs) of + [] -> Nothing + ns -> return (fromInteger (foldr1 lcm ns)) + +distributeTimes :: Rule Expr +distributeTimes = makeSimpleRuleList "distribution multiplication" $ \expr -> do + new <- applyAll distributionT expr + return (applyD mergeT new) + +distributeDivision :: Rule Expr +distributeDivision = makeSimpleRule "distribution division" $ \expr -> do + (a, b) <- match divView expr + r <- match rationalView b + xs <- match sumView a + guard (length xs > 1) + let ys = map (/fromRational r) xs + return $ build sumView ys + +merge :: Rule Expr +merge = makeSimpleRule "merge similar terms" $ \old -> do + new <- apply mergeT old + guard (old /= new) + return new + +------------------------ +-- Old + +-- Temporary fix: here we don't care about the terms we apply it to. Only +-- use for cleaning up +distributionOldT :: Transformation Expr +distributionOldT = makeTrans "distributeT" f + where + f (a :*: b) = + case (match sumView a, match sumView b) of + (Just as, Just bs) | length as > 1 || length bs > 1 -> + return $ build sumView [ a .*. b | a <- as, b <- bs ] + _ -> Nothing + f _ = Nothing diff --git a/src/Domain/Math/Polynomial/Strategies.hs b/src/Domain/Math/Polynomial/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Strategies.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Strategies + ( linearStrategy, quadraticStrategy + , higherDegreeStrategy + ) where + +import Prelude hiding (repeat, replicate) +import Common.Strategy +import Common.Transformation +import Common.View +import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus) +import Domain.Math.Polynomial.Rules +import Domain.Math.Polynomial.Views +import Domain.Math.Data.OrList +import Domain.Math.Data.Equation +import Domain.Math.Expr +import Domain.Math.Polynomial.CleanUp + +------------------------------------------------------------ +-- Linear equations + +linearStrategy :: LabeledStrategy (Equation Expr) +linearStrategy = cleanUpStrategy (fmap cleanUpSimple) $ + label "Linear Equation" + $ label "Phase 1" (repeat ( + removeDivision + <|> ruleMulti (ruleSomewhere distributeTimes) + <|> ruleMulti merge)) + <*> label "Phase 2" ( + try varToLeft + <*> try (coverUpPlus id) + <*> try (coverUpTimes |> try coverUpNegate)) + +-- helper strategy +coverUpPlus :: (Rule (Equation Expr) -> Rule a) -> Strategy a +coverUpPlus f = alternatives $ map (f . ($ oneVar)) + [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] + +------------------------------------------------------------ +-- Quadratic equations + +quadraticStrategy :: LabeledStrategy (OrList (Equation Expr)) +quadraticStrategy = cleanUpStrategy cleanUp $ + label "Quadratic Equation Strategy" $ + repeat $ + -- general form + ( label "general form" $ + ( ruleOnce commonFactorVar <|> ruleOnce noLinFormula{- or coverup -} + <|> ruleOnce niceFactors <|> ruleOnce simplerA + <|> coverUpPower) -- to deal with special case x^2=0 + |> abcFormula + ) + |> -- zero form + ( label "zero form" + mulZero + ) + |> -- constant form + ( label "constant form" $ + coverUpPower <|> ruleOnce coverUpTimes <|> coverUpPlus ruleOnce + <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator + <|> squareBothSides + ) + |> -- simplification + ( label "square root simplification" $ + ruleMulti2 (ruleSomewhere simplerSquareRoot) + ) + |> -- top form + ( label "top form" $ + ( ruleOnce2 (ruleSomewhere merge) + <|> ruleOnce cancelTerms + <|> ruleMulti2 (ruleSomewhere distributionSquare) + <|> ruleMulti2 (ruleSomewhere distributeTimes) + <|> ruleMulti2 (ruleSomewhere distributeDivision) + <|> ruleOnce flipEquation) + |> ruleOnce moveToLeft + ) + +----------------------------------------------------------- +-- Higher degree equations + +higherDegreeStrategy :: LabeledStrategy (OrList (Equation Expr)) +higherDegreeStrategy = cleanUpStrategy cleanUp $ + label "higher degree" $ + repeat (allPowerFactors |> (mulZero <|> ruleOnce2 powerFactor <|> sameFactor)) + <*> check isQ <*> quadraticStrategy + +isQ :: OrList (Equation Expr) -> Bool +isQ = (`belongsTo` quadraticEquationsView) diff --git a/src/Domain/Math/Polynomial/Views.hs b/src/Domain/Math/Polynomial/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Polynomial/Views.hs @@ -0,0 +1,273 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Polynomial.Views + ( polyView, polyViewFor, polyViewWith, polyViewForWith + , quadraticView, quadraticViewFor, quadraticViewWith, quadraticViewForWith + , linearView, linearViewFor, linearViewWith, linearViewForWith + , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView + , monomialPolyView, binomialPolyView, trinomialPolyView + , polyNormalForm + , linearEquationView, quadraticEquationView, quadraticEquationsView + , higherDegreeEquationsView + ) where + +import Prelude hiding ((^)) +import Control.Monad +import Data.List +import Common.View +import Common.Traversable +import Common.Utils (distinct) +import Domain.Math.Data.Polynomial +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.Expr +import Domain.Math.Numeric.Views +import Data.Maybe +import qualified Domain.Math.Data.SquareRoot as SQ +import Domain.Math.Expr.Symbols +import Domain.Math.SquareRoot.Views +import Domain.Math.Power.Views (powerFactorViewForWith) + +------------------------------------------------------------------- +-- Polynomial view + +polyView :: View Expr (String, Polynomial Expr) +polyView = polyViewWith identity + +polyViewFor :: String -> View Expr (Polynomial Expr) +polyViewFor v = polyViewForWith v identity + +polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a) +polyViewWith v = makeView f (uncurry g) + where + f expr = do + pv <- selectVar expr + p <- match (polyViewForWith pv v) expr + return (pv, p) + g pv = build (polyViewForWith pv v) + +polyViewForWith :: Fractional a => String -> View Expr a -> View Expr (Polynomial a) +polyViewForWith pv v = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just var + Nat n -> Just (fromIntegral n) + Negate a -> liftM negate (f a) + a :+: b -> liftM2 (+) (f a) (f b) + a :-: b -> liftM2 (-) (f a) (f b) + a :*: b -> liftM2 (*) (f a) (f b) + a :/: b -> do + c <- match v b + guard (c /= 0) + guard (pv `notElem` collectVars b) + p <- f a + return (fmap (/c) p) + Sym s [a, n] | s == powerSymbol -> + liftM2 power (f a) (match integralView n) -- non-negative?? + _ -> do + guard (pv `notElem` collectVars expr) + liftM con (match v expr) + + g = build sumView . map h . reverse . terms + h (a, n) = build v a .*. (Var pv .^. fromIntegral n) + +------------------------------------------------------------------- +-- Quadratic view + +quadraticView :: View Expr (String, Expr, Expr, Expr) +quadraticView = quadraticViewWith identity + +quadraticViewFor :: String -> View Expr (Expr, Expr, Expr) +quadraticViewFor v = quadraticViewForWith v identity + +quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a) +quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> makeView f g + where + f (s, (a, b, c)) = return (s, a, b, c) + g (s, a, b, c) = (s, (a, b, c)) + +quadraticViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a, a) +quadraticViewForWith pv v = polyViewForWith pv v >>> quadraticPolyView + +------------------------------------------------------------------- +-- Linear view + +linearView :: View Expr (String, Expr, Expr) +linearView = linearViewWith identity + +linearViewFor :: String -> View Expr (Expr, Expr) +linearViewFor v = linearViewForWith v identity + +linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a) +linearViewWith v = polyViewWith v >>> second linearPolyView >>> makeView f g + where + f (s, (a, b)) = return (s, a, b) + g (s, a, b) = (s, (a, b)) + +linearViewForWith :: Fractional a => String -> View Expr a -> View Expr (a, a) +linearViewForWith pv v = polyViewForWith pv v >>> linearPolyView + +------------------------------------------------------------------- +-- Views on polynomials (degree) + +constantPolyView :: Num a => View (Polynomial a) a +constantPolyView = makeView (isList1 . polynomialList) (buildList . list1) + +linearPolyView :: Num a => View (Polynomial a) (a, a) +linearPolyView = makeView (isList2 . polynomialList) (buildList . list2) + +quadraticPolyView :: Num a => View (Polynomial a) (a, a, a) +quadraticPolyView = makeView (isList3 . polynomialList) (buildList . list3) + +cubicPolyView :: Num a => View (Polynomial a) (a, a, a, a) +cubicPolyView = makeView (isList4 . polynomialList) (buildList . list4) + +------------------------------------------------------------------- +-- Views on polynomials (number of terms) + +monomialPolyView :: Num a => View (Polynomial a) (a, Int) +monomialPolyView = makeView (isList1. terms) (buildPairs . list1) + +binomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int)) +binomialPolyView = makeView (isList2 . terms) (buildPairs . list2) + +trinomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int), (a, Int)) +trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3) + +-- helpers +buildList :: Num a => [a] -> Polynomial a +buildList = buildPairs . flip zip [0..] . reverse + +buildPairs :: Num a => [(a, Int)] -> Polynomial a +buildPairs as + | null as = 0 + | otherwise = foldl1 (+) (map f as) + where + f (a, n) = con a * power var n + +polynomialList :: Num a => Polynomial a -> [a] +polynomialList p = map (`coefficient` p) [d, d-1 .. 0] + where d = degree p + +list1 (a) = [a] +list2 (a, b) = [a, b] +list3 (a, b, c) = [a, b, c] +list4 (a, b, c, d) = [a, b, c, d] + +isList1 [a] = Just a +isList1 _ = Nothing +isList2 [a, b] = Just (a, b) +isList2 _ = Nothing +isList3 [a, b, c] = Just (a, b, c) +isList3 _ = Nothing +isList4 [a, b, c, d] = Just (a, b, c, d) +isList4 _ = Nothing + +------------------------------------------------------------------- +-- Normal form, and list of power factors + +listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)] +listOfPowerFactors pv v = sumView >>> listView (powerFactorViewForWith pv v) + +polyNormalForm :: Num a => View Expr a -> View Expr (String, Polynomial a) +polyNormalForm v = makeView f (uncurry g) + where + f e = do + pv <- selectVar e + xs <- match (listOfPowerFactors pv v) e + guard (distinct (map snd xs)) + return (pv, buildPairs xs) + g pv = build (listOfPowerFactors pv v) . reverse . terms + +------------------------------------------------------------------- +-- Normal forms for equations + +-- Excludes equations such as 1==1 or 0==1 +linearEquationViewWith :: Fractional a => View Expr a -> View (Equation Expr) (String, a) +linearEquationViewWith v = makeView f g + where + f (lhs :==: rhs) = do + (x, a, b) <- match (linearViewWith v) (lhs - rhs) + return (x, -b/a) + g (x, r) = Var x :==: build v r + +linearEquationView :: View (Equation Expr) (String, Rational) +linearEquationView = linearEquationViewWith rationalView + +quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational)) +quadraticEquationsView = makeView f (fmap g) + where + f eq = do + ors <- switch (fmap (match quadraticEquationView) eq) + return (normalize (join ors)) + + g (x, a) = Var x :==: build (squareRootViewWith rationalView) a + +quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational)) +quadraticEquationView = makeView f g + where + f (lhs :==: rhs) = do + (s, p) <- match (polyViewWith (squareRootViewWith rationalView)) (lhs - rhs) + guard (degree p <= 2) + liftM (fmap ((,) s)) $ + case polynomialList p of + [a, b, c] -> do + discr <- SQ.fromSquareRoot (b*b - SQ.scale 4 (a*c)) + let sdiscr = SQ.sqrtRational discr + twoA = SQ.scale 2 a + case compare discr 0 of + LT -> return false + EQ -> return $ orList [-b/twoA] + GT -> return $ orList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA] + [a, b] -> return $ orList [-b/a] + [a] | a==0 -> return true + _ -> return false + + g ors = + case disjunctions ors of + Nothing -> 0 :==: 0 + Just xs -> + let make (x, a) = Var x .-. build (squareRootViewWith rationalView) a + in build productView (False, map make xs) :==: 0 + +higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) +higherDegreeEquationsView = makeView f (fmap g) + where + f = let make (a :==: b) = orList (normHDE (a-b)) + in Just . normalize . join . fmap make + + g = (:==: 0) + +normHDE :: Expr -> [Expr] +normHDE e = + case match (polyViewWith rationalView) e of + Just (x, p) -> concatMap (g x) $ factorize p + Nothing -> fromMaybe [e] $ do + (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0) + return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] + where + g :: String -> Polynomial Rational -> [Expr] + g x p + | d==0 = [] + | length (terms p) <= 1 = [Var x] + | d==1 = [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)] + | d==2 = let [a,b,c] = [ coefficient n p | n <- [2,1,0] ] + discr = b*b - 4*a*c + sdiscr = SQ.sqrtRational discr + in if discr < 0 then [] else + map ((Var x .+.) . build (squareRootViewWith rationalView)) + [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr) + , SQ.scale (1/(2*a)) (SQ.con b - sdiscr) + ] + | otherwise = [build (polyViewWith rationalView) (x, p)] + where d = degree p diff --git a/src/Domain/Math/Power/Views.hs b/src/Domain/Math/Power/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Power/Views.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +-- For now, restricted to integers in exponent: +-- no sqrt, or roots +module Domain.Math.Power.Views + ( powerView, powerViewFor + , powerFactorView, powerFactorViewWith, powerFactorViewForWith + ) where + +import qualified Prelude +import Prelude hiding ((^), recip) +import Control.Monad +import Common.View +import Domain.Math.Expr + +---------------------------------------------------------------------- +-- Simplified views (no side-conditions to worry about) + +powerView :: View Expr (String, Int) +powerView = makeView f g + where + f expr = do + pv <- selectVar expr + n <- match (powerViewFor pv) expr + return (pv, n) + g (pv, n) = build (powerViewFor pv) n + +powerViewFor :: String -> View Expr Int +powerViewFor pv = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just 1 + e1 :*: e2 -> liftM2 (+) (f e1) (f e2) + Sym s [e, Nat n] + | s == powerSymbol -> liftM (* fromInteger n) (f e) + _ -> Nothing + + g a = Var pv .^. fromIntegral a + +powerFactorView :: View Expr (String, Expr, Int) +powerFactorView = powerFactorViewWith identity + +powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int) +powerFactorViewWith v = makeView f g + where + f expr = do + pv <- selectVar expr + (e, n) <- match (powerFactorViewForWith pv v) expr + return (pv, e, n) + g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n) + +powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int) +powerFactorViewForWith pv v = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just (1, 1) + Negate e -> do + (a, b) <- f e + return (negate a, b) + e1 :*: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1*a2, b1+b2) + Sym s [e1, Nat n] + | s == powerSymbol -> do + (a1, b1) <- f e1 + a <- match v (build v a1 ^ Nat n) + return (a, b1 * fromInteger n) + _ -> do + guard (pv `notElem` collectVars expr) + a <- match v expr + return (a, 0) + + g (a, b) = build v a .*. (Var pv .^. fromIntegral b) + +---------------------------------------------------------------------- +-- General views (that have to cope with side-conditions) +{- +-- x^n +genPowerView :: Num a => String -> View Expr a -> View Expr a +genPowerView pv v = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just 1 + e1 :*: e2 -> liftM2 (+) (f e1) (f e2) + e1 :/: e2 -> liftM2 (-) (f e1) (f e2) -- introduces a condition (silently) + Sym s [e1, e2] -- e2 should not be negative + | s == powerSymbol -> + liftM2 (*) (f e1) (match v e2) + _ -> Nothing + + g a = Var pv .^. build v a + +-- a*x^n +genPowerFactorView :: (Fractional a, Num b) => + String -> View Expr a -> View Expr b -> View Expr (a, b) +genPowerFactorView pv v1 v2 = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just (1, 1) + e1 :*: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1*a2, b1+b2) + e1 :/: e2 -> do -- introduces a condition (silently) + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1/a2, b1-b2) + Sym s [e1, e2] -- e2 should not be negative + | s == powerSymbol -> do + (a1, b1) <- f e1 + n <- match v2 e2 + a <- match v1 (build v1 a1 ^ build v2 n) + return (a, b1*n) + _ -> do + guard (pv `notElem` collectVars expr) + a <- match v1 expr + return (a, 0) + + g (a, b) = build v1 a .*. (Var pv .^. build v2 b) +-} + +{- +powerView :: Integral a => String -> View Expr a -> View Expr a +powerView = undefined + +-- helper: also generalizes over number type in exponent (not just Int) +genPowerView :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b) +genPowerView = genPowerViewWith + +genPowerViewWith :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b) +genPowerViewWith pv v1 v2 = makeView f g + where + f expr = + case expr of + Var s | pv == s -> Just (1, 1) + e1 :*: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + return (a1*a2, b1+b2) + e1 :/: e2 -> do + (a1, b1) <- f e1 + (a2, b2) <- f e2 + a <- match v1 (build v1 a1 / build v1 a2) + return (a, b1-b2) + Sqrt e -> f (root e 2) + Sym s [e1, e2] + | s == rootSymbol -> do + (a1, b1) <- f e1 + n <- match v2 e2 + a <- match v1 (build v1 a1 ^ build v2 n) + b <- match v2 (build v2 b1 / build v2 n) + return (a, b) + | s == powerSymbol -> do + (a1, b1) <- f e1 + n <- match v2 e2 + a <- match v1 (build v1 a1 ^ build v2 n) + return (a, b1*n) + _ -> liftM (\a -> (a, 0)) (match v1 expr) + + g (a, b) = build v1 a .*. (Var pv .^. build v2 b) + + +test = match (genPowerView "x" identity integralView) (sqrt (Var "x" ^ 4)) -} diff --git a/src/Domain/Math/Simplification.hs b/src/Domain/Math/Simplification.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Simplification.hs @@ -0,0 +1,204 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Simplification + ( Simplify(..), smartConstructors + , Simplified, simplified, liftS, liftS2 + , simplifyRule + ) where + +import Common.Context +import Common.Transformation +import Common.Uniplate +import Common.View hiding (simplify) +import Control.Monad +import Data.List +import Data.Maybe +import Domain.Math.Data.Equation +import Domain.Math.Expr hiding (recip) +import Domain.Math.Numeric.Views +import Domain.Math.SquareRoot.Views +import Test.QuickCheck +import qualified Common.View as View + +class Simplify a where + simplify :: a -> a + +instance Simplify a => Simplify (Context a) where + simplify = fmap simplify + +instance Simplify a => Simplify (Equation a) where + simplify = fmap simplify + +instance Simplify a => Simplify [a] where + simplify = fmap simplify + +instance Simplify Expr where + simplify = smartConstructors + . mergeAlike + . distribution + . View.simplify (squareRootViewWith rationalView) + . constantFolding + +instance Simplify a => Simplify (Rule a) where + simplify = doAfter simplify -- by default, simplify afterwards + +data Simplified a = S a deriving (Eq, Ord) + +instance Show a => Show (Simplified a) where + show (S x) = show x + +instance (Num a, Simplify a) => Num (Simplified a) where + (+) = liftS2 (+) + (*) = liftS2 (*) + (-) = liftS2 (-) + negate = liftS negate + abs = liftS abs + signum = liftS signum + fromInteger = simplified . fromInteger + +instance (Fractional a, Simplify a) => Fractional (Simplified a) where + (/) = liftS2 (/) + recip = liftS recip + fromRational = simplified . fromRational + +instance (Floating a, Simplify a) => Floating (Simplified a) where + pi = simplified pi + sqrt = liftS sqrt + (**) = liftS2 (**) + logBase = liftS2 logBase + exp = liftS exp + log = liftS log + sin = liftS sin + tan = liftS tan + cos = liftS cos + asin = liftS asin + atan = liftS atan + acos = liftS acos + sinh = liftS sinh + tanh = liftS tanh + cosh = liftS cosh + asinh = liftS asinh + atanh = liftS atanh + acosh = liftS acosh + +instance Simplify (Simplified a) where + simplify = id + +instance (Simplify a, IsExpr a) => IsExpr (Simplified a) where + toExpr (S x) = toExpr x + fromExpr = liftM simplified . fromExpr + +instance (Arbitrary a, Simplify a) => Arbitrary (Simplified a) where + arbitrary = liftM simplified arbitrary + coarbitrary (S x) = coarbitrary x + +simplified :: Simplify a => a -> Simplified a +simplified = S . simplify + +liftS :: Simplify a => (a -> a) -> Simplified a -> Simplified a +liftS f (S x) = simplified (f x) + +liftS2 :: Simplify a => (a -> a -> a) -> Simplified a -> Simplified a -> Simplified a +liftS2 f (S x) (S y) = simplified (f x y) + +simplifyRule :: Simplify a => Rule a +simplifyRule = simplify idRule + +------------------------------------------------------------ +-- Simplification with the smart constructors + +smartConstructors :: Expr -> Expr +smartConstructors = transform $ \expr -> + case expr of + a :+: b -> a .+. b + a :-: b -> a .-. b + Negate a -> neg a + a :*: b -> a .*. b + a :/: b -> a ./. b + Sym s [a, b] | s == powerSymbol -> + a .^. b + _ -> expr + +------------------------------------------------------------- +-- Distribution of constants + +distribution :: Expr -> Expr +distribution = transformTD $ \expr -> + fromMaybe expr $ do + case expr of + a :*: b -> do + (x, y) <- match plusView a + r <- match rationalView b + return $ (fromRational r .*. x) .+. (fromRational r .*. y) + `mplus` do + r <- match rationalView a + (x, y) <- match plusView b + return $ (fromRational r .*. x) .+. (fromRational r .*. y) + a :/: b -> do + xs <- match sumView a + guard (length xs > 1) + return $ build sumView $ map (./. b) xs + _ -> Nothing + +------------------------------------------------------------- +-- Constant folding + +-- Not an efficient implementation: could be improved if necessary +constantFolding :: Expr -> Expr +constantFolding expr = + case match rationalView expr of + Just r -> fromRational r + Nothing -> let (xs, f) = uniplate expr + in f (map constantFolding xs) + +---------------------------------------------------------------------- +-- merge alike for sums and products + +mergeAlike :: Expr -> Expr +mergeAlike a = + case (match sumView a, match productView a) of + (Just xs, _) | length xs > 1 -> + build sumView (sort $ mergeAlikeSum $ map mergeAlike xs) + (_, Just (b, ys)) | length (filter (/= 1) ys) > 1 -> + build productView (b, sort $ mergeAlikeProduct $ map mergeAlike ys) + _ -> a + +mergeAlikeProduct :: [Expr] -> [Expr] +mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ] + where f [] = [] + f ((Nothing , e):xs) = e:f xs + f ((Just r , _):xs) = + let cs = r : [ c | (Just c , _) <- xs ] + rest = [ x | (Nothing , x) <- xs ] + in build rationalView (product cs):rest + +mergeAlikeSum :: [Expr] -> [Expr] +mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ] + where + pm :: Rational -> Expr -> (Rational, Expr) + pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of + (Just r1, _) -> pm (r*r1) e2 + (_, Just r1) -> pm (r*r1) e1 + _ -> (r, e1 .*. e2) + pm r (Negate e) = pm (negate r) e + pm r e = case match rationalView e of + Just r1 -> (r*r1, Nat 1) + Nothing -> (r, e) + + rec [] = [] + rec ((Nothing, e):xs) = e:rec xs + rec ((Just (r, a), e):xs) = new:rec rest + where + (js, rest) = partition (maybe False ((==a) . snd) . fst) xs + rs = r:map fst (mapMaybe fst js) + new | null js = e + | otherwise = build rationalView (sum rs) .*. a diff --git a/src/Domain/Math/SquareRoot/Views.hs b/src/Domain/Math/SquareRoot/Views.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/SquareRoot/Views.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.SquareRoot.Views + ( squareRootView, squareRootViewWith + ) where + +import Control.Monad +import Common.View +import Domain.Math.Numeric.Views +import Domain.Math.Expr hiding ((^)) +import Domain.Math.Data.SquareRoot + +squareRootView :: View Expr (SquareRoot Expr) +squareRootView = squareRootViewWith identity + +squareRootViewWith :: Fractional a => View Expr a -> View Expr (SquareRoot a) +squareRootViewWith v = makeView f g + where + f expr = + case expr of + Nat a -> Just (fromIntegral a) + a :+: b -> liftM2 (+) (f a) (f b) + a :-: b -> liftM2 (-) (f a) (f b) + Negate a -> fmap negate (f a) + a :*: b -> liftM2 (*) (f a) (f b) + a :/: b -> join $ liftM2 fracDiv (f a) (f b) + Sqrt a -> fmap sqrtRational (match rationalView a) + Sym s [a, b] | s == powerSymbol -> + liftM2 (^) (f a) (match integerView b) + _ -> fmap con (match v expr) + + g = build sumView . map h . toList + h (a, n) + | n == 0 = 0 + | n == 1 = build v a + | otherwise = build v a .*. Sqrt (fromIntegral n) diff --git a/src/Domain/Math/Strategy/BrokenEquations.hs b/src/Domain/Math/Strategy/BrokenEquations.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Strategy/BrokenEquations.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Strategy.BrokenEquations where + +import Prelude hiding (repeat) +import Common.Apply +import Common.Strategy +import Common.Transformation +import Common.Traversable +import Control.Monad +import Data.Ratio +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.View.Basic +import Domain.Math.ExercisesDWO +import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) +import Domain.Math.Polynomial.QuadraticEquations (solvedList) +import Domain.Math.Polynomial.Views +import Domain.Math.Strategy.CoverUpEquations (rule1) +{- +Equations: + (a/b) = 0 = a=0 + (a/b) = 1 = a=b + (a/c) = (b/c) = a==b + (a/b) = (a/c) = b==c +-} + +main = forM_ (concat brokenEquations) $ \eq -> + let res = applyD brokenStrategy (OrList [eq]) + in if solvedList res then print "ok" else print res + +-- TODO: check results afterwards (possibility of division by zero) +brokenStrategy :: LabeledStrategy (OrList (Equation Expr)) +brokenStrategy = label "broken" $ notBroken <*> + try (check p <*> equationsStrategy <*> repeat inconsistencies) + where p (OrList xs) = all (`belongsTo` polyView) $ concat [[a,b] | a:==: b <- xs] + +notBroken :: LabeledStrategy (OrList (Equation Expr)) +notBroken = label "not broken" $ repeat $ + alternatives [brokenZero, brokenOne, brokenSameDenom, brokenSameNum] + |> alternatives [coverUpPlus, brokenCross] + +coverUpPlus = rule1 + +------------------------------------------------------------------------ +-- Equation rules + +brokenZero :: Rule (OrList (Equation Expr)) +brokenZero = makeSimpleRule "brokenZero" $ onceJoinM $ \(a :==: b) -> do + n <- match rationalView b + guard (n==0) + (x, _) <- match divView a + return $ OrList [x :==: 0] + `mplus` do + n <- match rationalView a + guard (n==0) + (x, _) <- match divView b + return $ OrList [x :==: 0] + +brokenOne :: Rule (OrList (Equation Expr)) +brokenOne = makeSimpleRule "brokenOne" $ onceJoinM $ \(a :==: b) -> do + n <- match rationalView b + guard (n==1) + (x, y) <- match divView a + return $ OrList [x :==: y] + `mplus` do + n <- match rationalView a + guard (n==1) + (x, y) <- match divView b + return $ OrList [x :==: y] + +brokenSameDenom :: Rule (OrList (Equation Expr)) +brokenSameDenom = makeSimpleRule "brokenSameDenom" $ onceJoinM $ \(a :==: b) -> do + (x1, y1) <- match divView a + (x2, y2) <- match divView b + guard (y1==y2) + return $ OrList [x1 :==: x2] + +brokenSameNum :: Rule (OrList (Equation Expr)) +brokenSameNum = makeSimpleRule "brokenSameNum" $ onceJoinM $ \(a :==: b) -> do + (x1, y1) <- match divView a + (x2, y2) <- match divView b + guard (x1==x2) + return $ OrList [y1 :==: y2] + +brokenCross :: Rule (OrList (Equation Expr)) +brokenCross = makeSimpleRule "brokenCross" $ onceJoinM $ \(a :==: b) -> do + let matchDiv e = match divView e `mplus` fmap f (match rationalView e) + f r = (fromInteger (numerator r), fromInteger (denominator r)) + (x1, y1) <- matchDiv a + (x2, y2) <- matchDiv b + return $ OrList[x1 .*. y2 :==: x2 .*. y1] + +-- remove inconsistent equations from the or-list, such as 0==1 +-- TODO: move this to a different module (should not be here) +inconsistencies :: Rule (OrList (Equation Expr)) +inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do + r1 <- match rationalView a + r2 <- match rationalView b + guard (r1 /= r2) + return $ OrList [] diff --git a/src/Domain/Math/Strategy/Modulus.hs b/src/Domain/Math/Strategy/Modulus.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Strategy/Modulus.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Strategy.Modulus where + +import Prelude hiding (repeat) +import Common.Apply +import Common.Strategy +import Common.Uniplate +import Common.Transformation +import Common.Traversable +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Expr.Symbols +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.View.Basic +import Domain.Math.ExercisesDWO +import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) +import Domain.Math.Polynomial.QuadraticEquations (solvedList) +{- +Simplifications: + abs r = r if r>=0 + -r if r<0 + abs (abs e) = abs e + abs (-e) = abs e + abs (sqrt e) = sqrt e + abs (e^n) = e^n if even n + +Distribution: + abs (a*b) = abs a * abs b + abs (a/b) = abs a / abs b + +Equations: + abs a = b = a = b or a = -b + abs a = abs b = a = b or a = -b (special case) +-} + +-- For level-4 exercises, I need cube-roots (to solve x^3=9) +main = forM_ (take 12 $ concat modulusEquations) $ \eq -> + let res = applyD modulusStrategy (OrList [eq]) + in if solvedList res then print "ok" else print res + +modulusStrategy :: LabeledStrategy (OrList (Equation Expr)) +modulusStrategy = label "modulus" $ noAbs <*> try (check p <*> equationsStrategy <*> repeat inconsistencies) + where p (OrList xs) = all absFree $ concat [[a,b] | a:==: b <- xs] + absFree e = null [ () | Sym s [_] <- universe e, s == absSymbol ] + +noAbs :: LabeledStrategy (OrList (Equation Expr)) +noAbs = label "remove modulus" $ repeat absEquation + +------------------------------------------------------------------------ +-- Equation rules + +absEquation :: Rule (OrList (Equation Expr)) +absEquation = makeSimpleRule "abs in equation" $ onceJoinM f + where + f (Sym s1 [a] :==: Sym s2 [b]) | all (==absSymbol) [s1, s2] = + Just $ OrList [a :==: b, a :==: -b] + f (Sym s1 [a] :==: b ) | s1 == absSymbol = + Just $ OrList [a :==: b, a :==: -b] + f (a :==: Sym s2 [b]) | s2 == absSymbol = + Just $ OrList [a :==: b, -a :==: b] + f _ = Nothing + +-- remove inconsistent equations from the or-list, such as 0==1 +-- TODO: move this to a different module (should not be here) +inconsistencies :: Rule (OrList (Equation Expr)) +inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do + r1 <- match rationalView a + r2 <- match rationalView b + guard (r1 /= r2) + return $ OrList [] diff --git a/src/Domain/Math/Strategy/SquareRootEquations.hs b/src/Domain/Math/Strategy/SquareRootEquations.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Strategy/SquareRootEquations.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Strategy.SquareRootEquations where + +import Prelude hiding (repeat) +import Common.Apply +import Common.Strategy hiding (not) +import Common.Transformation +import Common.Traversable +import Common.Uniplate (universe) +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.View.Basic +import Domain.Math.ExercisesDWO +import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) +import Domain.Math.Polynomial.QuadraticEquations (solvedList) +{- +Strategie (p21. G&R deel 1): +1) Isoleer wortel +2) Kwadrateer +3) Controleer + +Equations: + sqrt a = b = a = b^2 (if a >= 0, and b>=0) +-} + +main = forM_ (concat sqrtEquations) $ \eq -> + let res = applyD sqrtStrategy (OrList [eq]) + in if solvedList res then print "ok" else print res + +-- TODO: check results afterwards (invalid results due to squaring both sides) +sqrtStrategy :: LabeledStrategy (OrList (Equation Expr)) +sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*> + try (check p <*> equationsStrategy <*> repeat inconsistencies) + where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs] + +isolate :: LabeledStrategy (OrList (Equation Expr)) +isolate = label "isolate" $ repeat $ alternatives + [coverUpPlus, coverUpTimes, coverUpNegation] + +varUnderSqrt :: Expr -> Bool +varUnderSqrt e = not $ null [ () | Sqrt a <- universe e, hasVars a ] + +------------------------------------------------------------------------ +-- Equation rules + +-- Isolation +coverUpPlus :: Rule (OrList (Equation Expr)) +coverUpPlus = makeSimpleRule "coverup plus" $ onceJoinM $ \(a :==: b) -> do + guard (not $ varUnderSqrt b) + (x, y) <- match plusView a + case (varUnderSqrt x, varUnderSqrt y) of + (True, False) -> return $ OrList [x :==: b .-. y] + (False, True ) -> return $ OrList [y :==: b .-. x] + _ -> Nothing + +coverUpNegation :: Rule (OrList (Equation Expr)) +coverUpNegation = makeSimpleRule "coverup negation" $ onceJoinM f + where + f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) = + return $ OrList [a :==: Negate b] + f _ = Nothing + +coverUpTimes :: Rule (OrList (Equation Expr)) +coverUpTimes = makeSimpleRule "coverup times" $ onceJoinM $ \(a :==: b) -> do + guard (not $ varUnderSqrt b) + (x, y) <- match timesView a + case (varUnderSqrt x, varUnderSqrt y) of + (True, False) -> return $ OrList [x :==: b ./. y] + (False, True ) -> return $ OrList [y :==: b ./. x] + _ -> Nothing + +-------------------------------------------------------------- + +squareBoth :: Rule (OrList (Equation Expr)) +squareBoth = makeSimpleRule "inconsistencies" $ onceJoinM f + where + f (Sqrt a :==: Sqrt b) = return $ OrList [a :==: b] + f (a :==: Sqrt b) = return $ OrList [a .^. 2 :==: b] + f (Sqrt a :==: b ) = return $ OrList [a :==: b .^. 2] + f _ = Nothing + +-- remove inconsistent equations from the or-list, such as 0==1 +-- TODO: move this to a different module (should not be here) +inconsistencies :: Rule (OrList (Equation Expr)) +inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do + r1 <- match rationalView a + r2 <- match rationalView b + guard (r1 /= r2) + return $ OrList [] diff --git a/src/Domain/Math/Strategy/SquareRootSimplification.hs b/src/Domain/Math/Strategy/SquareRootSimplification.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Math/Strategy/SquareRootSimplification.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Math.Strategy.SquareRootSimplification where + +import Prelude hiding (repeat) +import Common.Apply +import Common.Strategy hiding (not) +import Common.Transformation +import Common.Uniplate (universe) +import Control.Monad +import Domain.Math.Expr +import Domain.Math.Data.Equation +import Domain.Math.Data.OrList +import Domain.Math.View.Basic +import Domain.Math.ExercisesDWO +import Domain.Math.View.SquareRoot +import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy) +{- +Strategie (p21. G&R deel 1): +1) Isoleer wortel +2) Kwadrateer +3) Controleer + +Equations: + sqrt a = b = a = b^2 (if a >= 0, and b>=0) +-} + +main = forM_ (concat simplerSqrt) $ \e -> + if e `belongsTo` squareRootView then print "ok" else print e + +-- TODO: check results afterwards (invalid results due to squaring both sides) +{- +sqrtStrategy :: LabeledStrategy (OrList (Equation Expr)) +sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*> + try (check p <*> equationsStrategy <*> repeat inconsistencies) + where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs] +-} +isolate :: LabeledStrategy (OrList (Equation Expr)) +isolate = undefined + +------------------------------------------------------------------------ +-- Equation rules +{- +-- Isolation +coverUpPlus :: Rule (OrList (Equation Expr)) +coverUpPlus = makeSimpleRuleList "coverup plus" $ forOne $ \(a :==: b) -> do + guard (not $ varUnderSqrt b) + (x, y) <- match plusView a + case (varUnderSqrt x, varUnderSqrt y) of + (True, False) -> return [x :==: b .-. y] + (False, True ) -> return [y :==: b .-. x] + _ -> Nothing + +coverUpNegation :: Rule (OrList (Equation Expr)) +coverUpNegation = makeSimpleRuleList "coverup negation" $ forOne f + where + f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) = + return [a :==: Negate b] + f _ = Nothing + +coverUpTimes :: Rule (OrList (Equation Expr)) +coverUpTimes = makeSimpleRuleList "coverup times" $ forOne $ \(a :==: b) -> do + guard (not $ varUnderSqrt b) + (x, y) <- match timesView a + case (varUnderSqrt x, varUnderSqrt y) of + (True, False) -> return [x :==: b ./. y] + (False, True ) -> return [y :==: b ./. x] + _ -> Nothing + +-------------------------------------------------------------- + +squareBoth :: Rule (OrList (Equation Expr)) +squareBoth = makeSimpleRuleList "inconsistencies" $ forOne f + where + f (Sqrt a :==: Sqrt b) = return [a :==: b] + f (a :==: Sqrt b) = return [a .^. 2 :==: b] + f (Sqrt a :==: b ) = return [a :==: b .^. 2] + f _ = Nothing + +-- remove inconsistent equations from the or-list, such as 0==1 +-- TODO: move this to a different module (should not be here) +inconsistencies :: Rule (OrList (Equation Expr)) +inconsistencies = makeSimpleRuleList "inconsistencies" $ forOne $ \(a :==: b) -> do + r1 <- match rationalView a + r2 <- match rationalView b + guard (r1 /= r2) + return [] -} diff --git a/src/Domain/Programming.hs b/src/Domain/Programming.hs new file mode 100644 --- /dev/null +++ b/src/Domain/Programming.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.Programming + ( module Domain.Programming.Expr + , module Domain.Programming.Prelude + , module Domain.Programming.Eval + , module Domain.Programming.Parser + , module Domain.Programming.Strategies + , module Domain.Programming.Rules + , module Domain.Programming.Exercises + ) where + +import Domain.Programming.Expr +import Domain.Programming.Prelude +import Domain.Programming.Eval +import Domain.Programming.Parser +import Domain.Programming.Strategies +import Domain.Programming.Rules +import Domain.Programming.Exercises + diff --git a/src/Domain/RelationAlgebra.hs b/src/Domain/RelationAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra + ( module Domain.RelationAlgebra.Formula + , module Domain.RelationAlgebra.Rules + , module Domain.RelationAlgebra.Exercises + , module Domain.RelationAlgebra.Strategies + , module Domain.RelationAlgebra.Generator + , module Domain.RelationAlgebra.Parser + ) where + +import Domain.RelationAlgebra.Formula +import Domain.RelationAlgebra.Rules +import Domain.RelationAlgebra.Exercises +import Domain.RelationAlgebra.Strategies +import Domain.RelationAlgebra.Generator +import Domain.RelationAlgebra.Parser +-- import Domain.RelationAlgebra.Equivalence + +{- +import Test.QuickCheck +import System.Random +import Data.List +import Common.Apply +import Common.Context +import Control.Monad + +nrpairs = 2000 -- 20000 + +repeatM :: Monad m => m a -> m [a] +repeatM m = liftM2 (:) m (repeatM m) + +pairs :: [(RelAlg, RelAlg)] +pairs = take nrpairs $ generate 100 (mkStdGen 280578) (repeatM arbitrary) + +precision :: IO () +precision = do + let f (x, y) = probablyEqualWithG (mkStdGen 28) x y + ms = map f pairs + freq = map g $ group $ sort ms + is = [ n | (Just n, _) <- freq ] + g xs@(x:_) = (x, length xs) + h n = let score = sum [ i | (Just m, i) <- freq, m <= n ] + in putStrLn $ show n ++ ": " ++ showPerc (nrpairs - score - dif) + troubles = [ (norm p, norm q) | (Nothing, (p, q)) <- zip ms pairs ] + len = length unknown + dif = length troubles - len + unknown = -- map (\(a,b) -> (a, b, isEquivalent a b)) $ + filter (\(a,b) -> a /= b) troubles + putStrLn $ map (maybe '!' (const '.')) ms + mapM_ h is + + putStrLn $ unlines $ map show unknown + putStrLn $ "(" ++ show len ++ " unknown)" + +showPerc :: Int -> String +showPerc n = show (fromIntegral (100*n)/fromIntegral nrpairs) ++ "%" + +norm :: RelAlg -> RelAlg +norm = fromContext . applyD toCNF . inContext + +pair1 = ((Not (Inv (Var "q")) :&&: Not (Inv (Var "s"))) :&&: Inv (Var "s") :.: Inv (Var "q"),E) +pair2 = ((Var "s" :&&: (E :+: Not (Var "r")) :.: Inv (Var "r") :&&: ((Not (Var "s") :.: Var "q") :||: (Not (Var "s") :.: Var "s"))) :.: (Var "s" :+: Inv (Var "r") :.: (Inv (Var "s") :+: Inv (Var "r")) :&&: Inv (Var "q")),E) +pair3 = ((Not (Var "q") :||: Not (Var "s")) :||: ((Inv (Var "r") :+: E :.: Inv (Var "q")) :||: (Not (Var "q") :||: Var "s")),U) + +test1 = uncurry isEquivalent pair1 +test2 = uncurry isEquivalent pair2 +test3 = uncurry isEquivalent pair3 -} diff --git a/src/Domain/RelationAlgebra/Equivalence.hs b/src/Domain/RelationAlgebra/Equivalence.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Equivalence.hs @@ -0,0 +1,189 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Equivalence (isEquivalent) where + +import Data.List +import Data.Maybe +import Domain.RelationAlgebra.Formula +import Common.Apply +import Common.Context +import Domain.RelationAlgebra.Strategies +{- +infixr 1 :.: +infixr 2 :+: +infixr 3 :||: +infixr 4 :&&: +-} +{- +-- | The data type RelAlg is the abstract syntax for the domain +-- | of logic expressions. +data RelAlg = Var String + | RelAlg :.: RelAlg -- composition + | RelAlg :+: RelAlg -- relative addition + | RelAlg :&&: RelAlg -- and (conjunction) + | RelAlg :||: RelAlg -- or (disjunction) + | Not RelAlg -- not + | Inv RelAlg -- inverse + | U -- universe + | E -- empty + deriving (Show, Eq, Ord) + +------------------------------------- + + +isAtom :: RelAlg -> Bool +isAtom r = + case r of + Var x -> True + Not (Var x) -> True + Inv (Var x) -> True + Not (Inv (Var x)) -> True + U -> True + E -> True + otherwise -> False + +isMolecule :: RelAlg -> Bool +isMolecule (r :.: s) = isMolecule r && isMolecule s +isMolecule (r :+: s) = isMolecule r && isMolecule s +isMolecule r = isAtom r + +isDisj :: RelAlg -> Bool +isDisj (r :||: s) = isDisj r && isDisj s +isDisj r = isMolecule r + +isCNF :: RelAlg -> Bool +isCNF (r :&&: s) = isCNF r && isCNF s +isCNF r = isDisj r +-} +-- | maak er een cnf van +isEquivalent :: RelAlg -> RelAlg -> Bool +isEquivalent x1 x2 = + let res1 = fromContext (applyD toCNF (inContext x1)) -- cnf van x1 + res2 = fromContext (applyD toCNF (inContext x2)) -- cnf van x2 + mols = union (getSetOfMolecules res1) (getSetOfMolecules res2) + (rs, r1, r2) = remCompls mols res1 res2 + vals = createValuations rs + in all (\ v -> evalFormula r1 v == evalFormula r2 v) vals +{- +-- | zet 'm in cnf +solve (Inv (Inv (Not (Var "p")) :+: Not (Var "q"))) = Not (Var "p") :+: Not (Inv (Var "q")) +solve (Not (Not (Var "p") :+: Not (Inv (Var "q")))) = undefined +solve (Not (Inv (Inv (Not (Var "p")) :+: Not (Var "q")))) = undefined +solve (Not (Var "p" :.: Inv (Var "q"))) = Inv (Inv (Not (Var "p")) :+: Not (Var "q")) +solve x = x +-} + +{- +ra1 = Var "a" :||: (Var "p" :.: Inv (Var "q")) +ra2 = Var "a" :||: (Inv (Inv (Not (Var "p")) :+: Not (Var "q"))) + +fa1 = Inv (Var "r" :+: Var "s") +fa2 = Inv (Var "s") :+: Inv (Var "r") +-} + +{- +mols = union (getSetOfMolecules ra1) (getSetOfMolecules ra2) +triple@(t1, t2, t3) = remCompls mols ra1 ra2 +vs = createValuations t1 +bb = and (map (\v -> evalFormula ra1 v == evalFormula ra2 v) vs) +-} +remCompls :: [RelAlg] -> RelAlg -> RelAlg -> ([RelAlg], RelAlg, RelAlg) +remCompls rs r1 r2 = + let complements = searchForComplements rs + -- sub = [ (r1, Not r2) | (r1, r2) <- complements ] + in ( removeCompls rs complements + , substCompls r1 complements + , substCompls r2 complements + ) + +-- | +substCompls :: RelAlg -> [(RelAlg, RelAlg)] -> RelAlg +substCompls = foldl subst + + + +subst :: RelAlg -> (RelAlg, RelAlg) -> RelAlg +subst r (r1, r2) = + case r of + p :&&: q -> subst p (r1, r2) :&&: subst q (r1, r2) + p :||: q -> subst p (r1, r2) :||: subst q (r1, r2) + _ -> if r == r1 + then Not r2 + else r + + +removeCompls :: [RelAlg] -> [(RelAlg, RelAlg)] -> [RelAlg] +removeCompls xs ys = [ x | x <- xs, notElem x (map snd ys)] + +-- | Search for complements +searchForComplements ::[RelAlg] -> [(RelAlg, RelAlg)] +searchForComplements [] = [] +searchForComplements (x:xs) = [(x,z) | z <- xs, isComplement x z] ++ searchForComplements xs + +isComplement :: RelAlg -> RelAlg -> Bool +isComplement = (==) . fromContext . applyD toCNF . inContext . Not + +-- FIXME: what should we do with the identity relation? +evalFormula :: RelAlg -> [(RelAlg, Bool)] -> Bool +evalFormula f val = + case lookup f val of + Just b -> b + Nothing -> + case f of + f1 :&&: f2 -> evalFormula f1 val && evalFormula f2 val + f1 :||: f2 -> evalFormula f1 val || evalFormula f2 val + Not f -> not (evalFormula f val) + V -> True + E -> False + x -> let value = lookup x val + in if value == Nothing + then error $ "evalFormula: molecule not in valuation " ++ show (f, val) + else fromJust value + + + + + + +-- | Get the set of molecules of an expression in CNF as list. +getSetOfMolecules :: RelAlg -> [RelAlg] +getSetOfMolecules = nub . getMolecules + where + getMolecules :: RelAlg -> [RelAlg] + getMolecules expr = + case expr of + p :&&: q -> getMolecules p ++ getMolecules q + p :||: q -> getMolecules p ++ getMolecules q + Not p -> getMolecules p + V -> [] + E -> [] + I -> [] + p -> [p] + + +{------------------------------------------------------------------- + Given a varList, for example [x,y], function createValuations + creates all valuations: + [[(x,0),(y,0)],[(x,0),(y,1)],[(x,1),(y,0)],[(x,1),(y,1)]], + where (x,0) means: variable x equals 0. +--------------------------------------------------------------------} + +type Molecule = RelAlg +-- type Valuation = (RelAlg, Bool) + + +createValuations :: [a] -> [[(a, Bool)]] +createValuations = foldr op [[]] + where op a vs = [ (a, b):v | v <- vs, b <- [True, False] ] + +prop :: RelAlg -> RelAlg -> Bool +prop p q = isEquivalent p q == probablyEqual p q diff --git a/src/Domain/RelationAlgebra/Exercises.hs b/src/Domain/RelationAlgebra/Exercises.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Exercises.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Exercises (cnfExercise) where + +import Prelude hiding (repeat) +import Domain.RelationAlgebra.Formula +import Domain.RelationAlgebra.Generator +import Domain.RelationAlgebra.Strategies +import Domain.RelationAlgebra.Rules +import Domain.RelationAlgebra.Parser +import Common.Apply +import Common.Exercise +import Common.Context +import Data.Maybe +import Text.Parsing (fromRanged) +import Common.Derivation +import Common.Rewriting (differenceMode) +import Common.Strategy hiding (not) +import Common.Transformation + +cnfExercise :: Exercise RelAlg +cnfExercise = testableExercise + { description = "To conjunctive normal form" + , exerciseCode = makeCode "relationalg" "cnf" + , status = Provisional + , parser = either Left (Right . fromRanged) . parseRelAlg + , prettyPrinter = ppRelAlg + , equivalence = probablyEqual -- isEquivalent + , extraRules = map liftToContext (relAlgRules ++ buggyRelAlgRules) + , strategy = toCNF + , difference = differenceMode probablyEqual + , ordering = compare + , isReady = ready (ruleset cnfExercise) + , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p) + in n >= 2 && n <= 4 + in useGenerator ok (\_ -> templateGenerator 1) + } + +stepsRemaining :: Int -> RelAlg -> Maybe Int +stepsRemaining i = + lengthMax i . derivationTree toCNF . inContext + +{- cnfExerciseSimple :: Exercise RelAlg +cnfExerciseSimple = cnfExercise + { identifier = "cnf-simple" + , description = description cnfExercise ++ " (simple)" + , strategy = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise + } -} + +ready :: [Rule (Context a)] -> a -> Bool +ready rs = null . applyAll (alternatives $ filter (not . isBuggyRule) rs) . inContext diff --git a/src/Domain/RelationAlgebra/Formula.hs b/src/Domain/RelationAlgebra/Formula.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Formula.hs @@ -0,0 +1,190 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Formula where + +import Common.Uniplate (Uniplate(..)) +import Common.Rewriting +import Common.Utils +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import qualified Data.Set as S +import System.Random (StdGen, mkStdGen, split) +import Test.QuickCheck + +infixr 2 :.: +infixr 3 :+: +infixr 4 :||: +infixr 5 :&&: + +-- | The data type RelAlg is the abstract syntax for the domain +-- | of logic expressions. +data RelAlg = Var String + | RelAlg :.: RelAlg -- composition + | RelAlg :+: RelAlg -- relative addition + | RelAlg :&&: RelAlg -- and (conjunction) + | RelAlg :||: RelAlg -- or (disjunction) + | Not RelAlg -- not + | Inv RelAlg -- inverse + | V -- universe + | I -- identity relation + deriving (Show, Eq, Ord) + +-- The empty relation is a smart-constructor: it has no (longer an) actual constructor +-- in the RelAlg datatype +empty :: RelAlg +empty = Not V + +------------------------------------- + + +isAtom :: RelAlg -> Bool +isAtom r = + case r of + Var _ -> True + Not I -> True + Not V -> True + Not (Var _) -> True + Inv (Var _) -> True + Not (Inv (Var _)) -> True + V -> True + I -> True + _ -> False + +isMolecule :: RelAlg -> Bool +isMolecule (r :.: s) = isMolecule r && isMolecule s +isMolecule (r :+: s) = isMolecule r && isMolecule s +isMolecule r = isAtom r + +isDisj :: RelAlg -> Bool +isDisj (r :||: s) = isDisj r && isDisj s +isDisj r = isMolecule r + +isCNF :: RelAlg -> Bool +isCNF (r :&&: s) = isCNF r && isCNF s +isCNF r = isDisj r + +-- | The type RelAlgAlgebra is the algebra for the data type RelAlg +-- | Used in the fold for RelAlg. +type RelAlgAlgebra a = (String -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a -> a, a, a) + +-- | foldRelAlg is the standard folfd for RelAlg. +foldRelAlg :: RelAlgAlgebra a -> RelAlg -> a +foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) = rec + where + rec term = + case term of + Var x -> var x + p :.: q -> rec p `comp` rec q + p :+: q -> rec p `add` rec q + p :&&: q -> rec p `conj` rec q + p :||: q -> rec p `disj` rec q + Not p -> not (rec p) + Inv p -> inverse (rec p) + V -> universe + I -> ident + +type Relation a = S.Set (a, a) + +evalRelAlg :: Ord a => (String -> Relation a) -> [a] -> RelAlg -> Relation a +evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, not, inverse, universe, ident) + where + pairs = cartesian as as + comp p q = let f (a1, a2) c = (a1, c) `S.member` p && (c, a2) `S.member` q + in S.fromAscList [ x | x <- pairs, any (f x) as ] + add p q = let f (a1, a2) c = (a1, c) `S.member` p || (c, a2) `S.member` q + in S.fromAscList [ x | x <- pairs, all (f x) as ] + conj = S.intersection + disj = S.union + not p = S.fromAscList [ x | x <- pairs, x `S.notMember` p ] + inverse = S.map (\(x, y) -> (y, x)) + universe = S.fromAscList pairs + ident = S.fromAscList [ (x, x) | x <- as ] + +-- | Try to find a counter-example showing that the two formulas are not equivalent. +probablyEqual :: RelAlg -> RelAlg -> Bool +probablyEqual = probablyEqualWith (mkStdGen 28) + +probablyEqualWith :: StdGen -> RelAlg -> RelAlg -> Bool +probablyEqualWith rng p q = all (\i -> eval i p == eval i q) (makeRngs 50 rng) + where + -- size of (co-)domain + as = [0..1] + -- number of attemps (with different randomly generated relations) + makeRngs n g + | n == 0 = [] + | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2 + eval g = evalRelAlg (generate 100 g (arbRelations as)) as + +inspect :: [Int] +inspect = map f [1..100] + where f i = S.size $ generate 100 (mkStdGen i) (arbRelations [0..9]) "p" + +arbRelations :: Eq a => [a] -> Gen (String -> Relation a) +arbRelations as = promote (\s -> coarbitrary s (arbRelation as)) + +-- Suitable for small domains (e.g., with just 2 elements) +arbRelation :: Eq a => [a] -> Gen (Relation a) +arbRelation as = do + let f _ = oneof $ map return [True, False] + xs <- filterM f (cartesian as as) + return (S.fromAscList xs) + +-- Alternative relation generator, which works best for slightly +-- larger domains (for instance, with 4 elements or more) +arbRelationAlt:: Eq a => [a] -> Gen (Relation a) +arbRelationAlt as = do + n <- choose (0, 100) + let f x = do + m <- choose (1::Int, 100) + return [ x | n < m ] + xs <- mapM f $ cartesian as as + return $ S.fromAscList $ concat xs + +-- Test on a limited domain whether two relation algebra terms are equivalent +(===) :: RelAlg -> RelAlg -> Property +p === q = forAll arbitrary $ \n -> probablyEqualWith (mkStdGen n) p q + +-- | Function varsRelAlg returns the variables that appear in a RelAlg expression. +varsRelAlg :: RelAlg -> [String] +varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], []) + +instance Uniplate RelAlg where + uniplate term = + case term of + s :.: t -> ([s, t], \[a, b] -> a :.: b) + s :+: t -> ([s, t], \[a, b] -> a :+: b) + s :&&: t -> ([s, t], \[a, b] -> a :&&: b) + s :||: t -> ([s, t], \[a, b] -> a :||: b) + Not s -> ([s], \[a] -> Not a) + Inv s -> ([s], \[a] -> Inv a) + _ -> ([], \[] -> term) + +instance MetaVar RelAlg where + isMetaVar (Var a) = isMetaVar a + isMetaVar _ = Nothing + metaVar = Var . metaVar + +instance ShallowEq RelAlg where + shallowEq expr1 expr2 = + case (expr1, expr2) of + (Var a , Var b ) -> a==b + (_ :.: _ , _ :.: _ ) -> True + (_ :+: _ , _ :+: _ ) -> True + (_ :&&: _, _ :&&: _) -> True + (_ :||: _, _ :||: _) -> True + (Not _ , Not _ ) -> True + (Inv _ , Inv _ ) -> True + (V , V ) -> True + (I , I ) -> True + _ -> False diff --git a/src/Domain/RelationAlgebra/Generator.hs b/src/Domain/RelationAlgebra/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Generator.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Generator (templateGenerator) where + +import Domain.RelationAlgebra.Formula +import Common.Rewriting +import Control.Monad +import Test.QuickCheck + +instance Rewrite RelAlg + +instance Arbitrary RelAlg where + arbitrary = sized arbRelAlg + coarbitrary term = + case term of + Var x -> variant 0 . coarbitrary x + p :.: q -> variant 1 . coarbitrary p . coarbitrary q + p :+: q -> variant 2 . coarbitrary p . coarbitrary q + p :&&: q -> variant 3 . coarbitrary p . coarbitrary q + p :||: q -> variant 4 . coarbitrary p . coarbitrary q + Not p -> variant 5 . coarbitrary p + Inv p -> variant 6 . coarbitrary p + V -> variant 7 + I -> variant 8 + +arbRelAlg :: Int -> Gen RelAlg +arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)] +arbRelAlg n = oneof [ arbRelAlg 0, binop (:.:), binop (:+:), binop (:&&:), binop (:||:) + , unop Not, unop Inv + ] + where + binop op = liftM2 op rec rec + unop op = liftM op rec + rec = arbRelAlg (n `div` 2) + +vars :: [String] +vars = ["q", "r", "s"] + +------------------------------------------------------------------- +-- Templates + +template1 x y z = x :||: (y :&&: z) +template2 x y z = Not(x :&&: (y :||: z)) +template3 x y z = Inv(x :||: (y :&&: z)) +template4 x y z = Inv (Not(x :&&: (y :||: z))) +template5 x y z v = Inv (Not((x :||: v) :&&: (y :||: z))) +template6 mp a b mq = f1 (f2 (a :&&: b)) + where f1 x = maybe x (:.: x) mp + f2 x = maybe x (x :.:) mq +template7 x y z = x :.: (y :||:z) +template8 x y z = x :||: Not (Inv (y :.: z) :&&: Not (Inv y :.: Inv z)) + +------------------------------------------------------------------- +-- Template generators + +templateGenerator :: Int -> Gen RelAlg +templateGenerator n = oneof (map ($ n) [gen1,gen2,gen3,gen4,gen5,gen6,gen7,gen8,gen9]) + +gen1, gen2, gen3, gen4, gen5, gen6, gen7, gen8, gen9 :: Int -> Gen RelAlg +gen1 = use3 template1 arbInvNotMol arbInvNotMol arbInvNotMol +gen2 = use3 template2 arbInvNotMol arbInvNotMol arbInvNotMol +gen3 = use3 template3 arbInvNotMol arbInvNotMol arbInvNotMol +gen4 = use3 template4 arbInvNotMol arbInvNotMol arbInvNotMol +gen5 = use4 template5 arbInvNotMol arbInvNotMol arbInvNotMol arbInvNotMol +gen6 = use3 template1 hulpgen1 arbInvNotMol arbInvNotMol +gen7 = use3 template1 arbInvNotMol hulpgen1 arbInvNotMol +gen8 = use3 template2 arbInvNotMol hulpgen1 arbInvNotMol +gen9 = use3 template8 hulpgen2 arbInvNotMol arbInvNotMol + +use3 temp f g h n = liftM3 temp (f n) (g n) (h n) +use4 temp f g h k n = liftM4 temp (f n) (g n) (h n) (k n) + +hulpgen1 :: Int -> Gen RelAlg +hulpgen1 n = liftM4 template6 (arbMaybeInvNotMol n) arbVar arbVar (arbMaybeInvNotMol n) + +hulpgen2 :: Int -> Gen RelAlg +hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n) + +arbInvNotMol :: Int -> Gen RelAlg +arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return vars)), (1, return V), (1, return empty), (1, return I)] +arbInvNotMol n = frequency [ (10, arbInvNotMol 0), (4, binop (:.:)), (4, binop (:+:)), (2, unop Not), (2, unop Inv) ] + where + binop op = liftM2 op rec rec + unop op = liftM op rec + rec = arbInvNotMol (n `div` 2) + +arbMaybeInvNotMol :: Int -> Gen (Maybe RelAlg) +arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)] + +arbVar :: Gen RelAlg +arbVar = liftM Var (oneof $ map return vars) diff --git a/src/Domain/RelationAlgebra/Parser.hs b/src/Domain/RelationAlgebra/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Parser.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Parser (parseRelAlg, ppRelAlg) where + +import Domain.RelationAlgebra.Formula +import Text.Parsing +import Data.Char + +myScanner :: Scanner +myScanner = minusAsSpecial $ makeCharsSpecial "~" defaultScanner + { keywords = ["V", "E", "I"] + , keywordOperators = concatMap (map fst . snd) operatorTable + } + +operatorTable :: OperatorTable RelAlg +operatorTable = + [ (RightAssociative, [(orSym, (:||:))]) + , (RightAssociative, [(andSym, (:&&:))]) + , (NoMix, [(compSym, (:.:)), (addSym, (:+:))]) + ] + +andSym = "/\\" +orSym = "\\/" +addSym = "!" +compSym = ";" +notSym = "-" +invSym = "~" + +----------------------------------------------------------- +--- Parser + +parseRelAlg :: String -> Either SyntaxError (Ranged RelAlg) +parseRelAlg = analyseAndParse pRelAlg . scanWith myScanner + +pRelAlg :: Parser Token (Ranged RelAlg) +pRelAlg = pOperators operatorTable pTerm + +-- Two postfix operators +pTerm :: Parser Token (Ranged RelAlg) +pTerm = foldl (flip ($)) <$> pAtom <*> pList pUnOp + where + pUnOp = unaryOp Inv <$> pKey invSym + <|> unaryOp Not <$> pKey notSym + +pAtom :: Parser Token (Ranged RelAlg) +pAtom = (\(s, r) -> toRanged (Var s) r) <$> pVarid + <|> pParens pRelAlg + <|> toRanged V <$> pKey "V" + <|> toRanged empty <$> pKey "E" + <|> toRanged I <$> pKey "I" + +----------------------------------------------------------- +--- Helper-function for parentheses analyses + +analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a +analyseAndParse p ts = + case checkParentheses ts of + Just err -> Left err + Nothing -> case parse p ts of + (_, m:_) -> Left (fromMessage m) + (a, _) -> Right a + +----------------------------------------------------------- +--- Pretty-Printer + +ppRelAlg :: RelAlg -> String +ppRelAlg = ppRelAlgPrio (0, "") + +ppRelAlgPrio :: (Int, String) -> RelAlg -> String +ppRelAlgPrio n p = foldRelAlg (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/", nott, inv, var "V", var "I") p n "" + where + binop prio op p q (n, parent) = + parIf (n > prio || (prio==4 && n==4 && op/=parent)) (p (prio+1, op) . ((" "++op++" ")++) . q (prio, op)) + var = const . (++) + nott p _ = p (6, "") . ("-"++) + inv p _ = p (6, "") . ("~"++) + parIf b f = if b then ("("++) . f . (")"++) else f diff --git a/src/Domain/RelationAlgebra/Rules.hs b/src/Domain/RelationAlgebra/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Rules.hs @@ -0,0 +1,327 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Rules where + +import Domain.RelationAlgebra.Formula +import Domain.RelationAlgebra.Generator() +import Common.Transformation +import Common.Rewriting + +invRules :: [Rule RelAlg] +invRules = [ ruleInvOverUnion, ruleInvOverIntersec, ruleInvOverComp + , ruleInvOverAdd, ruleInvOverNot, ruleDoubleInv + ] +compAddRules :: [Rule RelAlg] +compAddRules = [ ruleCompOverUnion {- , ruleCompOverIntersec -} + , {- ruleAddOverUnion,-} ruleAddOverIntersec + ] +relAlgRules :: [Rule RelAlg] +relAlgRules = invRules ++ compAddRules ++ + [ ruleUnionOverIntersec, ruleDeMorganOr, ruleDeMorganAnd, ruleIdempOr, ruleIdempAnd + , ruleRemCompl, ruleDoubleNegation, ruleAbsorpCompl + , ruleAbsorp, ruleRemRedunExprs, ruleNotOverComp + , ruleNotOverAdd + ] + +buggyRelAlgRules ::[Rule RelAlg] +buggyRelAlgRules = [buggyRuleIdemComp, buggyRuleIdemAdd, buggyRuleDeMorgan + , buggyRuleNotOverAdd, buggyRuleNotOverComp, buggyRuleParenth + , buggyRuleAssoc, buggyRuleInvOverComp, buggyRuleInvOverAdd + , buggyRuleCompOverIntersec, buggyRuleAddOverUnion, buggyRuleRemCompl + ] + +-- | 1. Alle ~ operatoren naar binnen verplaatsen + +conversionGroup s = addRuleToGroup "Conversion" . rule s + +ruleInvOverUnion :: Rule RelAlg +ruleInvOverUnion = conversionGroup "InvOverUnion" $ + \r s -> Inv (r :||: s) :~> Inv r :||: Inv s + +ruleInvOverIntersec :: Rule RelAlg +ruleInvOverIntersec = conversionGroup "InvOverIntersect" $ + \r s -> Inv (r :&&: s) :~> Inv r :&&: Inv s --- !!!!!!! ALLEEN VOOR FUNCTIES + +ruleInvOverComp :: Rule RelAlg +ruleInvOverComp = conversionGroup "InvOverComp" $ + \r s -> Inv (r :.: s) :~> Inv s :.: Inv r + +ruleInvOverAdd :: Rule RelAlg +ruleInvOverAdd = conversionGroup "InvOverAdd" $ + \r s -> Inv (r :+: s) :~> Inv s :+: Inv r + +ruleInvOverNot :: Rule RelAlg +ruleInvOverNot = conversionGroup "InvOverNot" $ + \r -> Inv (Not r) :~> Not (Inv r) + +ruleDoubleInv :: Rule RelAlg +ruleDoubleInv = conversionGroup "DoubleInv" $ + \r -> Inv (Inv r) :~> r + + + + +-- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen + +distributionGroup s = addRuleToGroup "Distribution" . ruleList s + +ruleCompOverUnion :: Rule RelAlg +ruleCompOverUnion = distributionGroup "CompOverUnion" + [ \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: (q :.: s) + , \q r s -> (q :||: r) :.: s :~> (q :.: s) :||: (r :.: s) + ] + +ruleCompOverIntersec :: Rule RelAlg +ruleCompOverIntersec = distributionGroup "CompOverIntersec" + [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s) --alleen toegestaan als q een functie is! + , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s) --idem + ] +ruleAddOverUnion :: Rule RelAlg +ruleAddOverUnion = distributionGroup "AddOverUnion" + [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is! + , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem + ] + +ruleAddOverIntersec :: Rule RelAlg +ruleAddOverIntersec = distributionGroup "AddOverIntersec" + [ \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: (q :+: s) + , \q r s -> (q :&&: r) :+: s :~> (q :+: s) :&&: (r :+: s) + ] +-- | 3. Distribute union over intersection + +ruleUnionOverIntersec :: Rule RelAlg +ruleUnionOverIntersec = distributionGroup "UnionOverIntersec" + [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: (q :||: s) + , \q r s -> (q :&&: r) :||: s :~> (q :||: s) :&&: (r :||: s) + ] + +-- | 4. De Morgan rules + +deMorganGroup s = addRuleToGroup "DeMorgan" . rule s + +ruleDeMorganOr :: Rule RelAlg +ruleDeMorganOr = deMorganGroup "DeMorganOr" $ + \r s -> Not (r :||: s) :~> Not r :&&: Not s + +ruleDeMorganAnd :: Rule RelAlg +ruleDeMorganAnd = deMorganGroup "DeMorganAnd" $ + \r s -> Not (r :&&: s) :~> Not r :||: Not s + +-- | 5. Idempotency + +idempotencyGroup s = addRuleToGroup "Idempotency" . rule s + +ruleIdempOr :: Rule RelAlg +ruleIdempOr = idempotencyGroup "IdempotencyOr" $ + \r -> r :||: r :~> r + +ruleIdempAnd :: Rule RelAlg +ruleIdempAnd = idempotencyGroup "IdempotencyAnd" $ + \r -> r :&&: r :~> r + +-- | 6. Complement + +complementGroup s = addRuleToGroup "Complement" . ruleList s + +ruleDoubleNegation :: Rule RelAlg +ruleDoubleNegation = complementGroup "DoubleNegation" + [ \r -> Not (Not r) :~> r + ] + +ruleRemCompl :: Rule RelAlg +ruleRemCompl = complementGroup "RemCompl" + [ \r -> r :||: Not r :~> V + , \r -> Not r :||: r :~> V + , \r -> r :&&: Not r :~> empty + , \r -> Not r :&&: r :~> empty + ] + +-- Distribute Not over . and + + +ruleNotOverComp :: Rule RelAlg +ruleNotOverComp = complementGroup "NotOverComp" + [ \r s -> Not (r :.: s) :~> Not r :+: Not s + ] + +ruleNotOverAdd :: Rule RelAlg +ruleNotOverAdd = complementGroup "NotOverAdd" + [ \r s -> Not (r :+: s) :~> Not r :.: Not s + ] + +-- | 7. Absorption complement + +absorptionGroup s = addRuleToGroup "Absorption" . ruleList s + +ruleAbsorpCompl :: Rule RelAlg +ruleAbsorpCompl = absorptionGroup "AbsorpCompl" + [ \r s -> r :&&: (Not r :||: s) :~> r :&&: s + , \r s -> r :&&: (s :||: Not r) :~> r :&&: s + , \r s -> (Not r :||: s) :&&: r :~> r :&&: s + , \r s -> (s :||: Not r) :&&: r :~> r :&&: s + , \r s -> r :||: (Not r :&&: s) :~> r :||: s + , \r s -> r :||: (s :&&: Not r) :~> r :||: s + , \r s -> (Not r :&&: s) :||: r :~> r :||: s + , \r s -> (s :&&: Not r) :||: r :~> r :||: s + ] + +ruleAbsorp :: Rule RelAlg +ruleAbsorp = absorptionGroup "Absorp" + [ \r s -> r :&&: (r :||: s) :~> r + , \r s -> r :&&: (s :||: r) :~> r + , \r s -> (r :||: s) :&&: r :~> r + , \r s -> (s :||: r) :&&: r :~> r + , \r s -> r :||: (r :&&: s) :~> r + , \r s -> r :||: (s :&&: r) :~> r + , \r s -> (r :&&: s) :||: r :~> r + , \r s -> (s :&&: r) :||: r :~> r + ] + +-- | 8. Remove redundant expressions + +simplificationGroup s = addRuleToGroup "Simplification" . ruleList s + +ruleRemRedunExprs :: Rule RelAlg +ruleRemRedunExprs = simplificationGroup "RemRedunExprs" + [ \r -> r :||: V :~> V + , \r -> V :||: r :~> V + , \r -> r :&&: V :~> r + , \r -> V :&&: r :~> r +-- , (r :.: U) :~> r +-- , (U :.: r) :~> r + , \_ -> V :.: V :~> V + , \r -> r :+: V :~> V + , \r -> V :+: r :~> V +-- , (r :+: E) :~> r +-- , (E :+: r) :~> r + , \_ -> Inv V :~> V + -- rules involving the empty relation + , \_ -> Inv empty :~> empty + , \r -> r :||: empty :~> r + , \r -> empty :||: r :~> r + , \r -> r :&&: empty :~> empty + , \r -> empty :&&: r :~> empty + , \r -> r :.: empty :~> empty + , \r -> empty :.: r :~> empty + , \_ -> empty :+: empty :~> empty +-- new identity rules: CHECK! + , \_ -> Inv I :~> I + , \r -> I :.: r :~> r + , \r -> r :.: I :~> r + ] + +-- Buggy rules: + +buggyGroup s = addRuleToGroup "Buggy" . buggyRule . ruleList s + +buggyRuleIdemComp :: Rule RelAlg +buggyRuleIdemComp = buggyGroup "IdemComp" + [ \q -> q :.: q :~> q + ] + +buggyRuleIdemAdd :: Rule RelAlg +buggyRuleIdemAdd = buggyGroup "IdemAdd" + [ \q -> q :+: q :~> q + ] + +buggyRuleDeMorgan :: Rule RelAlg +buggyRuleDeMorgan = buggyGroup "BuggyDeMorgan" + [ \q r -> Not (q :&&: r) :~> Not q :||: r + , \q r -> Not (q :&&: r) :~> q :||: Not r + , \q r -> Not (q :&&: r) :~> Not (Not q :||: Not r) + , \q r -> Not (q :||: r) :~> Not q :&&: r + , \q r -> Not (q :||: r) :~> q :&&: Not r + , \q r -> Not (q :||: r) :~> Not (Not q :&&: Not r) --note the firstNot in both formulas! + ] + +buggyRuleNotOverAdd :: Rule RelAlg +buggyRuleNotOverAdd = buggyGroup "BuggyNotOverAdd" + [ \q r -> Not (q :+: r) :~> Not q :+: Not r + , \q r -> Not (q :+: r) :~> Not q :.: r + , \q r -> Not (q :+: r) :~> Not q :+: r + , \q r -> Not (q :+: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! + ] + +buggyRuleNotOverComp :: Rule RelAlg +buggyRuleNotOverComp = buggyGroup "BuggyNotOverComp" + [ \q r -> Not (q :.: r) :~> Not q :.: Not r + , \q r -> Not (q :.: r) :~> Not q :.: r + , \q r -> Not (q :.: r) :~> Not q :+: r + , \q r -> Not (q :.: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas! + ] + +buggyRuleParenth :: Rule RelAlg +buggyRuleParenth = buggyGroup "BuggyParenth" + [ \q r -> Not (q :&&: r) :~> Not q :&&: r + , \q r -> Not (q :||: r) :~> Not q :||: r + , \q r -> Not (Not q :&&: r) :~> q :&&: r + , \q r -> Not (Not q :||: r) :~> q :||: r + , \q r -> Not (Not q :.: r) :~> q :.: r + , \q r -> Not (Not q :+: r) :~> q :+: r + , \q r -> Inv (q :&&: r) :~> Inv q :&&: r + , \q r -> Inv (q :||: r) :~> Inv q :||: r + , \q r -> Inv (Inv q :&&: r) :~> q :&&: r + , \q r -> Inv (Inv q :||: r) :~> q :||: r + , \q r -> Inv (Inv q :.: r) :~> q :.: r + , \q r -> Inv (Inv q :+: r) :~> q :+: r + ] + +buggyRuleAssoc :: Rule RelAlg +buggyRuleAssoc = buggyGroup "BuggyAssoc" + [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: s + , \q r s -> (q :||: r) :&&: s :~> q :||: (r :&&: s) + , \q r s -> (q :&&: r) :||: s :~> q :&&: (r :||: s) + , \q r s -> q :&&: (r :||: s) :~> (q :&&: r) :||: s + , \q r s -> q :.: (r :||: s) :~> (q :.: r) :||: s + , \q r s -> (q :||: r) :.: s :~> q :||: (r :.: s) + , \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: s + , \q r s -> (q :&&: r) :.: s :~> q :&&: (r :.: s) + , \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: s + , \q r s -> (q :||: r) :+: s :~> q :||: (r :+: s) + , \q r s -> q :+: (r :&&: s) :~> (q :+: r) :&&: s + , \q r s -> (q :&&: r) :+: s :~> q :&&: (r :+: s) + ] + +buggyRuleInvOverComp :: Rule RelAlg +buggyRuleInvOverComp = buggyGroup "BuggyInvOverComp" + [ \r s -> Inv (r :.: s) :~> Inv r :.: Inv s + ] + +buggyRuleInvOverAdd :: Rule RelAlg +buggyRuleInvOverAdd = buggyGroup "BuggyInvOverAdd" + [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s + ] + +buggyRuleCompOverIntersec :: Rule RelAlg +buggyRuleCompOverIntersec = buggyGroup "BuggyCompOverIntersec" + [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s) --alleen toegestaan als q een functie is! + , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s) --idem + ] +buggyRuleAddOverUnion :: Rule RelAlg +buggyRuleAddOverUnion = buggyGroup "BuggyAddOverUnion" + [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is! + , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem + ] + +buggyRuleRemCompl :: Rule RelAlg +buggyRuleRemCompl = buggyGroup "BuggyRemCompl" + [ \r -> r :&&: Not r :~> V + , \r -> Not r :&&: r :~> V + , \r -> r :||: Not r :~> empty + , \r -> Not r :||: r :~> empty + ] + +-- Older rules involving the empty relation +{- + -- RemRedunExprs + \_ -> (Not V) :~> E + \_ -> (Not E) :~> V +-} diff --git a/src/Domain/RelationAlgebra/Strategies.hs b/src/Domain/RelationAlgebra/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Domain/RelationAlgebra/Strategies.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Domain.RelationAlgebra.Strategies (toCNF) where + +import Domain.RelationAlgebra.Rules +import Domain.RelationAlgebra.Formula +import Common.Context +import Common.Strategy +import Common.Transformation +import Prelude hiding (repeat) + +toCNF :: LabeledStrategy (Context RelAlg) +toCNF = label "To CNF" $ + repeat $ label "step1" step1 + |> label "step2" step2 + |> label "step3" step3 + where + step1 = topDown $ useRules $ + [ ruleRemCompl, ruleRemRedunExprs, ruleDoubleNegation + , ruleIdempOr, ruleIdempAnd, ruleAbsorp, ruleAbsorpCompl + ] ++ invRules + step2 = topDown $ useRules + [ ruleCompOverUnion, ruleAddOverIntersec, ruleDeMorganOr, ruleDeMorganAnd + , ruleNotOverComp, ruleNotOverAdd + ] + step3 = somewhere $ liftToContext + ruleUnionOverIntersec + +-- local helper-function +useRules :: [Rule RelAlg] -> Strategy (Context RelAlg) +useRules = alternatives . map liftToContext + + + + + diff --git a/src/Service/ExerciseList.hs b/src/Service/ExerciseList.hs new file mode 100644 --- /dev/null +++ b/src/Service/ExerciseList.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ExistentialQuantification, Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.ExerciseList + ( exerciseList, findExercises, getExercise + , openMathExercises, findOpenMathExercises, getOpenMathExercise + , OpenMathExercise(..) + , resolveExerciseCode + ) where + +import Common.Utils (Some(..)) +import Common.Exercise +import Data.Char +import Domain.Math.Expr +import qualified Domain.LinearAlgebra as LA +import qualified Domain.Logic as Logic +import qualified Domain.RelationAlgebra as RA +import qualified Domain.Math.DerivativeExercise as Math +import qualified Domain.Math.Numeric.Exercises as Math +import qualified Domain.Math.Equation.CoverUpExercise as Math +import qualified Domain.Math.Polynomial.Exercises as Math + +-- List with all known exercises +exerciseList :: [Some Exercise] +exerciseList = + [ -- logic and relation-algebra + Some Logic.dnfExercise + , Some Logic.dnfUnicodeExercise + , Some RA.cnfExercise + ] ++ + [ Some e | OMEX e <- openMathExercises ] + +----------------------------------------------------------------------------- +-- All mathematical exercises are supported by the OpenMath standard, and +-- require an extra type constraint + +data OpenMathExercise = forall a . IsExpr a => OMEX (Exercise a) + +openMathExercises :: [OpenMathExercise] +openMathExercises = + [ -- basic math + OMEX Math.naturalExercise, OMEX Math.integerExercise + , OMEX Math.rationalExercise, OMEX Math.fractionExercise + , OMEX Math.coverUpExercise + , OMEX Math.linearExercise + , OMEX Math.quadraticExercise + , OMEX Math.higherDegreeExercise + , OMEX Math.derivativeExercise + -- linear algebra + , OMEX LA.gramSchmidtExercise + , OMEX LA.linearSystemExercise + , OMEX LA.gaussianElimExercise + , OMEX LA.systemWithMatrixExercise + ] + +----------------------------------------------------------------------------- +-- Utility functions for finding an exercise + +resolveExerciseCode :: Monad m => String -> m ExerciseCode +resolveExerciseCode txt = + case findExercises (\ex -> show (exerciseCode ex) ~= txt) of + [Some ex] -> return (exerciseCode ex) + _ -> fail $ "Failed to resolve the exercise code " ++ show txt + where + s ~= t = f s == f t + f = map toLower . filter isAlphaNum + +findExercises :: (forall a . Exercise a -> Bool) -> [Some Exercise] +findExercises p = [ Some e | Some e <- exerciseList, p e ] + +getExercise :: Monad m => ExerciseCode -> m (Some Exercise) +getExercise code = + case findExercises ((==code) . exerciseCode) of + [hd] -> return hd + [] -> fail $ "No exercise with code " ++ show code + _ -> fail $ "Ambiguous exercise code " ++ show code + +findOpenMathExercises :: (forall a . Exercise a -> Bool) -> [OpenMathExercise] +findOpenMathExercises p = [ OMEX e | OMEX e <- openMathExercises, p e ] + +getOpenMathExercise :: Monad m => ExerciseCode -> m OpenMathExercise +getOpenMathExercise code = + case findOpenMathExercises ((==code) . exerciseCode) of + [hd] -> return hd + [] -> fail $ "No exercise with code " ++ show code + _ -> fail $ "Ambiguous exercise code " ++ show code diff --git a/src/Service/FeedbackText.hs b/src/Service/FeedbackText.hs new file mode 100644 --- /dev/null +++ b/src/Service/FeedbackText.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.FeedbackText + ( feedbackLogic + , onefirsttext, submittext, derivationtext + ) where + +import Control.Arrow +import Control.Monad +import Common.Exercise +import Common.Utils (safeHead, fst3, commaList) +import Data.Maybe +import Domain.Logic.Formula (SLogic) +import Domain.Logic.FeedbackText +import Domain.Logic.Exercises (dnfExercise, dnfUnicodeExercise) +import Service.TypedAbstractService +import Common.Context +import Common.Transformation (name, Rule) +import Text.Parsing (errorToPositions) +import Data.Char + +-- Quick hack for determining subterms +coerceLogic :: Exercise a -> a -> Maybe SLogic +coerceLogic ex a + | exerciseCode ex == exerciseCode dnfExercise = + either (const Nothing) Just $ parser dnfExercise (prettyPrinter ex a) + | exerciseCode ex == exerciseCode dnfUnicodeExercise = + either (const Nothing) Just $ parser dnfUnicodeExercise (prettyPrinter ex a) + | otherwise = Nothing + +youRewroteInto :: State a -> a -> Maybe String +youRewroteInto = rewriteIntoText False "You rewrote " + +useToRewrite :: Rule (Context a) -> State a -> a -> Maybe String +useToRewrite rule old = rewriteIntoText True txt old + where + txt = "Use " ++ showRule (exerciseCode $ exercise old) rule + ++ " to rewrite " + +rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String +rewriteIntoText mode txt old a = do + let ex | exerciseCode (exercise old) == exerciseCode dnfUnicodeExercise = + dnfUnicodeExercise + | otherwise = dnfExercise + p <- coerceLogic (exercise old) (fromContext $ context old) + q <- coerceLogic (exercise old) a + (p1, q1) <- difference ex mode p q + return $ txt ++ prettyPrinter ex p1 + ++ " into " ++ prettyPrinter ex q1 ++ ". " + +-- Feedback messages for submit service (free student input). The boolean +-- indicates whether the student is allowed to continue (True), or forced +-- to go back to the previous state (False) +feedbackLogic :: State a -> a -> Result a -> (String, Bool) +feedbackLogic old a result = + case result of + Buggy rs -> ( fromMaybe "" (youRewroteInto old a) ++ + feedbackBuggy (ready old) rs + , False) + NotEquivalent -> ( fromMaybe "" (youRewroteInto old a) ++ + feedbackNotEquivalent (ready old) + , False) + Ok rs _ + | null rs -> (feedbackSame, False) + | otherwise -> feedbackOk rs + Detour rs _ -> feedbackDetour (ready old) (expected old) rs + Unknown _ -> ( fromMaybe "" (youRewroteInto old a) ++ + feedbackUnknown (ready old) + , False) + where + expected = fmap fst3 . safeHead . allfirsts + +showRule :: ExerciseCode -> Rule a -> String +showRule code r + | code `elem` map exerciseCode [dnfExercise, dnfUnicodeExercise] = + fromMaybe txt (ruleText r) + | otherwise = txt + where + txt = "rule " ++ name r + +getCode :: State a -> ExerciseCode +getCode = exerciseCode . exercise + +derivationtext :: State a -> Maybe String -> [(String, Context a)] +derivationtext st _event = + map (first (showRule (getCode st))) (derivation st) + +onefirsttext :: State a -> Maybe String -> (Bool, String, State a) +onefirsttext state event = + case allfirsts state of + (r, _, s):_ -> + let msg = case useToRewrite r state (fromContext $ context s) of + Just txt | event /= Just "hint button" -> txt + _ -> "Use " ++ showRule (getCode state) r + in (True, msg, s) + _ -> (False, "Sorry, no hint available", state) + +submittext :: State a -> String -> Maybe String -> (Bool, String, State a) +submittext state txt _event = + case parser (exercise state) txt of + Left err -> + let msg = "Syntax error" ++ pos ++ ": " ++ show err + pos = case map show (errorToPositions err) of + [] -> "" + xs -> " at " ++ commaList xs + in (False, msg, state) + Right a -> + let result = submit state a + (txt, b) = feedbackLogic state a result + in case getResultState result of + Just new | b -> (True, txt, resetStateIfNeeded new) + _ -> (False, txt, state) diff --git a/src/Service/LoggingDatabase.hs b/src/Service/LoggingDatabase.hs new file mode 100644 --- /dev/null +++ b/src/Service/LoggingDatabase.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : alex.gerdes@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Facilities to create a log database +-- +----------------------------------------------------------------------------- +module Service.LoggingDatabase (logMessage, logEnabled) where + +import Data.Time +import Service.Request +#ifdef DB +import Data.Maybe +import Database.HDBC +import Database.HDBC.Sqlite3 (connectSqlite3) + +logEnabled :: Bool +logEnabled = True + +-- | Log a message to the database (a Sqlite database). +logMessage :: Request -> String -> String -> String -> UTCTime -> IO () +logMessage req input output ipaddress begin = do + -- make a connection with the database + conn <- connectSqlite3 "service.db" + + -- check if the database exists, if not make one + --tables <- getTables conn + --if not (elem "log" tables) then run conn createStmt [] else return 0 + + -- calculate duration + end <- getCurrentTime + let diff = diffUTCTime end begin + + -- insert data into database + run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" + [ toSql $ service req + , toSql $ maybe "unknown" show (exerciseID req) + , toSql $ fromMaybe "unknown" (source req) + , toSql $ show (dataformat req) + , toSql $ maybe "unknown" show (encoding req) + , toSql $ input + , toSql $ output + , toSql $ ipaddress + , toSql $ begin + , toSql $ diff + ] + commit conn + + -- close the connection to the database + disconnect conn + `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err + +{- +-- | Log table schema +createStmt = "CREATE TABLE log ( service VARCHAR(250)" + ++ ", exerciseID VARCHAR(250)" + ++ ", source VARCHAR(250)" + ++ ", dataformat VARCHAR(250)" + ++ ", encoding VARCHAR(250)" + ++ ", input VARCHAR(250)" + ++ ", output VARCHAR(250)" + ++ ", ipaddress VARCHAR(20)" + ++ ", time TIME" + ++ ", responsetime TIME)" +-} +#else +logMessage :: Request -> String -> String -> String -> UTCTime -> IO () +logMessage _ _ _ _ _ = return () + +logEnabled :: Bool +logEnabled = False +#endif + diff --git a/src/Service/Main.hs b/src/Service/Main.hs new file mode 100644 --- /dev/null +++ b/src/Service/Main.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Main module for feedback services +-- +----------------------------------------------------------------------------- +module Main (main) where + +-- import Common.Logging +import Common.Utils (useFixedStdGen) +import Service.Options +import Service.ModeXML (processXML) +import Service.ModeJSON (processJSON) +import Service.Request +import Service.LoggingDatabase +import Network.CGI +import Control.Monad.Trans +import Control.Monad +import Data.Maybe +import Data.Char +import Data.IORef +import Data.Time + +main :: IO () +main = do + startTime <- getCurrentTime + flags <- serviceOptions + logRef <- newIORef (return ()) + + case withInputFile flags of + -- from file + Just file -> do + useFixedStdGen -- use a predictable "random" number generator + input <- readFile file + (req, txt, _) <- process input + when (Logging True `elem` flags) $ + writeIORef logRef $ -- save logging action for later + logMessage req input txt "local" startTime + putStrLn txt + + + -- cgi binary + Nothing -> runCGI $ do + addr <- remoteAddr -- the IP address of the remote host making the request + raw <- getInput "input" -- read input + input <- case raw of + Nothing -> fail "Invalid request: environment variable \"input\" is empty" + Just s -> return s + (req, txt, ctp) <- lift $ process input + lift $ writeIORef logRef $ -- save logging action for later + logMessage req input txt addr startTime + setHeader "Content-type" ctp + output txt + + -- log request to database + when (withLogging flags) $ + join (readIORef logRef) + +process :: String -> IO (Request, String, String) +process input = + case discoverDataFormat input of + Just XML -> processXML input + Just JSON -> processJSON input + _ -> fail "Invalid input" + +-- Convert escaped characters ('%') +{- +convert :: String -> String +convert [] = [] +convert ('%':c1:c2:cs) = + case stringToHex [c1, c2] of + Just i -> chr i : convert cs + Nothing -> '%' : convert (c1:c2:cs) +convert (c:cs) = c : convert cs -} diff --git a/src/Service/ModeJSON.hs b/src/Service/ModeJSON.hs new file mode 100644 --- /dev/null +++ b/src/Service/ModeJSON.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Services using JSON notation +-- +----------------------------------------------------------------------------- +module Service.ModeJSON (processJSON, jsonTuple) where + +import Common.Context +import Common.Utils (Some(..), distinct) +import Common.Exercise +import Common.Strategy (makePrefix) +import Common.Transformation hiding (ruleList, defaultArgument) +import Text.JSON +import Service.Request +import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..)) +import qualified Service.Types as Tp +import qualified Service.TypedAbstractService as TAS +import Service.ServiceList hiding (Service) +import qualified Service.ExerciseList as List +import Control.Monad +import Data.Maybe +import Data.Char + +-- TODO: Clean-up code +extractCode :: JSON -> ExerciseCode +extractCode = fromMaybe noCode . List.resolveExerciseCode . f + where + f (String s) = s + f (Array [String _, String _, a@(Array _)]) = f a + f (Array (String s:tl)) | any (\c -> not (isAlphaNum c || isSpace c || c `elem` ".-")) s = f (Array tl) + f (Array (hd:_)) = f hd + f _ = "" + +processJSON :: String -> IO (Request, String, String) +processJSON input = do + txt <- jsonRPC input myHandler + case fmap jsonRequest (parseJSON input) of + Just (Right req) -> return (req, txt, "application/json") + Just (Left err) -> fail err + _ -> fail "no parse" + +jsonRequest :: JSON -> Either String Request +jsonRequest json = do + srv <- case lookupM "method" json of + Just (String s) -> return s + _ -> fail "Invalid method" + code <- liftM (return . extractCode) (lookupM "params" json) + enc <- case lookupM "encoding" json of + Nothing -> return Nothing + Just (String s) -> liftM Just (readEncoding s) + _ -> fail "Invalid encoding" + src <- case lookupM "source" json of + Nothing -> return Nothing + Just (String s) -> return (Just s) + _ -> fail "Invalid source" + return Request + { service = srv + , exerciseID = code + , source = src + , dataformat = JSON + , encoding = enc + } + +myHandler :: JSON_RPC_Handler +myHandler fun arg + | code == noCode && fun /= "exerciselist" = + fail "invalid exercise code" + | otherwise = + case jsonConverter code of + Some conv -> do + service <- getService fun + either fail return (evalService conv service arg) + where + code = extractCode arg + +jsonConverter :: ExerciseCode -> Some (Evaluator (Either String) JSON JSON) +jsonConverter code = + let f a = Some (Evaluator (jsonEncoder a) (jsonDecoder a)) + in case List.getExercise code of + Just (Some a) -> f a + Nothing -> f emptyExercise + +jsonEncoder :: Monad m => Exercise a -> Encoder m JSON a +jsonEncoder ex = Encoder + { encodeType = encode (jsonEncoder ex) + , encodeTerm = return . String . prettyPrinter ex + , encodeTuple = jsonTuple + } + where + encode :: Monad m => Encoder m JSON a -> Type a t -> t -> m JSON + encode enc serviceType = + case serviceType of + Tp.List t -> liftM Array . mapM (encode enc t) + Tp.Tag s t -> liftM (\a -> Object [(s, a)]) . encode enc t + Tp.Int -> return . toJSON + Tp.Bool -> return . toJSON + Tp.String -> return . toJSON + Tp.State -> encode enc stateType . fromState + Tp.Result -> encodeResult enc + _ -> encodeDefault enc serviceType + +fromState :: TAS.State a -> (String, String, Context a, String) +fromState st = + ( show (exerciseCode (TAS.exercise st)) + , maybe "NoPrefix" show (TAS.prefix st) + , inContext (TAS.term st) + , showContext (TAS.context st) + ) + +stateType :: Type a (String, String, Context a, String) +stateType = Tp.Quadruple Tp.String Tp.String Tp.Term Tp.String + +jsonDecoder :: MonadPlus m => Exercise a -> Decoder m JSON a +jsonDecoder ex = Decoder + { decodeType = decode (jsonDecoder ex) + , decodeTerm = reader ex + , decoderExercise = ex + } + where + reader :: Monad m => Exercise a -> JSON -> m a + reader ex (String s) = either (fail . show) return (parser ex s) + reader _ _ = fail "Expecting a string when reading a term" + + decode :: MonadPlus m => Decoder m JSON a -> Type a t -> JSON -> m (t, JSON) + decode dec serviceType = + case serviceType of + Tp.State -> useFirst $ decodeState (decoderExercise dec) (decodeTerm dec) + Tp.Location -> useFirst fromJSON + Tp.Term -> useFirst $ liftM inContext . decodeTerm dec + Tp.Rule -> useFirst $ \x -> fromJSON x >>= getRule (decoderExercise dec) + Tp.Exercise -> \json -> case json of + (Array (String s:rest)) -> return (decoderExercise dec, Array rest) + _ -> return (decoderExercise dec, json) + Tp.Int -> useFirst $ \json -> case json of + Number (I n) -> return (fromIntegral n) + _ -> fail "not an integer" + Tp.String -> useFirst $ \json -> case json of + String s -> return s + _ -> fail "not a string" + _ -> decodeDefault dec serviceType + + useFirst :: Monad m => (JSON -> m a) -> JSON -> m (a, JSON) + useFirst f (Array (x:xs)) = do + a <- f x + return (a, Array xs) + useFirst _ _ = fail "expecting an argument" + +instance InJSON Location where + toJSON = toJSON . show + fromJSON (String s) = case reads s of + [(loc, rest)] | all isSpace rest -> return loc + _ -> fail "invalid string" + fromJSON _ = fail "expecting a string" + +-------------------------- + +decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (TAS.State a) +decodeState ex f (Array [a]) = decodeState ex f a +decodeState ex f (Array [String code, String p, ce, String ctx]) = do + a <- f ce + unit <- maybe (fail "invalid context") return (parseContext ctx) + return TAS.State + { TAS.exercise = ex + , TAS.prefix = fmap (`makePrefix` strategy ex) (readPrefix p) + , TAS.context = fmap (const a) unit + } +decodeState _ _ s = fail $ "invalid state" ++ show s + +readPrefix :: String -> Maybe [Int] +readPrefix input = + case reads input of + [(is, rest)] | all isSpace rest -> return is + _ -> Nothing + +encodeResult :: Monad m => Encoder m JSON a -> TAS.Result a -> m JSON +encodeResult enc result = + case result of + -- TAS.SyntaxError _ -> [("result", String "SyntaxError")] + TAS.Buggy rs -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)] + TAS.NotEquivalent -> return $ Object [("result", String "NotEquivalent")] + TAS.Ok rs st -> do + json <- encodeType enc Tp.State st + return $ Object [("result", String "Ok"), ("rules", Array $ map (String . name) rs), ("state", json)] + TAS.Detour rs st -> do + json <- encodeType enc Tp.State st + return $ Object [("result", String "Detour"), ("rules", Array $ map (String . name) rs), ("state", json)] + TAS.Unknown st -> do + json <- encodeType enc Tp.State st + return $ Object [("result", String "Unknown"), ("state", json)] + +jsonTuple :: [JSON] -> JSON +jsonTuple xs = + case mapM f xs of + Just xs | distinct (map fst xs) -> Object xs + _ -> Array xs + where + f (Object [p]) = Just p + f _ = Nothing diff --git a/src/Service/ModeXML.hs b/src/Service/ModeXML.hs new file mode 100644 --- /dev/null +++ b/src/Service/ModeXML.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Services using XML notation +-- +----------------------------------------------------------------------------- +module Service.ModeXML (processXML) where + +import Common.Context +import Common.Exercise +import Common.Strategy hiding (not, fail) +import Common.Transformation hiding (name, defaultArgument) +import Common.Utils (Some(..)) +import Control.Monad +import Data.Char +import Data.Maybe +import Service.ExerciseList +import Service.ProblemDecomposition +import Service.Request +import Service.Revision (version) +import Service.ServiceList +import Service.TypedAbstractService hiding (exercise) +import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..)) +import Domain.Math.Expr +import Text.OpenMath.Object +import Text.OpenMath.Reply (replyToXML) +import Text.OpenMath.Request (xmlToRequest) +import Text.XML +import qualified Common.Transformation as Rule +import qualified Service.Types as Tp + + +processXML :: String -> IO (Request, String, String) +processXML input = + either fail return $ do + xml <- parseXML input + req <- xmlRequest xml + out <- xmlRequestHandler xml + return (req, showXML out, "application/xml") + +xmlRequest :: XML -> Either String Request +xmlRequest xml = do + unless (name xml == "request") $ + fail "expected xml tag request" + srv <- findAttribute "service" xml + let code = extractExerciseCode xml + enc <- case findAttribute "encoding" xml of + Just s -> liftM Just (readEncoding s) + Nothing -> return Nothing + return Request + { service = srv + , exerciseID = code + , source = findAttribute "source" xml + , dataformat = XML + , encoding = enc + } + +xmlReply :: Request -> XML -> Either String XML +xmlReply request xml + | service request == "mathdox" = do + code <- maybe (fail "unknown exercise code") return (exerciseID request) + OMEX ex <- getOpenMathExercise code + (st, sloc, answer) <- xmlToRequest xml ex + return (replyToXML (problemDecomposition st sloc answer)) + | otherwise = + case encoding request of + Just StringEncoding -> do + code <- maybe (fail "unknown exercise code") return (exerciseID request) + ex <- getExercise code + case stringFormatConverter ex of + Some conv -> do + srv <- getService (service request) + res <- evalService conv srv xml + return (resultOk res) + _ -> do + code <- maybe (fail "unknown exercise code") return (exerciseID request) + ex <- getOpenMathExercise code + case openMathConverter ex of + Some conv -> do + srv <- getService (service request) + res <- evalService conv srv xml + return (resultOk res) + +xmlRequestHandler :: Monad m => XML -> m XML +xmlRequestHandler xml = + case xmlRequest xml of + Left err -> return (resultError err) + Right request -> + case xmlReply request xml of + Left err -> return (resultError err) + Right result -> return result + +extractExerciseCode :: Monad m => XML -> m ExerciseCode +extractExerciseCode xml = + case liftM (break (== '.')) (findAttribute "exerciseid" xml) of + Just (as, _:bs) -> return (makeCode as bs) + Just (as, _) -> resolveExerciseCode as + -- being backwards compatible with early MathDox + Nothing -> + case fmap getData (findChild "strategy" xml) of + Just name -> + let s ~= t = f s == f t + f = map toLower . filter isAlphaNum + in case findOpenMathExercises (\ex -> name ~= description ex) of + [OMEX a] -> return (exerciseCode a) + _ -> fail $ "Unknown strategy name " ++ show name + _ -> fail "no exerciseid attribute, nor a known strategy element" + +resultOk :: XMLBuilder -> XML +resultOk body = makeXML "reply" $ do + "result" .=. "ok" + "version" .=. version + body + +resultError :: String -> XML +resultError txt = makeXML "reply" $ do + "result" .=. "error" + "version" .=. version + element "message" (text txt) + +------------------------------------------------------------ +-- Mixing abstract syntax (OpenMath format) and concrete syntax (string) + +stringFormatConverter :: Some Exercise -> Some (Evaluator (Either String) XML XMLBuilder) +stringFormatConverter (Some ex) = + Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex) + where + f = return . element "expr" . text . prettyPrinter ex + g xml = do + xml <- findChild "expr" xml -- quick fix + -- guard (name xml == "expr") + let input = getData xml + either (fail . show) return (parser ex input) + +openMathConverter :: OpenMathExercise -> Some (Evaluator (Either String) XML XMLBuilder) +openMathConverter (OMEX ex) = + Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex) + where + f = return . builder . toXML . toOMOBJ . toExpr + g xml = do + xob <- findChild "OMOBJ" xml + omobj <- xml2omobj xob + case fromExpr (fromOMOBJ omobj) of + Just a -> return a + Nothing -> fail "Unknown OpenMath object" + +xmlEncoder :: Monad m => (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a +xmlEncoder f ex = Encoder + { encodeType = encode (xmlEncoder f ex) + , encodeTerm = f + , encodeTuple = sequence_ + } + where + encode :: Monad m => Encoder m XMLBuilder a -> Type a t -> t -> m XMLBuilder + encode enc serviceType = + case serviceType of + Tp.List t1 -> \xs -> do + bs <- mapM (encode enc t1) xs + let b = mapM_ (element "elem") bs + return (element "list" b) + Tp.Elem t1 -> liftM (element "elem") . encode enc t1 + Tp.Tag s t1 -> liftM (element s) . encode enc t1 -- quick fix + Tp.Rule -> return . ("ruleid" .=.) . Rule.name + Tp.Term -> encodeTerm enc . fromContext + Tp.Location -> return . text . show + Tp.Bool -> return . text . show + Tp.Int -> return . text . show + Tp.State -> encodeState (encodeTerm enc) + _ -> encodeDefault enc serviceType + +xmlDecoder :: MonadPlus m => (XML -> m a) -> Exercise a -> Decoder m XML a +xmlDecoder f ex = Decoder + { decodeType = decode (xmlDecoder f ex) + , decodeTerm = f + , decoderExercise = ex + } + where + decode :: MonadPlus m => Decoder m XML a -> Type a t -> XML -> m (t, XML) + decode dec serviceType = + case serviceType of + Tp.State -> decodeState (decoderExercise dec) (decodeTerm dec) + Tp.Location -> leave $ liftM (read . getData) . findChild "location" + Tp.Rule -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid" + Tp.Exercise -> leave $ const (return (decoderExercise dec)) + Tp.Term -> \xml -> decodeTerm dec xml >>= \a -> return (inContext a, xml) + _ -> decodeDefault dec serviceType + + leave :: Monad m => (XML -> m a) -> XML -> m (a, XML) + leave f xml = liftM (\a -> (a, xml)) (f xml) + +decodeState :: Monad m => Exercise a -> (XML -> m a) -> XML -> m (State a, XML) +decodeState ex f top = do + xml <- findChild "state" top + unless (name xml == "state") (fail "expected a state tag") + let sp = maybe "[]" getData (findChild "prefix" xml) + sc = maybe "" getData (findChild "context" xml) + --x <- findChild "OMOBJ" xml + expr <- f xml + contxt <- maybe (fail $ "invalid context" ++ show sc) return (parseContext sc) + let state = State ex (Just (makePrefix (read sp) $ strategy ex)) term + term = fmap (const expr) contxt + return (state, top) + +encodeState :: Monad m => (a -> m XMLBuilder) -> State a -> m XMLBuilder +encodeState f state = do + b <- f (term state) + return $ element "state" $ do + element "prefix" (text $ maybe "[]" show (prefix state)) + element "context" (text $ showContext (context state)) + b + diff --git a/src/Service/Options.hs b/src/Service/Options.hs new file mode 100644 --- /dev/null +++ b/src/Service/Options.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Options and command-line flags for services +-- +----------------------------------------------------------------------------- +module Service.Options where + +import System.Environment +import System.Exit +import System.Console.GetOpt +import Service.Revision (version, revision) +import Service.LoggingDatabase (logEnabled) + +data Flag = Verbose | Version | Logging Bool | InputFile String + deriving (Show, Eq) + +options :: [OptDescr Flag] +options = + [ Option "?" ["version"] (NoArg Version) "show version number" + , Option "l" ["logging"] (NoArg $ Logging True) "enable logging" + , Option [] ["no-logging"] (NoArg $ Logging False) "disable logging (default on local machine)" + , Option "f" ["file"] (ReqArg InputFile "FILE") "input FILE" + ] + +header :: String +header = "Usage: service [OPTION] (" ++ versionText ++ ", logging " ++ + (if logEnabled then "enabled" else "disabled") ++ ")" + +versionText :: String +versionText = "version " ++ version ++ ", revision " ++ show revision + +serviceOptions :: IO [Flag] +serviceOptions = do + args <- getArgs + case getOpt Permute options args of + (flags, [], []) | Version `notElem` flags -> + return flags + (_, _, errs) -> do + putStrLn (concat errs ++ usageInfo header options) + exitFailure + +withLogging :: [Flag] -> Bool +withLogging flags = and [ b | Logging b <- flags ] + +withInputFile :: [Flag] -> Maybe String +withInputFile flags = + case [ file | InputFile file <- flags ] of + [hd] -> Just hd + _ -> Nothing diff --git a/src/Service/ProblemDecomposition.hs b/src/Service/ProblemDecomposition.hs new file mode 100644 --- /dev/null +++ b/src/Service/ProblemDecomposition.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.ProblemDecomposition (problemDecomposition) where + +import Common.Apply +import Common.Context +import Common.Exercise +import Common.Derivation +import Common.Strategy hiding (not, repeat) +import Common.Transformation +import Common.Utils +import Data.Char +import Data.List +import Data.Maybe +import Text.OpenMath.Reply +import Service.TypedAbstractService (State(..), stepsremaining) + +replyError :: String -> String -> Reply a +replyError kind = Error . ReplyError kind + +problemDecomposition :: State a -> StrategyLocation -> Maybe a -> Reply a +problemDecomposition st@(State ex mpr requestedTerm) sloc answer + | isNothing $ subStrategy sloc (strategy ex) = + replyError "request error" "invalid location for strategy" + | otherwise = + let pr = fromMaybe (emptyPrefix $ strategy ex) mpr in + case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext) answer) of + ([], _) -> replyError "strategy error" "not able to compute an expected answer" + (answers, Just answeredTerm) + | not (null witnesses) -> + Ok ReplyOk + { repOk_Code = ex + , repOk_Location = nextTask sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses) + , repOk_Context = show newPrefix ++ ";" ++ + showContext (fst $ head witnesses) + , repOk_Steps = stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses) + } + where + witnesses = filter (similarity ex (fromContext answeredTerm) . fromContext . fst) $ take 1 answers + newPrefix = snd (head witnesses) + + ((expected, prefix):_, maybeAnswer) -> + Incorrect ReplyIncorrect + { repInc_Code = ex + , repInc_Location = subTask sloc loc + , repInc_Expected = fromContext expected + , repInc_Derivation = derivation + , repInc_Arguments = args + , repInc_Steps = stepsremaining $ State ex (Just pr) requestedTerm + , repInc_Equivalent = maybe False (equivalence ex (fromContext expected) . fromContext) maybeAnswer + } + where + (loc, args) = firstMajorInPrefix pr prefix requestedTerm + derivation = + let len = length $ prefixToSteps pr + rules = stepsToRules $ drop len $ prefixToSteps prefix + f (s, a) = (s, fromContext a) + in map f (makeDerivation requestedTerm rules) + +-- | Continue with a prefix until a certain strategy location is reached. At least one +-- major rule should have been executed +runPrefixLocation :: StrategyLocation -> Prefix a -> a -> [(a, Prefix a)] +runPrefixLocation loc p0 = + concatMap (check . f) . derivations . + cutOnStep (stop . lastStepInPrefix) . prefixTree p0 + where + f d = (last (terms d), if isEmpty d then p0 else last (steps d)) + stop (Just (End is)) = is==loc + stop (Just (Step is _)) = is==loc + stop _ = False + + check result@(a, p) + | null rules = [result] + | all isMinorRule rules = runPrefixLocation loc p a + | otherwise = [result] + where + rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p + +-- old (current) and actual (next major rule) location +subTask :: [Int] -> [Int] -> [Int] +subTask (i:is) (j:js) + | i == j = i : subTask is js + | otherwise = [] +subTask _ js = take 1 js + +-- old (current) and actual (next major rule) location +nextTask :: [Int] -> [Int] -> [Int] +nextTask (i:is) (j:js) + | i == j = i : nextTask is js + | otherwise = [j] +nextTask _ _ = [] + +firstMajorInPrefix :: Prefix a -> Prefix a -> a -> ([Int], Args) +firstMajorInPrefix p0 prefix a = fromMaybe ([], []) $ do + let steps = prefixToSteps prefix + newSteps = drop (length $ prefixToSteps p0) steps + is <- safeHead [ is | Step is r <- newSteps, isMajorRule r ] + return (is, argumentsForSteps a newSteps) + +argumentsForSteps :: a -> [Step a] -> Args +argumentsForSteps a = flip rec a . stepsToRules + where + rec [] _ = [] + rec (r:rs) a + | isMinorRule r = concatMap (rec rs) (applyAll r a) + | applicable r a = let ds = map (\(Some d) -> labelArgument d) (getDescriptors r) + in maybe [] (zip ds) (expectedArguments r a) + | otherwise = [] + +nextMajorForPrefix :: Prefix a -> a -> [Int] +nextMajorForPrefix p0 a = fromMaybe [] $ do + (_, p1) <- safeHead $ runPrefixMajor p0 a + let steps = prefixToSteps p1 + lastStep <- safeHead (reverse steps) + case lastStep of + Step is r | not (isMinorRule r) -> return is + _ -> Nothing + +makeDerivation :: a -> [Rule a] -> [(String, a)] +makeDerivation _ [] = [] +makeDerivation a (r:rs) = + let new = applyD r a + in [ (name r, new) | isMajorRule r ] ++ makeDerivation new rs + +-- Copied from TypedAbstractService: clean me up +runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)] +runPrefixMajor p0 = + map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0 + where + f d = (last (terms d), if isEmpty d then p0 else last (steps d)) + stop (Just (Step _ r)) = isMajorRule r + stop _ = False diff --git a/src/Service/Request.hs b/src/Service/Request.hs new file mode 100644 --- /dev/null +++ b/src/Service/Request.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Request where + +import Common.Exercise +import Data.Char + +data Request = Request + { service :: String + , exerciseID :: Maybe ExerciseCode + , source :: Maybe String + , dataformat :: DataFormat + , encoding :: Maybe Encoding + } + deriving Show + +data DataFormat = XML | JSON + deriving Show + +data Encoding = OpenMath | StringEncoding + deriving Show + +discoverDataFormat :: Monad m => String -> m DataFormat +discoverDataFormat xs = + case dropWhile isSpace xs of + '<':_ -> return XML + '{':_ -> return JSON + _ -> fail "Unknown data format" + +readEncoding :: Monad m => String -> m Encoding +readEncoding xs = + case map toLower xs of + "openmath" -> return OpenMath + "string" -> return StringEncoding + _ -> fail $ "Invalid encoding: " ++ xs diff --git a/src/Service/Revision.hs b/src/Service/Revision.hs new file mode 100644 --- /dev/null +++ b/src/Service/Revision.hs @@ -0,0 +1,4 @@ +module Service.Revision where +version = "0.5.8" +revision = 2376 +lastChanged = "Fri, 23 Oct 2009" diff --git a/src/Service/SearchSpace.hs b/src/Service/SearchSpace.hs new file mode 100644 --- /dev/null +++ b/src/Service/SearchSpace.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.SearchSpace + ( searchSpace, searchSpaceWith, SearchSpaceConfig(..), defaultConfig + ) where + +import Common.Apply +import Common.Rewriting.TreeDiff +import Common.Transformation +import Common.Strategy hiding ((<||>), (<|>)) +import Service.Progress +import qualified Data.Set as S + +data SearchSpaceConfig = SSC + { costStrategy :: Rational + , costRule :: String -> Rational + } + +defaultConfig :: SearchSpaceConfig +defaultConfig = SSC + { costStrategy = 1 + , costRule = const 1 + } + +type Diffs a = a -> [(a, TreeDiff)] + +searchSpace :: (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a]) +searchSpace = searchSpaceWith defaultConfig + +searchSpaceWith :: SearchSpaceConfig -> (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a]) +searchSpaceWith config ordering diffs mp rules q = rec (empty ordering) (success (q, [], mp)) + where + rec history worklist = + case extractFirst worklist of + Nothing -> + emptyProgress + Just (cost, (p, rs, mStrat), _, rest) + | member p history -> + addScore cost failure <||> rec history rest + | otherwise -> + let new = newStrategy <|> newRule + newRule = mapProgress (\(a, r) -> (a, r:rs, Nothing)) (stepP p) + newStrategy = + case mStrat of + Nothing -> emptyProgress + Just p1 -> addScore (costStrategy config) $ fromMaybeList $ + flip map (runPrefixMajor p1 p) $ \(x, y) -> + case lastRuleInPrefix y of + Just r | isMajorRule r && stepsToRules (prefixToSteps p1) /= stepsToRules (prefixToSteps y) -> + Just (x, r:rs, Just y) + _ -> Nothing + newHistory = insert p history + newWorklist = addScore cost new <|> rest + in addScore cost (success (p, mStrat, rs)) <||> rec newHistory newWorklist + + stepP a0 = do + (r, a) <- scoreList + [ (cost , (r, a)) + | (a, td) <- diffs a0 + , r <- rules + , let cost = costRule config (name r) * scoreTreeDiff td + ] + fromMaybeList $ + case applyAll r a of + [] -> [ Nothing ] + bs -> [ Just (b, r) | b <- bs] + +scoreTreeDiff :: TreeDiff -> Rational +scoreTreeDiff td = + case td of + Equal -> 1000 + _ -> 1 + {- Equal -> 20 + Inside -> 10 + Different -> 1 + Top -> 2 -} + +-- History and X are a work-around, since we don't have an Ord instance for our type +data History a = History (a -> a -> Ordering) (S.Set (X a)) + +newtype X a = X (a -> a -> Ordering, a) + +instance Eq (X a) where + X (f, a) == X (_, b) = f a b == EQ + +instance Ord (X a) where + X (f, a) `compare` X (_, b) = f a b + +empty :: (a -> a -> Ordering) -> History a +empty f = History f S.empty + +member :: a -> History a -> Bool +member a (History f s) = S.member (X (f, a)) s + +insert :: a -> History a -> History a +insert a (History f s) = History f (S.insert (X (f, a)) s) + +------------------------------------------------------ +-- Example for logic domain +{- +buggyRules = map liftRuleToContext [buggyDeMorganOr, buggyDeMorganAnd, buggyAndOverOr, buggyOrOverAnd] +expensiveRules = map liftRuleToContext [ruleDefEquiv, ruleAndOverOr, ruleOrOverAnd] + +buggyDeMorganOr :: LogicRule +buggyDeMorganOr = buggyRule $ makeRule "Buggy DeMorganOr" $ + (Not (x :||: y)) |- (Not x :||: Not y) + +buggyDeMorganAnd :: LogicRule +buggyDeMorganAnd = buggyRule $ makeRule "Buggy DeMorganAnd" $ + (Not (x :&&: y)) |- (Not x :&&: Not y) + +buggyAndOverOr :: LogicRule +buggyAndOverOr = buggyRule $ makeRuleList "Buggy AndOverOr" + [ (x :&&: (y :||: z)) |- ((x :||: y) :&&: (x :||: z)) + , ((x :||: y) :&&: z) |- ((x :||: z) :&&: (y :||: z)) + ] + +buggyOrOverAnd :: LogicRule +buggyOrOverAnd = buggyRule $ makeRuleList "Buggy OrOverAnd" + [ (x :||: (y :&&: z)) |- ((x :&&: y) :||: (x :&&: z)) + , ((x :&&: y) :||: z) |- ((x :&&: z) :||: (y :&&: z)) + ] + +ex = (T :->: Var "p") :&&: (Var "q" :||: T) + +q = putStrLn $ unlines $ map f $ successes $ maxDepth 20 $ stepsP (inContext ex) + where f (a, rs) = ppLogic (fromContext a) ++ " " ++ show rs + +w = map (\(a,b) -> (a, length b)) $ successesForScore $ maxDepth 25 $ stepsP (inContext ex) + +ruleScore :: Rule (Context Logic) -> Int +ruleScore r + | name r `elem` map name buggyRules = fromInteger costBUGGY + | name r `elem` map name expensiveRules = fromInteger costEXPENSIVE + | otherwise = fromInteger costRULE + +stepsP :: Context Logic -> Progress Int (Context Logic, [Rule (Context Logic)]) +stepsP = searchSpace (emptyPrefix toDNF) rules + where + list = map liftRuleToContext logicRules ++ buggyRules + rules = zip (map ruleScore list) list -} diff --git a/src/Service/ServiceList.hs b/src/Service/ServiceList.hs new file mode 100644 --- /dev/null +++ b/src/Service/ServiceList.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.ServiceList (serviceList, Service(..), getService, evalService) where + +import Common.Context +import Common.Transformation +import qualified Common.Exercise as E +import Common.Utils (Some(..)) +import Common.Exercise hiding (Exercise) +import Control.Monad.Error +import qualified Service.ExerciseList as S +import qualified Service.TypedAbstractService as S +import Service.FeedbackText +import Service.Types +import Data.List (sortBy) + +data Service a = Service + { serviceName :: String + , typedValue :: TypedValue a + } + +------------------------------------------------------ +-- Querying a service + +serviceList :: [Service a] +serviceList = + [ derivationS, allfirstsS, onefirstS, readyS + , stepsremainingS, applicableS, applyS, generateS + , submitS + , onefirsttextS, findbuggyrulesS + , submittextS, derivationtextS + , exerciselistS, rulelistS + ] + +getService :: Monad m => String -> m (Service a) +getService txt = + case filter ((==txt) . serviceName) serviceList of + [hd] -> return hd + [] -> fail $ "No service " ++ txt + _ -> fail $ "Ambiguous service " ++ txt + +evalService :: Monad m => Evaluator m inp out a -> Service a -> inp -> m out +evalService f = eval f . typedValue + +------------------------------------------------------ +-- Basic services + +derivationS :: Service a +derivationS = Service "derivation" $ + S.derivation ::: State :-> List (Pair Rule Term) + +allfirstsS :: Service a +allfirstsS = Service "allfirsts" $ + S.allfirsts ::: State :-> List (Triple Rule Location State) + +onefirstS :: Service a +onefirstS = Service "onefirst" $ + S.onefirst ::: State :-> Elem (Triple Rule Location State) + +readyS :: Service a +readyS = Service "ready" $ + S.ready ::: State :-> Bool + +stepsremainingS :: Service a +stepsremainingS = Service "stepsremaining" $ + S.stepsremaining ::: State :-> Int + +applicableS :: Service a +applicableS = Service "applicable" $ + S.applicable ::: Location :-> State :-> List Rule + +applyS :: Service a +applyS = Service "apply" $ + S.apply ::: Rule :-> Location :-> State :-> State + +generateS :: Service a +generateS = Service "generate" $ S.generate ::: + Exercise :-> Optional 5 Int :-> IO State + +findbuggyrulesS :: Service a +findbuggyrulesS = Service "findbuggyrules" $ + S.findbuggyrules ::: State :-> Term :-> List Rule + +submitS :: Service a +submitS = Service "submit" $ (\a -> S.submit a . fromContext) ::: + State :-> Term :-> Result + +------------------------------------------------------ +-- Services with a feedback component + +onefirsttextS :: Service a +onefirsttextS = Service "onefirsttext" $ + onefirsttext ::: State :-> Maybe String :-> Elem (Triple Bool String State) + +submittextS :: Service a +submittextS = Service "submittext" $ + submittext ::: State :-> String :-> Maybe String :-> Elem (Triple Bool String State) + +derivationtextS :: Service a +derivationtextS = Service "derivationtext" $ + derivationtext ::: State :-> Maybe String :-> List (Pair String Term) + +------------------------------------------------------ +-- Reflective services + +exerciselistS :: Service a +exerciselistS = Service "exerciselist" $ + allExercises ::: List (Quadruple (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String)) + +rulelistS :: Service a +rulelistS = Service "rulelist" $ + allRules ::: Exercise :-> List (Triple (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool)) + +allExercises :: [(String, String, String, String)] +allExercises = map make $ sortBy cmp S.exerciseList + where + cmp e1 e2 = f e1 `compare` f e2 + f (Some e) = (domain (exerciseCode e), identifier (exerciseCode e)) + make (Some ex) = (domain (exerciseCode ex), identifier (exerciseCode ex), description ex, show (status ex)) + +allRules :: E.Exercise a -> [(String, Bool, Bool)] +allRules = map make . ruleset + where + make r = (name r, isBuggyRule r, isRewriteRule r) diff --git a/src/Service/TypedAbstractService.hs b/src/Service/TypedAbstractService.hs new file mode 100644 --- /dev/null +++ b/src/Service/TypedAbstractService.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.TypedAbstractService + ( -- * Exercise state + State(..), emptyState, term + -- * Services + , stepsremaining, findbuggyrules, submit, ready, allfirsts + , derivation, onefirst, applicable, apply, generate, generateWith + -- * Result data type + , Result(..), getResultState, resetStateIfNeeded + ) where + +import qualified Common.Apply as Apply +import Common.Context +import Common.Derivation hiding (derivation) +import Common.Exercise (Exercise(..), ruleset, randomTermWith) +import Common.Strategy hiding (not) +import Common.Transformation (Rule, name, isMajorRule, isBuggyRule) +import Common.Utils (safeHead) +import Data.Maybe +import System.Random + +data State a = State + { exercise :: Exercise a + , prefix :: Maybe (Prefix (Context a)) + , context :: Context a + } + +term :: State a -> a +term = fromContext . context + +-- Note that in the typed setting there is no syntax error +data Result a = Buggy [Rule (Context a)] + | NotEquivalent + | Ok [Rule (Context a)] (State a) -- equivalent + | Detour [Rule (Context a)] (State a) -- equivalent + | Unknown (State a) -- equivalent + +----------------------------------------------------------- + +emptyState :: Exercise a -> a -> State a +emptyState ex a = State + { exercise = ex + , prefix = Just (emptyPrefix (strategy ex)) + , context = inContext a + } + +-- result must be in the IO monad to access a standard random number generator +generate :: Exercise a -> Int -> IO (State a) +generate ex level = do + stdgen <- newStdGen + return (generateWith stdgen ex level) + +generateWith :: StdGen -> Exercise a -> Int -> State a +generateWith rng ex level = emptyState ex (randomTermWith rng level ex) + +derivation :: State a -> [(Rule (Context a), Context a)] +derivation state = + case allfirsts state of + [] -> [] + (r, _, next):_ -> (r, context next) : derivation next + +-- Note that we have to inspect the last step of the prefix afterwards, because +-- the remaining part of the derivation could consist of minor rules only. +allfirsts :: State a -> [(Rule (Context a), Location, State a)] +allfirsts state = + case prefix state of + Nothing -> + error "allfirsts: no prefix" + Just p0 -> + let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (context state)) + in mapMaybe make (derivations tree) + where + stop (Just (Step _ r)) = isMajorRule r + stop _ = False + + make d = do + prefixEnd <- safeHead (reverse (steps d)) + termEnd <- safeHead (reverse (terms d)) + case lastStepInPrefix prefixEnd of + Just (Step _ r) | isMajorRule r -> return + ( r + , location termEnd + , state { context = termEnd + , prefix = Just prefixEnd + } + ) + _ -> Nothing + +onefirst :: State a -> (Rule (Context a), Location, State a) +onefirst = fromMaybe (error "onefirst") . safeHead . allfirsts + +applicable :: Location -> State a -> [Rule (Context a)] +applicable loc state = + let check r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (context state)) + in filter check (ruleset (exercise state)) + +-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the +-- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied +-- to the current term at the given location, in which case the request is invalid. +apply :: Rule (Context a) -> Location -> State a -> State a +apply r loc state = maybe applyOff applyOn (prefix state) + where + applyOn _ = -- scenario 1: on-strategy + fromMaybe applyOff $ safeHead + [ s1 | (r1, loc1, s1) <- allfirsts state, name r == name r1, loc==loc1 ] + + applyOff = -- scenario 2: off-strategy + case Apply.apply r (setLocation loc (context state)) of + Just new -> state { context=new } + Nothing -> error "apply" + +ready :: State a -> Bool +ready state = isReady (exercise state) (term state) + +stepsremaining :: State a -> Int +stepsremaining = length . derivation + +findbuggyrules :: State a -> Context a -> [Rule (Context a)] +findbuggyrules state a = + let ex = exercise state + isA = similarity ex (fromContext a) . fromContext + buggies = filter isBuggyRule (ruleset ex) + check r = any isA (Apply.applyAll r (context state)) + in filter check buggies + +-- make sure that new has a prefix (because of possible detour) +-- when resetting the prefix, also make sure that the context is refreshed +resetStateIfNeeded :: State a -> State a +resetStateIfNeeded s + | isJust (prefix s) = s + | otherwise = s + { prefix = Just (emptyPrefix (strategy (exercise s))) + , context = inContext (fromContext (context s)) + } + +submit :: State a -> a -> Result a +submit state new + -- Is the submitted term equivalent? + | not (equivalence (exercise state) (term state) new) = + -- Is the rule used discoverable by trying all known buggy rules? + case discovered True of + Just r -> -- report the buggy rule + Buggy [r] + Nothing -> -- unknown mistake + NotEquivalent + -- Is the submitted term (very) similar to the previous one? + | similarity (exercise state) (term state) new = + -- If yes, report this + Ok [] state + -- Was the submitted term expected by the strategy + | isJust expected = + -- If yes, return new state and rule + let (r, _, ns) = fromJust expected + in Ok [r] ns + -- Is the rule used discoverable by trying all known rules? + | otherwise = + case discovered False of + Just r -> -- If yes, report the found rule as a detour + Detour [r] state { prefix=Nothing, context=inContext new } + Nothing -> -- If not, we give up + Unknown state { prefix=Nothing, context=inContext new } + where + expected = + let p (_, _, ns) = similarity (exercise state) new (term ns) + in safeHead (filter p (allfirsts state)) + + discovered searchForBuggy = safeHead + [ r + | r <- ruleset (exercise state) + , isBuggyRule r == searchForBuggy + , a <- Apply.applyAll r (inContext sub1) + , similarity (exercise state) sub2 (fromContext a) + ] + where + mode = not searchForBuggy + diff = difference (exercise state) mode (term state) new + (sub1, sub2) = fromMaybe (term state, new) diff + +getResultState :: Result a -> Maybe (State a) +getResultState result = + case result of + Ok _ st -> return st + Detour _ st -> return st + Unknown st -> return st + _ -> Nothing diff --git a/src/Service/Types.hs b/src/Service/Types.hs new file mode 100644 --- /dev/null +++ b/src/Service/Types.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE GADTs, Rank2Types #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Service.Types where + +import Common.Context (Context, Location, fromContext) +import Common.Exercise (Exercise) +import Common.Transformation (Rule, name) +import Common.Utils (commaList) +import Control.Arrow +import Control.Monad +import Data.Maybe +import Service.TypedAbstractService (State, Result) +import System.IO.Unsafe + +infix 2 ::: +infixr 3 :-> + +data TypedValue a = forall t . t ::: Type a t + +data Type a t where + -- Function type + (:->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) + -- Tuple types + Pair :: Type a t1 -> Type a t2 -> Type a (t1, t2) + Triple :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) + Quadruple :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) + -- Special annotations + Tag :: String -> Type a t1 -> Type a t1 + Optional :: t1 -> Type a t1 -> Type a t1 + Maybe :: Type a t1 -> Type a (Maybe t1) + -- Type constructors + List :: Type a t -> Type a [t] + Elem :: Type a t -> Type a t -- quick fix + IO :: Type a t -> Type a (IO t) + -- Exercise-specific types + State :: Type a (State a) + Exercise :: Type a (Exercise a) + Rule :: Type a (Rule (Context a)) + Term :: Type a (Context a) + Result :: Type a (Result a) + -- Basic types + Bool :: Type a Bool + Int :: Type a Int + String :: Type a String + Location :: Type a Location + +instance Show (Type a t) where + show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 + show (Pair t1 t2) = "(" ++ commaList [show t1, show t2] ++ ")" + show (Triple t1 t2 t3) = "(" ++ commaList [show t1, show t2, show t3] ++ ")" + show (Quadruple t1 t2 t3 t4) = "(" ++ commaList [show t1, show t2, show t3, show t4] ++ ")" + show (Tag _ t) = show t + show (Optional _ t) = "(" ++ show t ++ ")?" + show (Maybe t) = "(" ++ show t ++ ")?" + show (List t) = "[" ++ show t ++ "]" + show (Elem t) = show t + show (IO t) = show t + show t = fromMaybe "unknown" (groundType t) + +groundType :: Type a t -> Maybe String +groundType tp = + case tp of + State -> Just "State" + Exercise -> Just "Exercise" + Rule -> Just "Rule" + Term -> Just "Term" + Result -> Just "Result" + Bool -> Just "Bool" + Int -> Just "Int" + String -> Just "String" + Location -> Just "Location" + _ -> Nothing + +{- eqType :: Type a1 t1 -> Type a2 t2 -> Bool +eqType (t1 :-> t2) (t3 :-> t4) = eqType t1 t3 && eqType t2 t4 +eqType (Pair t1 t2) (Pair t3 t4) = eqType t1 t3 && eqType t2 t4 +eqType (Triple t1 t2 t3) (Triple t4 t5 t6) = eqType t1 t4 && eqType t2 t5 && eqType t3 t6 +eqType (List t1) (List t2) = eqType t1 t2 +eqType (Elem t1) (Elem t2) = eqType t1 t2 +eqType (IO t1) (IO t2) = eqType t1 t2 +eqType t1 t2 = maybe False ((groundType t1 ==) . Just) (groundType t2) -} + +data Evaluator m inp out a = Evaluator + { encoder :: Encoder m out a + , decoder :: Decoder m inp a + } + +data Encoder m s a = Encoder + { encodeType :: forall t . Type a t -> t -> m s + , encodeTerm :: a -> m s + , encodeTuple :: [s] -> s + } + +data Decoder m s a = Decoder + { decodeType :: forall t . Type a t -> s -> m (t, s) + , decodeTerm :: s -> m a + , decoderExercise :: Exercise a + } + +eval :: Monad m => Evaluator m inp out a -> TypedValue a -> inp -> m out +eval f (tv ::: tp) s = + case tp of + t1 :-> t2 -> do + (a, s1) <- decodeType (decoder f) t1 s + eval f (tv a ::: t2) s1 + _ -> + encodeType (encoder f) tp tv + +decodeDefault :: MonadPlus m => Decoder m s a -> Type a t -> s -> m (t, s) +decodeDefault dec tp s = + case tp of + Pair t1 t2 -> do + (a, s1) <- decodeType dec t1 s + (b, s2) <- decodeType dec t2 s1 + return ((a, b), s2) + Triple t1 t2 t3 -> do + (a, s1) <- decodeType dec t1 s + (b, s2) <- decodeType dec t2 s1 + (c, s3) <- decodeType dec t3 s2 + return ((a, b, c), s3) + Quadruple t1 t2 t3 t4 -> do + (a, s1) <- decodeType dec t1 s + (b, s2) <- decodeType dec t2 s1 + (c, s3) <- decodeType dec t3 s2 + (d, s4) <- decodeType dec t4 s3 + return ((a, b, c, d), s4) + Tag _ t1 -> + decodeType dec t1 s + Optional a t1 -> + decodeType dec t1 s `mplus` return (a, s) + Maybe t1 -> + liftM (first Just) (decodeType dec t1 s) `mplus` return (Nothing, s) + _ -> + fail $ "No support for argument type: " ++ show tp + +encodeDefault :: Monad m => Encoder m s a -> Type a t -> t -> m s +encodeDefault enc tp tv = + case tp of + Pair t1 t2 -> do + let (a, b) = tv + x <- encodeType enc t1 a + y <- encodeType enc t2 b + return (encodeTuple enc [x, y]) + Triple t1 t2 t3 -> do + let (a, b, c) = tv + x <- encodeType enc t1 a + y <- encodeType enc t2 b + z <- encodeType enc t3 c + return (encodeTuple enc [x, y, z]) + Quadruple t1 t2 t3 t4 -> do + let (a, b, c, d) = tv + x <- encodeType enc t1 a + y <- encodeType enc t2 b + z <- encodeType enc t3 c + u <- encodeType enc t4 d + return (encodeTuple enc [x, y, z, u]) + Tag _ t1 -> encodeType enc t1 tv + Elem t1 -> encodeType enc t1 tv + Optional _ t1 -> encodeType enc t1 tv + Maybe t1 -> case tv of + Just a -> encodeType enc t1 a + Nothing -> return (encodeTuple enc []) + IO t1 -> encodeType enc t1 (unsafePerformIO tv) + Rule -> encodeType enc String (name tv) + Term -> encodeTerm enc (fromContext tv) + Location -> encodeType enc String (show tv) + _ -> fail "No support for result type" diff --git a/src/Text/HTML.hs b/src/Text/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A minimal interface for constructing simple HTML pages +-- +----------------------------------------------------------------------------- +module Text.HTML + ( HTML, HTMLBuilder, showHTML + , htmlPage, errorPage, link, h1, h2, preText, ul, table, text, image, space + , bold, italic, para, ttText, hr, br, pre, center + ) where + +import Text.XML hiding (text) +import qualified Text.XML as XML + +type HTML = XML + +type HTMLBuilder = XMLBuilder + +showHTML :: HTML -> String +showHTML = compactXML + +-- html helper functions +htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML +htmlPage title css body = makeXML "html" $ do + element "head" $ do + element "title" (text title) + case css of + Nothing -> return () + Just n -> element "link" $ do + "rel" .=. "STYLESHEET" + "href" .=. n + "type" .=. "text/css" + element "body" body + +errorPage :: String -> HTML +errorPage s = htmlPage "Error" Nothing $ do + h1 "Error" + text s + +link :: String -> HTMLBuilder -> HTMLBuilder +link url body = element "a" $ + ("href" .=. url) >> body + +center :: HTMLBuilder -> HTMLBuilder +center = element "center" + +h1 :: String -> HTMLBuilder +h1 = element "h1" . text + +h2 :: String -> HTMLBuilder +h2 = element "h2" . text + +bold, italic :: HTMLBuilder -> HTMLBuilder +bold = element "b" +italic = element "i" + +para :: HTMLBuilder -> HTMLBuilder +para = element "p" + +preText :: String -> HTMLBuilder +preText = pre . text + +pre :: HTMLBuilder -> HTMLBuilder +pre = element "pre" + +hr :: HTMLBuilder +hr = tag "hr" + +br :: HTMLBuilder +br = tag "br" + +tt :: HTMLBuilder -> HTMLBuilder +tt = element "tt" + +ttText :: String -> HTMLBuilder +ttText = tt . text + +ul :: [HTMLBuilder] -> HTMLBuilder +ul = element "ul" . mapM_ (element "li") + +table :: [[HTMLBuilder]] -> HTMLBuilder +table rows = element "table" $ do + "border" .=. "1" + mapM_ (element "tr" . mapM_ (element "td")) rows + +space :: HTMLBuilder +space = XML.text " " + +image :: String -> HTMLBuilder +image n = element "img" ("src" .=. n) + +text :: String -> HTMLBuilder +text = XML.text . escape + +escape :: String -> String +escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '\n' = "
" + f c = [c] diff --git a/src/Text/JSON.hs b/src/Text/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Text/JSON.hs @@ -0,0 +1,252 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for JavaScript Object Notation (JSON) and remote procedure calls using +-- JSON. JSON is a lightweight alternative for XML. +-- +----------------------------------------------------------------------------- +module Text.JSON + ( JSON(..), Key, Number(..) -- types + , InJSON(..) -- type class" + , lookupM + , parseJSON, showCompact, showPretty -- parser and pretty-printers + , jsonRPC, JSON_RPC_Handler + ) where + +import Text.Parsing +import qualified Text.UTF8 as UTF8 +import Common.Utils (indent) +import Data.Char +import Data.List (intersperse) +import Data.Maybe +import Control.Monad +import Service.Revision (version, revision) + +-- temporary test +{- +main :: IO () +main = do + input <- readFile "ex.json" + print (scan input) + putStrLn input + let Just json = parseJSON input + print json + print (parseJSON $ show json) +-} + +data JSON + = Number Number -- integer, real, or floating point + | String String -- double-quoted Unicode with backslash escapement + | Boolean Bool -- true and false + | Array [JSON] -- ordered sequence (comma-separated, square brackets) + | Object [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets + | Null + +type Key = String + +data Number = I Integer | F Float + +instance Show JSON where + show = showPretty + +showCompact :: JSON -> String +showCompact json = + case json of + Number n -> show n + String s -> "\"" ++ escape s ++ "\"" + Boolean b -> if b then "true" else "false" + Array xs -> squareBrackets $ concat $ intersperse ", " $ map showCompact xs + Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v + in curlyBrackets $ concat $ intersperse ", " $ map f xs + Null -> "null" + +-- Escape double quote and backslash, and convert to UTF8 encoding +escape :: String -> String +escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM + where + f '"' = "\\\"" + f '\\' = "\\\\" + f c = [c] + +showPretty :: JSON -> String +showPretty json = + case json of + Array xs -> squareBrackets $ '\n' : indent 3 (commas (map showPretty xs)) + Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v + in curlyBrackets $ '\n' : indent 3 (commas (map f xs)) + _ -> showCompact json + where + commas [] = [] + commas [x] = x + commas (x:xs) = x ++ ",\n" ++ commas xs + +instance Show Number where + show (I n) = show n + show (F f) = show f + +class InJSON a where + toJSON :: a -> JSON + listToJSON :: [a] -> JSON + fromJSON :: Monad m => JSON -> m a + listFromJSON :: Monad m => JSON -> m [a] + -- default definitions + listToJSON = Array . map toJSON + listFromJSON (Array xs) = mapM fromJSON xs + listFromJSON _ = fail "expecting an array" + +instance InJSON Int where + toJSON = toJSON . toInteger + fromJSON = liftM fromInteger . fromJSON + +instance InJSON Integer where + toJSON = Number . I + fromJSON (Number (I n)) = return n + fromJSON _ = fail "expecting a number" + +instance InJSON Float where + toJSON = Number . F + fromJSON (Number (F n)) = return n + fromJSON _ = fail "expecting a number" + +instance InJSON Char where + toJSON c = String [c] + listToJSON = String + fromJSON (String [c]) = return c + fromJSON _ = fail "expecting a string" + listFromJSON (String s) = return s + listFromJSON _ = fail "expecting a string" + +instance InJSON Bool where + toJSON = Boolean + fromJSON (Boolean b) = return b + fromJSON _ = fail "expecting a boolean" + +instance InJSON a => InJSON [a] where + toJSON = listToJSON + fromJSON = listFromJSON + +instance (InJSON a, InJSON b) => InJSON (a, b) where + toJSON (a, b) = Array [toJSON a, toJSON b] + fromJSON (Array [a, b]) = liftM2 (,) (fromJSON a) (fromJSON b) + fromJSON _ = fail "expecting an array with 2 elements" + +instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where + toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c] + fromJSON (Array [a, b, c]) = liftM3 (,,) (fromJSON a) (fromJSON b) (fromJSON c) + fromJSON _ = fail "expecting an array with 3 elements" + +instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where + toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d) + fromJSON _ = fail "expecting an array with 4 elements" + +parseJSON :: String -> Maybe JSON +parseJSON input = + case parse json (scanWith (makeCharsSpecial ":" defaultScanner) input) of + (result, []) -> Just result + _ -> Nothing + where + json :: TokenParser JSON + json = (Number . I) <$> pInteger + <|> (Number . F) <$> pFraction + <|> (String . fromMaybe [] . UTF8.decodeM) <$> pString + <|> Boolean True <$ pKey "true" + <|> Boolean False <$ pKey "false" + <|> Array <$> pBracks (pCommas json) + <|> Object <$> pCurly (pCommas keyValue) + <|> Null <$ pKey "null" + + keyValue :: TokenParser (String, JSON) + keyValue = (,) <$> pString <* pSpec ':' <*> json + +squareBrackets, curlyBrackets :: String -> String +squareBrackets s = "[" ++ s ++ "]" +curlyBrackets s = "{" ++ s ++ "}" + +-------------------------------------------------------- +-- JSON-RPC + +data JSON_RPC_Request = Request + { requestMethod :: String + , requestParams :: JSON + , requestId :: JSON + } + +data JSON_RPC_Response = Response + { responseResult :: JSON + , responseError :: JSON + , responseId :: JSON + } + +instance Show JSON_RPC_Request where + show = show . toJSON + +instance Show JSON_RPC_Response where + show = show . toJSON + +instance InJSON JSON_RPC_Request where + toJSON req = Object + [ ("method", String $ requestMethod req) + , ("params", requestParams req) + , ("id" , requestId req) + ] + fromJSON obj = do + mj <- lookupM "method" obj + pj <- lookupM "params" obj + ij <- lookupM "id" obj + case mj of + String s -> return (Request s pj ij) + _ -> fail "expecting a string" + +instance InJSON JSON_RPC_Response where + toJSON resp = Object + [ ("result", responseResult resp) + , ("error" , responseError resp) + , ("id" , responseId resp) + , ("version", String $ version ++ " (" ++ show revision ++ ")") + ] + fromJSON obj = do + rj <- lookupM "result" obj + ej <- lookupM "error" obj + ij <- lookupM "id" obj + return (Response rj ej ij) + +okResponse :: JSON -> JSON -> JSON_RPC_Response +okResponse x y = Response + { responseResult = x + , responseError = Null + , responseId = y + } + +errorResponse :: JSON -> JSON -> JSON_RPC_Response +errorResponse x y = Response + { responseResult = Null + , responseError = x + , responseId = y + } + +lookupM :: Monad m => String -> JSON -> m JSON +lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs) +lookupM _ _ = fail "expecting a JSON object" + +-------------------------------------------------------- +-- JSON-RPC over HTTP + +type JSON_RPC_Handler = String -> JSON -> IO JSON + +jsonRPC :: String -> JSON_RPC_Handler -> IO String +jsonRPC input handler = + case parseJSON input >>= fromJSON of + Nothing -> fail "Invalid request" + Just req -> do + json <- handler (requestMethod req) (requestParams req) + return $ show $ okResponse json (requestId req) + `catch` \e -> + return $ show $ errorResponse (String (show e)) (requestId req) diff --git a/src/Text/OpenMath/ContentDictionary.hs b/src/Text/OpenMath/ContentDictionary.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/ContentDictionary.hs @@ -0,0 +1,157 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.ContentDictionary + ( -- data types + ContentDictionary(..), VersionNumber, Date + , ContentDictionaryStatus(..), Definition(..) + -- parsing and reading + , readContentDictionary, main, findOCDs + ) where + +import Text.OpenMath.Object (OMOBJ, xml2omobj) +import Text.XML +import Data.Char +import Data.List +import Data.Maybe +import Control.Monad +import System.Directory + +main :: IO () +main = do + let base = "lib/Dictionaries" + f x = base ++ "/" ++ x + xs <- findOCDs base + cds <- mapM (readContentDictionary . f) xs + let defs = concatMap definitions cds + putStrLn $ show (length cds) ++ " valid dictionaries, with " ++ show (length defs) ++ " definitions" + + -- print [ p | d <- defs, p <- formalProperties d ] + +findOCDs :: String -> IO [FilePath] +findOCDs filepath = do + xs <- getDirectoryContents filepath + return $ filter (".ocd" `isSuffixOf`) xs + +readContentDictionary :: String -> IO ContentDictionary +readContentDictionary filename = do + putStrLn $ "reading " ++ show filename ++ "..." + input <- readFile filename + case parseXML input of + Left s -> err s + Right xml -> do + guard (name xml == "CD") + case buildContentDictionary xml of + Left s -> err s + Right cd -> do + putStrLn $ " found " ++ show (length $ definitions cd) ++ " definition(s)" + return cd + `catch` (err . show) + where + err s = fail $ "Content dictionary not found: " ++ s + +buildContentDictionary :: XML -> Either String ContentDictionary +buildContentDictionary xml = do + cdname <- extractText "CDName" xml + descr <- extractText "Description" xml + revision <- extractDate "CDDate" xml + review <- extractDate "CDReviewDate" xml + major <- extractInt "CDVersion" xml + minor <- extractInt "CDRevision" xml + theStatus <- extractStatus xml + let theBase = extractText "CDBase" xml + theURL <- extractText "CDURL" xml + defs <- mapM buildDefinition [ d | d <- children xml, name d == "CDDefinition" ] + return CD + { dictionaryName = cdname + , description = descr + , revisionDate = revision + , reviewDate = review + , versionNumber = (major, minor) + , status = theStatus + , base = theBase + , url = theURL + , definitions = defs + } + +buildDefinition :: XML -> Either String Definition +buildDefinition xml = do + theName <- extractText "Name" xml + descr <- extractText "Description" xml + let theRole = extractText "Role" xml + cmps = [ getData a | a <- children xml, name a == "CMP" ] + fmps = [ head xs | a <- children xml, name a == "FMP", let xs=children a, length xs==1 ] + exs = [ children a | a <- children xml, name a == "Example" ] + return Definition + { symbolName = theName + , symbolDescription = descr + , role = theRole + , commentedProperties = cmps + , formalProperties = map (either error id . xml2omobj) fmps + , examples = exs + } + +extractDate :: String -> XML -> Either String Date +extractDate s xml = do + txt <- extractText s xml + case txt of + [y1,y2,y3,y4,'-',m1,m2,'-',d1,d2] | all isDigit [y1,y2,y3,y4,m1,m2,d1,d2] -> + return (read [y1,y2,y3,y4], read [m1,m2], read [d1,d2]) + _ -> fail ("invalid date (YYYY-MM-DD): " ++ txt) + +extractInt :: String -> XML -> Either String Int +extractInt s xml = do + txt <- extractText s xml + case reads txt of + [(n, xs)] | all isSpace xs -> + return n + _ -> fail ("invalid number" ++ txt) + +extractStatus :: XML -> Either String ContentDictionaryStatus +extractStatus xml = do + txt <- extractText "CDStatus" xml + let (hd, tl) = splitAt 1 txt + case reads (map toUpper hd ++ map toLower tl) of + [(st, xs)] | all isSpace xs -> + return st + _ -> fail ("invalid status: " ++ txt) + +extractText :: MonadPlus m => String -> XML -> m String +extractText s xml = do + a <- findChild s xml + guard (null $ children a) + return (getData a) + +data ContentDictionary = CD + { dictionaryName :: String + , description :: String + , revisionDate :: Date + , reviewDate :: Date + , versionNumber :: VersionNumber + , status :: ContentDictionaryStatus + , base :: Maybe String + , url :: String + , definitions :: [Definition] + } deriving Show + +type VersionNumber = (Int, Int) -- major and minor part +type Date = (Int, Int, Int) -- YYYY-MM-DD + +data ContentDictionaryStatus = Official | Experimental | Private | Obsolete deriving (Read,Show) + +data Definition = Definition + { symbolName :: String + , symbolDescription :: String + , role :: Maybe String + , commentedProperties :: [String] + , formalProperties :: [OMOBJ] + , examples :: [[XML]] + } deriving Show diff --git a/src/Text/OpenMath/Dictionary/Arith1.hs b/src/Text/OpenMath/Dictionary/Arith1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Arith1.hs @@ -0,0 +1,80 @@ +-- Automatically generated from content dictionary arith1.ocd. Do not change. +module Text.OpenMath.Dictionary.Arith1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in arith1 dictionary +arith1List :: [Symbol] +arith1List = [lcmSymbol, gcdSymbol, plusSymbol, unaryMinusSymbol, minusSymbol, timesSymbol, divideSymbol, powerSymbol, absSymbol, rootSymbol, sumSymbol, productSymbol] + +{-| The symbol to represent the n-ary function to return the least common +multiple of its arguments. -} +lcmSymbol :: Symbol +lcmSymbol = makeSymbol "arith1" "lcm" + +{-| The symbol to represent the n-ary function to return the gcd (greatest +common divisor) of its arguments. -} +gcdSymbol :: Symbol +gcdSymbol = makeSymbol "arith1" "gcd" + +{-| The symbol representing an n-ary commutative function plus. -} +plusSymbol :: Symbol +plusSymbol = makeSymbol "arith1" "plus" + +{-| This symbol denotes unary minus, i.e. the additive inverse. -} +unaryMinusSymbol :: Symbol +unaryMinusSymbol = makeSymbol "arith1" "unary_minus" + +{-| The symbol representing a binary minus function. This is equivalent to +adding the additive inverse. -} +minusSymbol :: Symbol +minusSymbol = makeSymbol "arith1" "minus" + +{-| The symbol representing an n-ary multiplication function. -} +timesSymbol :: Symbol +timesSymbol = makeSymbol "arith1" "times" + +{-| This symbol represents a (binary) division function denoting the first +argument right-divided by the second, i.e. divide(a,b)=a*inverse(b). It is the +inverse of the multiplication function defined by the symbol times in this CD. +-} +divideSymbol :: Symbol +divideSymbol = makeSymbol "arith1" "divide" + +{-| This symbol represents a power function. The first argument is raised to +the power of the second argument. When the second argument is not an integer, +powering is defined in terms of exponentials and logarithms for the complex +and real numbers. This operator can represent general powering. -} +powerSymbol :: Symbol +powerSymbol = makeSymbol "arith1" "power" + +{-| A unary operator which represents the absolute value of its argument. The +argument should be numerically valued. In the complex case this is often +referred to as the modulus. -} +absSymbol :: Symbol +absSymbol = makeSymbol "arith1" "abs" + +{-| A binary operator which represents its first argument "lowered" to its +n'th root where n is the second argument. This is the inverse of the operation +represented by the power symbol defined in this CD. Care should be taken as to +the precise meaning of this operator, in particular which root is represented, +however it is here to represent the general notion of taking n'th roots. As +inferred by the signature relevant to this symbol, the function represented by +this symbol is the single valued function, the specific root returned is the +one indicated by the first CMP. Note also that the converse of the second CMP +is not valid in general. -} +rootSymbol :: Symbol +rootSymbol = makeSymbol "arith1" "root" + +{-| An operator taking two arguments, the first being the range of summation, +e.g. an integral interval, the second being the function to be summed. Note +that the sum may be over an infinite interval. -} +sumSymbol :: Symbol +sumSymbol = makeSymbol "arith1" "sum" + +{-| An operator taking two arguments, the first being the range of +multiplication e.g. an integral interval, the second being the function to be +multiplied. Note that the product may be over an infinite interval. -} +productSymbol :: Symbol +productSymbol = makeSymbol "arith1" "product" + diff --git a/src/Text/OpenMath/Dictionary/Calculus1.hs b/src/Text/OpenMath/Dictionary/Calculus1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Calculus1.hs @@ -0,0 +1,37 @@ +-- Automatically generated from content dictionary calculus1.ocd. Do not change. +module Text.OpenMath.Dictionary.Calculus1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in calculus1 dictionary +calculus1List :: [Symbol] +calculus1List = [diffSymbol, nthdiffSymbol, partialdiffSymbol, intSymbol, defintSymbol] + +{-| This symbol is used to express ordinary differentiation of a unary +function. The single argument is the unary function. -} +diffSymbol :: Symbol +diffSymbol = makeSymbol "calculus1" "diff" + +{-| This symbol is used to express the nth-iterated ordinary differentiation +of a unary function. The first argument is n, and the second the unary +function. -} +nthdiffSymbol :: Symbol +nthdiffSymbol = makeSymbol "calculus1" "nthdiff" + +{-| This symbol is used to express partial differentiation of a function of +more than one variable. It has two arguments, the first is a list of integers +which index the variables of the function, the second is the function. -} +partialdiffSymbol :: Symbol +partialdiffSymbol = makeSymbol "calculus1" "partialdiff" + +{-| This symbol is used to represent indefinite integration of unary +functions. The argument is the unary function. -} +intSymbol :: Symbol +intSymbol = makeSymbol "calculus1" "int" + +{-| This symbol is used to represent definite integration of unary functions. +It takes two arguments; the first being the range (e.g. a set) of integration, +and the second the function. -} +defintSymbol :: Symbol +defintSymbol = makeSymbol "calculus1" "defint" + diff --git a/src/Text/OpenMath/Dictionary/Fns1.hs b/src/Text/OpenMath/Dictionary/Fns1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Fns1.hs @@ -0,0 +1,74 @@ +-- Automatically generated from content dictionary fns1.ocd. Do not change. +module Text.OpenMath.Dictionary.Fns1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in fns1 dictionary +fns1List :: [Symbol] +fns1List = [domainofapplicationSymbol, domainSymbol, rangeSymbol, imageSymbol, identitySymbol, leftInverseSymbol, rightInverseSymbol, inverseSymbol, leftComposeSymbol, lambdaSymbol] + +{-| The domainofapplication element denotes the domain over which a given +function is being applied. It is intended in MathML to be a more general +alternative to specification of this domain using such quantifier elements as +bvar, lowlimit or condition. -} +domainofapplicationSymbol :: Symbol +domainofapplicationSymbol = makeSymbol "fns1" "domainofapplication" + +{-| This symbol denotes the domain of a given function, which is the set of +values it is defined over. -} +domainSymbol :: Symbol +domainSymbol = makeSymbol "fns1" "domain" + +{-| This symbol denotes the range of a function, that is a set that the +function will map to. The single argument should be the function whos range is +being queried. It should be noted that this is not necessarily equal to the +image, it is merely required to contain the image. -} +rangeSymbol :: Symbol +rangeSymbol = makeSymbol "fns1" "range" + +{-| This symbol denotes the image of a given function, which is the set of +values the domain of the given function maps to. -} +imageSymbol :: Symbol +imageSymbol = makeSymbol "fns1" "image" + +{-| The identity function, it takes one argument and returns the same value. +-} +identitySymbol :: Symbol +identitySymbol = makeSymbol "fns1" "identity" + +{-| This symbol is used to describe the left inverse of its argument (a +function). This inverse may only be partially defined because the function may +not have been surjective. If the function is not surjective the left inverse +function is ill-defined without further stipulations. No other assumptions are +made on the semantics of this left inverse. -} +leftInverseSymbol :: Symbol +leftInverseSymbol = makeSymbol "fns1" "left_inverse" + +{-| This symbol is used to describe the right inverse of its argument (a +function). This inverse may only be partially defined because the function may +not have been surjective. If the function is not surjective the right inverse +function is ill-defined without further stipulations. No other assumptions are +made on the semantics of this right inverse. -} +rightInverseSymbol :: Symbol +rightInverseSymbol = makeSymbol "fns1" "right_inverse" + +{-| This symbol is used to describe the inverse of its argument (a function). +This inverse may only be partially defined because the function may not have +been surjective. If the function is not surjective the inverse function is +ill-defined without further stipulations. No assumptions are made on the +semantics of this inverse. -} +inverseSymbol :: Symbol +inverseSymbol = makeSymbol "fns1" "inverse" + +{-| This symbol represents the function which forms the left-composition of +its two (function) arguments. -} +leftComposeSymbol :: Symbol +leftComposeSymbol = makeSymbol "fns1" "left_compose" + +{-| This symbol is used to represent anonymous functions as lambda expansions. +It is used in a binder that takes two further arguments, the first of which is +a list of variables, and the second of which is an expression, and it forms +the function which is the lambda extraction of the expression -} +lambdaSymbol :: Symbol +lambdaSymbol = makeSymbol "fns1" "lambda" + diff --git a/src/Text/OpenMath/Dictionary/Linalg2.hs b/src/Text/OpenMath/Dictionary/Linalg2.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Linalg2.hs @@ -0,0 +1,25 @@ +-- Automatically generated from content dictionary linalg2.ocd. Do not change. +module Text.OpenMath.Dictionary.Linalg2 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in linalg2 dictionary +linalg2List :: [Symbol] +linalg2List = [vectorSymbol, matrixrowSymbol, matrixSymbol] + +{-| This symbol represents an n-ary function used to construct (or describe) +vectors. Vectors in this CD are considered to be row vectors and must +therefore be transposed to be considered as column vectors. -} +vectorSymbol :: Symbol +vectorSymbol = makeSymbol "linalg2" "vector" + +{-| This symbol is an n-ary constructor used to represent rows of matrices. +Its arguments should be members of a ring. -} +matrixrowSymbol :: Symbol +matrixrowSymbol = makeSymbol "linalg2" "matrixrow" + +{-| This symbol is an n-ary matrix constructor which requires matrixrow's as +arguments. It is used to represent matrices. -} +matrixSymbol :: Symbol +matrixSymbol = makeSymbol "linalg2" "matrix" + diff --git a/src/Text/OpenMath/Dictionary/List1.hs b/src/Text/OpenMath/Dictionary/List1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/List1.hs @@ -0,0 +1,29 @@ +-- Automatically generated from content dictionary list1.ocd. Do not change. +module Text.OpenMath.Dictionary.List1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in list1 dictionary +list1List :: [Symbol] +list1List = [mapSymbol, suchthatSymbol, listSymbol] + +{-| This symbol represents a mapping function which may be used to construct +lists, it takes as arguments a function from X to Y and a list over X in that +order. The value that is returned is a list of values in Y. The argument list +may be a set or an integer_interval. -} +mapSymbol :: Symbol +mapSymbol = makeSymbol "list1" "map" + +{-| This symbol represents the suchthat function which may be used to +construct lists, it takes two arguments. The first argument should be the set +which contains the elements of the list, the second argument should be a +predicate, that is a function from the set to the booleans which describes if +an element is to be in the list returned. -} +suchthatSymbol :: Symbol +suchthatSymbol = makeSymbol "list1" "suchthat" + +{-| This symbol denotes the list construct which is an n-ary function. The +list entries must be given explicitly. -} +listSymbol :: Symbol +listSymbol = makeSymbol "list1" "list" + diff --git a/src/Text/OpenMath/Dictionary/Logic1.hs b/src/Text/OpenMath/Dictionary/Logic1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Logic1.hs @@ -0,0 +1,51 @@ +-- Automatically generated from content dictionary logic1.ocd. Do not change. +module Text.OpenMath.Dictionary.Logic1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in logic1 dictionary +logic1List :: [Symbol] +logic1List = [equivalentSymbol, notSymbol, andSymbol, xorSymbol, orSymbol, impliesSymbol, trueSymbol, falseSymbol] + +{-| This symbol is used to show that two boolean expressions are logically +equivalent, that is have the same boolean value for any inputs. -} +equivalentSymbol :: Symbol +equivalentSymbol = makeSymbol "logic1" "equivalent" + +{-| This symbol represents the logical not function which takes one boolean +argument, and returns the opposite boolean value. -} +notSymbol :: Symbol +notSymbol = makeSymbol "logic1" "not" + +{-| This symbol represents the logical and function which is an n-ary function +taking boolean arguments and returning a boolean value. It is true if all +arguments are true or false otherwise. -} +andSymbol :: Symbol +andSymbol = makeSymbol "logic1" "and" + +{-| This symbol represents the logical xor function which is an n-ary function +taking boolean arguments and returning a boolean value. It is true if there +are an odd number of true arguments or false otherwise. -} +xorSymbol :: Symbol +xorSymbol = makeSymbol "logic1" "xor" + +{-| This symbol represents the logical or function which is an n-ary function +taking boolean arguments and returning a boolean value. It is true if any of +the arguments are true or false otherwise. -} +orSymbol :: Symbol +orSymbol = makeSymbol "logic1" "or" + +{-| This symbol represents the logical implies function which takes two +boolean expressions as arguments. It evaluates to false if the first argument +is true and the second argument is false, otherwise it evaluates to true. -} +impliesSymbol :: Symbol +impliesSymbol = makeSymbol "logic1" "implies" + +{-| This symbol represents the boolean value true. -} +trueSymbol :: Symbol +trueSymbol = makeSymbol "logic1" "true" + +{-| This symbol represents the boolean value false. -} +falseSymbol :: Symbol +falseSymbol = makeSymbol "logic1" "false" + diff --git a/src/Text/OpenMath/Dictionary/Nums1.hs b/src/Text/OpenMath/Dictionary/Nums1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Nums1.hs @@ -0,0 +1,55 @@ +-- Automatically generated from content dictionary nums1.ocd. Do not change. +module Text.OpenMath.Dictionary.Nums1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in nums1 dictionary +nums1List :: [Symbol] +nums1List = [basedIntegerSymbol, rationalSymbol, infinitySymbol, eSymbol, iSymbol, piSymbol, gammaSymbol, naNSymbol] + +{-| This symbol represents the constructor function for integers, specifying +the base. It takes two arguments, the first is a positive integer to denote +the base to which the number is represented, the second argument is a string +which contains an optional sign and the digits of the integer, using 0-9a-z +(as a consequence of this no radix greater than 35 is supported). Base 16 and +base 10 are already covered in the encodings of integers. -} +basedIntegerSymbol :: Symbol +basedIntegerSymbol = makeSymbol "nums1" "based_integer" + +{-| This symbol represents the constructor function for rational numbers. It +takes two arguments, the first is an integer p to denote the numerator and the +second a nonzero integer q to denote the denominator of the rational p/q. -} +rationalSymbol :: Symbol +rationalSymbol = makeSymbol "nums1" "rational" + +{-| A symbol to represent the notion of infinity. -} +infinitySymbol :: Symbol +infinitySymbol = makeSymbol "nums1" "infinity" + +{-| This symbol represents the base of the natural logarithm, approximately +2.718. See Abramowitz and Stegun, Handbook of Mathematical Functions, section +4.1. -} +eSymbol :: Symbol +eSymbol = makeSymbol "nums1" "e" + +{-| This symbol represents the square root of -1. -} +iSymbol :: Symbol +iSymbol = makeSymbol "nums1" "i" + +{-| A symbol to convey the notion of pi, approximately 3.142. The ratio of the +circumference of a circle to its diameter. -} +piSymbol :: Symbol +piSymbol = makeSymbol "nums1" "pi" + +{-| A symbol to convey the notion of the gamma constant as defined in +Abramowitz and Stegun, Handbook of Mathematical Functions, section 6.1.3. It +is the limit of 1 + 1/2 + 1/3 + ... + 1/m - ln m as m tends to infinity, this +is approximately 0.5772 15664. -} +gammaSymbol :: Symbol +gammaSymbol = makeSymbol "nums1" "gamma" + +{-| A symbol to convey the notion of not-a-number. The result of an ill-posed +floating computation. See IEEE standard for floating point representations. -} +naNSymbol :: Symbol +naNSymbol = makeSymbol "nums1" "NaN" + diff --git a/src/Text/OpenMath/Dictionary/Relation1.hs b/src/Text/OpenMath/Dictionary/Relation1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Relation1.hs @@ -0,0 +1,45 @@ +-- Automatically generated from content dictionary relation1.ocd. Do not change. +module Text.OpenMath.Dictionary.Relation1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in relation1 dictionary +relation1List :: [Symbol] +relation1List = [eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, geqSymbol, approxSymbol] + +{-| This symbol represents the binary equality function. -} +eqSymbol :: Symbol +eqSymbol = makeSymbol "relation1" "eq" + +{-| This symbol represents the binary less than function which returns true if +the first argument is less than the second, it returns false otherwise. -} +ltSymbol :: Symbol +ltSymbol = makeSymbol "relation1" "lt" + +{-| This symbol represents the binary greater than function which returns true +if the first argument is greater than the second, it returns false otherwise. +-} +gtSymbol :: Symbol +gtSymbol = makeSymbol "relation1" "gt" + +{-| This symbol represents the binary inequality function. -} +neqSymbol :: Symbol +neqSymbol = makeSymbol "relation1" "neq" + +{-| This symbol represents the binary less than or equal to function which +returns true if the first argument is less than or equal to the second, it +returns false otherwise. -} +leqSymbol :: Symbol +leqSymbol = makeSymbol "relation1" "leq" + +{-| This symbol represents the binary greater than or equal to function which +returns true if the first argument is greater than or equal to the second, it +returns false otherwise. -} +geqSymbol :: Symbol +geqSymbol = makeSymbol "relation1" "geq" + +{-| This symbol is used to denote the approximate equality of its two +arguments. -} +approxSymbol :: Symbol +approxSymbol = makeSymbol "relation1" "approx" + diff --git a/src/Text/OpenMath/Dictionary/Transc1.hs b/src/Text/OpenMath/Dictionary/Transc1.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Dictionary/Transc1.hs @@ -0,0 +1,150 @@ +-- Automatically generated from content dictionary transc1.ocd. Do not change. +module Text.OpenMath.Dictionary.Transc1 where + +import Text.OpenMath.Symbol + +-- | List of symbols defined in transc1 dictionary +transc1List :: [Symbol] +transc1List = [logSymbol, lnSymbol, expSymbol, sinSymbol, cosSymbol, tanSymbol, secSymbol, cscSymbol, cotSymbol, sinhSymbol, coshSymbol, tanhSymbol, sechSymbol, cschSymbol, cothSymbol, arcsinSymbol, arccosSymbol, arctanSymbol, arcsecSymbol, arccscSymbol, arccotSymbol, arcsinhSymbol, arccoshSymbol, arctanhSymbol, arcsechSymbol, arccschSymbol, arccothSymbol] + +{-| This symbol represents a binary log function; the first argument is the +base, to which the second argument is log'ed. It is defined in Abramowitz and +Stegun, Handbook of Mathematical Functions, section 4.1 -} +logSymbol :: Symbol +logSymbol = makeSymbol "transc1" "log" + +{-| This symbol represents the ln function (natural logarithm) as described in +Abramowitz and Stegun, section 4.1. It takes one argument. Note the +description in the CMP/FMP of the branch cut. If signed zeros are in use, the +inequality needs to be non-strict. -} +lnSymbol :: Symbol +lnSymbol = makeSymbol "transc1" "ln" + +{-| This symbol represents the exponentiation function as described in +Abramowitz and Stegun, section 4.2. It takes one argument. -} +expSymbol :: Symbol +expSymbol = makeSymbol "transc1" "exp" + +{-| This symbol represents the sin function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +sinSymbol :: Symbol +sinSymbol = makeSymbol "transc1" "sin" + +{-| This symbol represents the cos function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +cosSymbol :: Symbol +cosSymbol = makeSymbol "transc1" "cos" + +{-| This symbol represents the tan function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +tanSymbol :: Symbol +tanSymbol = makeSymbol "transc1" "tan" + +{-| This symbol represents the sec function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +secSymbol :: Symbol +secSymbol = makeSymbol "transc1" "sec" + +{-| This symbol represents the csc function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +cscSymbol :: Symbol +cscSymbol = makeSymbol "transc1" "csc" + +{-| This symbol represents the cot function as described in Abramowitz and +Stegun, section 4.3. It takes one argument. -} +cotSymbol :: Symbol +cotSymbol = makeSymbol "transc1" "cot" + +{-| This symbol represents the sinh function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +sinhSymbol :: Symbol +sinhSymbol = makeSymbol "transc1" "sinh" + +{-| This symbol represents the cosh function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +coshSymbol :: Symbol +coshSymbol = makeSymbol "transc1" "cosh" + +{-| This symbol represents the tanh function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +tanhSymbol :: Symbol +tanhSymbol = makeSymbol "transc1" "tanh" + +{-| This symbol represents the sech function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +sechSymbol :: Symbol +sechSymbol = makeSymbol "transc1" "sech" + +{-| This symbol represents the csch function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +cschSymbol :: Symbol +cschSymbol = makeSymbol "transc1" "csch" + +{-| This symbol represents the coth function as described in Abramowitz and +Stegun, section 4.5. It takes one argument. -} +cothSymbol :: Symbol +cothSymbol = makeSymbol "transc1" "coth" + +{-| This symbol represents the arcsin function. This is the inverse of the sin +function as described in Abramowitz and Stegun, section 4.4. It takes one +argument. -} +arcsinSymbol :: Symbol +arcsinSymbol = makeSymbol "transc1" "arcsin" + +{-| This symbol represents the arccos function. This is the inverse of the cos +function as described in Abramowitz and Stegun, section 4.4. It takes one +argument. -} +arccosSymbol :: Symbol +arccosSymbol = makeSymbol "transc1" "arccos" + +{-| This symbol represents the arctan function. This is the inverse of the tan +function as described in Abramowitz and Stegun, section 4.4. It takes one +argument. -} +arctanSymbol :: Symbol +arctanSymbol = makeSymbol "transc1" "arctan" + +{-| This symbol represents the arcsec function as described in Abramowitz and +Stegun, section 4.4. -} +arcsecSymbol :: Symbol +arcsecSymbol = makeSymbol "transc1" "arcsec" + +{-| This symbol represents the arccsc function as described in Abramowitz and +Stegun, section 4.4. -} +arccscSymbol :: Symbol +arccscSymbol = makeSymbol "transc1" "arccsc" + +{-| This symbol represents the arccot function as described in Abramowitz and +Stegun, section 4.4. -} +arccotSymbol :: Symbol +arccotSymbol = makeSymbol "transc1" "arccot" + +{-| This symbol represents the arcsinh function as described in Abramowitz and +Stegun, section 4.6. -} +arcsinhSymbol :: Symbol +arcsinhSymbol = makeSymbol "transc1" "arcsinh" + +{-| This symbol represents the arccosh function as described in Abramowitz and +Stegun, section 4.6. -} +arccoshSymbol :: Symbol +arccoshSymbol = makeSymbol "transc1" "arccosh" + +{-| This symbol represents the arctanh function as described in Abramowitz and +Stegun, section 4.6. -} +arctanhSymbol :: Symbol +arctanhSymbol = makeSymbol "transc1" "arctanh" + +{-| This symbol represents the arcsech function as described in Abramowitz and +Stegun, section 4.6. -} +arcsechSymbol :: Symbol +arcsechSymbol = makeSymbol "transc1" "arcsech" + +{-| This symbol represents the arccsch function as described in Abramowitz and +Stegun, section 4.6. -} +arccschSymbol :: Symbol +arccschSymbol = makeSymbol "transc1" "arccsch" + +{-| This symbol represents the arccoth function as described in Abramowitz and +Stegun, section 4.6. -} +arccothSymbol :: Symbol +arccothSymbol = makeSymbol "transc1" "arccoth" + diff --git a/src/Text/OpenMath/MakeSymbols.hs b/src/Text/OpenMath/MakeSymbols.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/MakeSymbols.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Create symbol definitions from OpenMath content dictionary (ocd) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.MakeSymbols where + +import Text.OpenMath.ContentDictionary hiding (main) +import Control.Monad +import Data.Char +import Data.List + +main :: IO () +main = do + let base = "lib/Dictionaries" + target = "src/Text/Openmath/Dictionary" + ocds <- findOCDs base + forM_ ocds $ \s -> do + let modn = target ++ "/" ++ moduleName s ++ ".hs" + txt <- makeSymbols (base ++ "/" ++ s) + putStrLn $ " writing " ++ modn + writeFile modn txt + +moduleName :: String -> String +moduleName s = dropSuffix (map toUpper (take 1 s) ++ drop 1 s) + +dropDir :: String -> String +dropDir s + | '/' `elem` s = dropDir $ drop 1 $dropWhile (/='/') s + | otherwise = s + +dropSuffix :: String -> String +dropSuffix = takeWhile (/='.') + +makeSymbols :: String -> IO String +makeSymbols file = do + cd <- readContentDictionary file + let cdname = dropDir file + return $ unlines $ + [ "-- Automatically generated from content dictionary " ++ cdname ++ ". \ + \ Do not change." + , "module Text.OpenMath.Dictionary." ++ moduleName cdname ++ " where\n" + , "import Text.OpenMath.Symbol\n" + , makeSymbolList cd + ] ++ + map (makeSymbol (dropSuffix cdname)) (definitions cd) + +symbolIdentifier :: Definition -> String +symbolIdentifier d = f (symbolName d) ++ "Symbol" + where f xs = map toLower (take 1 xs) ++ camelCase (drop 1 xs) + +camelCase :: String -> String +camelCase [] = [] +camelCase ('_':x:xs) = toUpper x : camelCase xs +camelCase (x:xs) = x : camelCase xs + +makeSymbolList :: ContentDictionary -> String +makeSymbolList cd = unlines + [ "-- | List of symbols defined in " ++ dictionaryName cd ++ " dictionary" + , name ++ " :: [Symbol]" + , name ++ " = [" ++ concat (intersperse ", " list) ++ "]" + ] + where + name = dictionaryName cd ++ "List" + list = map symbolIdentifier (definitions cd) + +makeSymbol :: String -> Definition -> String +makeSymbol dict def = unlines $ + makeComment 80 (symbolDescription def) ++ + [ name ++ " :: Symbol" + , name ++ " = makeSymbol " ++ show dict ++ " " ++ show (symbolName def) + ] + where + name = symbolIdentifier def + +makeComment :: Int -> String -> [String] +makeComment n = breaks . comment . words + where + comment xs = ["{-|"] ++ xs ++ ["-}"] + accLength = scanl (\n -> (+n) . succ . length) 0 + breaks xs + | null xs = [] + | otherwise = + case break ((>=n) . fst) (zip (drop 1 (accLength xs)) xs) of + (as, bs) -> unwords (map snd as) : breaks (map snd bs) diff --git a/src/Text/OpenMath/Object.hs b/src/Text/OpenMath/Object.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Object.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Object + ( OMOBJ(..), xml2omobj, omobj2xml + ) where + +import Text.XML +import Data.Char (isSpace) +import Data.Maybe +import Text.OpenMath.Symbol + +-- internal representation for OpenMath objects +data OMOBJ = OMI Integer + | OMF Float + | OMV String + | OMS Symbol + | OMA [OMOBJ] + | OMBIND OMOBJ [String] OMOBJ + deriving (Show, Eq) + +instance InXML OMOBJ where + toXML = omobj2xml + fromXML = either fail return . xml2omobj + +---------------------------------------------------------- +-- conversion functions: XML <-> OMOBJ + +xml2omobj :: XML -> Either String OMOBJ +xml2omobj xml = + case xml of + Element "OMOBJ" _ [Right e] -> rec e + _ -> fail $ "expected an OMOBJ tag" ++ show xml + where + rec xml = + case content xml of + + _ | name xml == "OMA" -> do + ys <- mapM rec (children xml) + return (OMA ys) + + [] | name xml == "OMS" -> do + let mcd = findAttribute "cd" xml + name <- findAttribute "name" xml + return (OMS (Symbol mcd name)) + + [Left s] | name xml == "OMI" -> + case reads s of + [(i, xs)] | all isSpace xs -> return (OMI i) + _ -> fail "invalid integer in OMI" + + [] | name xml == "OMF" -> do + s <- findAttribute "dec" xml + case reads s of + [(fp, xs)] | all isSpace xs -> return (OMF fp) + _ -> fail "invalid floating-point in OMF" + + [] | name xml == "OMV" -> do + s <- findAttribute "name" xml + return (OMV s) + + [Right x1, Right x2, Right x3] | name xml == "OMBIND" -> do + y1 <- rec x1 + y2 <- recOMBVAR x2 + y3 <- rec x3 + return (OMBIND y1 y2 y3) + + _ -> fail ("invalid tag " ++ show (name xml)) + + recOMBVAR xml + | name xml == "OMBVAR" = + let f (Right (OMV s)) = return s + f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this + in mapM (f . rec) (children xml) + | otherwise = + fail ("expected tag OMVAR, but found " ++ show tag) + +omobj2xml :: OMOBJ -> XML +omobj2xml object = makeXML "OMOBJ" $ do + "xmlns" .=. "http://www.openmath.org/OpenMath" + "version" .=. "2.0" + "cdbase" .=. "http://www.openmath.org/cd" + rec object + where + rec omobj = + case omobj of + OMI i -> element "OMI" (text (show i)) + OMF f -> element "OMF" ("dec" .=. show f) + OMV v -> element "OMV" ("name" .=. v) + OMA xs -> element "OMA" (mapM_ rec xs) + OMS s -> element "OMS" $ do + "cd" .=. fromMaybe "unknown" (dictionary s) + "name" .=. symbolName s + OMBIND x ys z -> element "OMBIND" $ do + rec x + element "OMBVAR" (mapM_ (rec . OMV) ys) + rec z diff --git a/src/Text/OpenMath/Reply.hs b/src/Text/OpenMath/Reply.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Reply.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Reply + ( Reply(..), replyToXML, replyInXML + , ReplyOk(..), ReplyIncorrect(..), ReplyError(..), Args + ) where + +import Control.Monad +import Common.Exercise +import Common.Strategy hiding (not) +import Domain.Math.Expr +import Text.OpenMath.Object +import Text.XML +import Service.Revision + +------------------------------------------------------------------------ +-- Data types for replies + +-- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error) +data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError + +data ReplyOk a = ReplyOk + { repOk_Code :: Exercise a + , repOk_Location :: StrategyLocation + , repOk_Context :: String + , repOk_Steps :: Int + } + +data ReplyIncorrect a = ReplyIncorrect + { repInc_Code :: Exercise a + , repInc_Location :: StrategyLocation + , repInc_Expected :: a + , repInc_Derivation :: [(String, a)] + , repInc_Arguments :: Args + , repInc_Steps :: Int + , repInc_Equivalent :: Bool + } + +data ReplyError = ReplyError + { repErr_Kind :: String + , repErr_Message :: String + } + +type Args = [(String, String)] + +------------------------------------------------------------------------ +-- Conversion functions to XML + +replyInXML :: IsExpr a => Reply a -> String +replyInXML = showXML . replyToXML + +replyToXML :: IsExpr a => Reply a -> XML +replyToXML reply = + case reply of + Ok r -> replyOkToXML r + Incorrect r -> replyIncorrectToXML r + Error r -> replyErrorToXML r + +replyOkToXML :: ReplyOk a -> XML +replyOkToXML r = makeReply "ok" $ do + element "strategy" (text $ show $ exerciseCode $ repOk_Code r) + element "location" (text $ show $ repOk_Location r) + element "context" (text $ repOk_Context r) + element "steps" (text $ show $ repOk_Steps r) + +replyIncorrectToXML :: IsExpr a => ReplyIncorrect a -> XML +replyIncorrectToXML r = makeReply "incorrect" $ do + element "strategy" (text $ show $ exerciseCode $ repInc_Code r) + element "location" (text $ show $ repInc_Location r) + element "expected" (builder $ omobj2xml $ toOMOBJ $ toExpr $ repInc_Expected r) + element "steps" (text $ show $ repInc_Steps r) + element "equivalent" (text $ show $ repInc_Equivalent r) + + unless (null $ repInc_Arguments r) $ + let f (x, y) = element "elem" $ do + "descr" .=. x + text y + in element "arguments" $ mapM_ f (repInc_Arguments r) + + unless (null $ repInc_Derivation r) $ + let f (x,y) = element "elem" $ do + "ruleid" .=. x + builder (omobj2xml (toOMOBJ (toExpr y))) + in element "derivation" $ mapM_ f (repInc_Derivation r) + +replyErrorToXML :: ReplyError -> XML +replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r) + +makeReply :: String -> XMLBuilder -> XML +makeReply kind body = makeXML "reply" $ do + "result" .=. kind + "version" .=. version + body diff --git a/src/Text/OpenMath/Request.hs b/src/Text/OpenMath/Request.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Request.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Request (xmlToRequest) where + +import Service.TypedAbstractService +import Text.XML +import Control.Monad +import Common.Context +import Common.Exercise +import Common.Strategy hiding (fail) +import Common.Utils (splitAtElem) +import Text.OpenMath.Object +import Data.Char +import Data.Maybe +import Domain.Math.Expr + +extractString :: String -> XML -> Either String String +extractString s = liftM getData . findChild s + +xmlToRequest :: IsExpr a => XML -> Exercise a -> Either String (State a, StrategyLocation, Maybe a) +xmlToRequest xml ex = do + unless (name xml == "request") $ + fail "XML document is not a request" + loc <- optional (extractLocation "location" xml) + term <- extractExpr "term" xml + context <- optional (extractString "context" xml) + answer <- optional (extractExpr "answer" xml) + t <- fromExpr $ fromOMOBJ term + mt <- case answer of + Nothing -> return Nothing + Just o -> return $ fromExpr $ fromOMOBJ o + return + ( State + { exercise = ex + , prefix = case context of + Just s -> Just $ getPrefix2 s (strategy ex) + Nothing -> Just $ emptyPrefix (strategy ex) + , context = case context of + Just s -> putInContext2 s t + Nothing -> inContext t + } + , fromMaybe [] loc + , mt + ) + +----------------------------------------------------------- +putInContext2 :: String -> a -> Context a +putInContext2 s = fromMaybe inContext $ do + (_, s2) <- splitAtElem ';' s + c <- parseContext s2 + return (flip fmap c . const) + +getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a) +getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do + (s1, _) <- splitAtElem ';' s + case reads s1 of + [(is, xs)] | all isSpace xs -> return (makePrefix is ls) + _ -> Nothing + +optional :: Either String a -> Either String (Maybe a) +optional = Right . either (const Nothing) Just + +extractLocation :: String -> XML -> Either String StrategyLocation +extractLocation s xml = do + c <- findChild s xml + case reads (getData c) of + [(n, xs)] | all isSpace xs -> return n + _ -> fail "invalid location" + +extractExpr :: String -> XML -> Either String OMOBJ +extractExpr n xml = + case findChild n xml of + Just expr -> + case children expr of + [this] -> xml2omobj this + _ -> fail $ "error in " ++ show (n, xml) + _ -> fail $ "error in " ++ show (n, xml) diff --git a/src/Text/OpenMath/Symbol.hs b/src/Text/OpenMath/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Text/OpenMath/Symbol.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +module Text.OpenMath.Symbol where + +data Symbol = Symbol + { dictionary :: Maybe String + , symbolName :: String + } + deriving (Eq, Ord) + +instance Show Symbol where + show s = maybe "" (++".") (dictionary s) ++ symbolName s + +makeSymbol :: String -> String -> Symbol +makeSymbol = Symbol . Just + +extraSymbol :: String -> Symbol +extraSymbol = Symbol Nothing diff --git a/src/Text/Parsing.hs b/src/Text/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsing.hs @@ -0,0 +1,448 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A simplified interface to the UU.Parsing and UU.Scanner libraries. This module +-- provides some additional functionality to determine valid sub-expressions. +-- +----------------------------------------------------------------------------- +module Text.Parsing + ( -- * Scaning + Scanner(..), defaultScanner, makeCharsSpecial, newlinesAsSpecial, minusAsSpecial, scan, scanWith, UU.Token + -- * Parsing + , Parser, CharParser, TokenParser, parse, Message + -- * UU parser combinators + , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1 + , pChainl, pChainr, pChoice, pFail + -- * Subexpressions + , Ranged, Range(..), Pos(..), toRanged, fromRanged, subExpressionAt + , pKey, pSpec, pVarid, pConid, unaryOp, binaryOp, pParens, indicesToRange + , pInteger, pFraction, pString, pBracks, pCurly, pCommas, pLines + -- * Operator table (parser) + , OperatorTable, Associativity(..), pOperators + -- * Analyzing parentheses + , SyntaxError(..), fromMessage, errorToPositions + , checkParentheses, showTokenPos, tokenNoPosition + , toPosition, tokenText + ) where + +import qualified UU.Parsing as UU +import qualified UU.Scanner as UU +import qualified UU.Scanner.GenToken as UU +import Control.Arrow +import Common.Utils +import Data.Char +import Data.List +import Data.Maybe + +---------------------------------------------------------- +-- Scaning + +-- | Data type to configure a scanner +data Scanner = Scanner + { fileName :: Maybe String + , keywords :: [String] + , keywordOperators :: [String] + , specialCharacters :: String + , operatorCharacters :: String + } + +-- | A default scanner configuration (using Haskell's special characters) +defaultScanner :: Scanner +defaultScanner = Scanner + { fileName = Nothing + , keywords = [] + , keywordOperators = [] + , specialCharacters = "(),;[]`{}" -- Haskell's special characters + , operatorCharacters = "!#$%&*+./<=>?@\\^|-~" -- The non-special characters + } + +-- | Add characters to the list of special characters (and remove these from the list of operator characters) +makeCharsSpecial :: String -> Scanner -> Scanner +makeCharsSpecial cs scanner = scanner + { specialCharacters = specialCharacters scanner `union` cs + , operatorCharacters = operatorCharacters scanner \\ cs + } + +-- Newline characters are mapped to "special" tokens +-- The current solution to deal with newlines is a hack: all characters '\n' in the input +-- are first mapped to '\001', and later the tokens are adapted +newlinesAsSpecial :: Scanner -> Scanner +newlinesAsSpecial = makeCharsSpecial [specialNewlinesChar] + +specialNewlinesChar :: Char +specialNewlinesChar = chr 1 + +-- Minus characters are mapped to "special" tokens +-- The current solution to deal with minus is a hack: all characters '-' in the input +-- are first mapped to '\002', and later the tokens are adapted +-- (since the scanner considers -- to be comment) +minusAsSpecial :: Scanner -> Scanner +minusAsSpecial = makeCharsSpecial [specialMinusChar] + +specialMinusChar :: Char +specialMinusChar = chr 2 + +-- | Scan an input string with the default scanner configuration +scan :: String -> [UU.Token] +scan = scanWith defaultScanner + +-- | Scan an input string with the given scanner configuration +scanWith :: Scanner -> String -> [UU.Token] +scanWith scanner = post . uuScan . pre + where + -- very special characters + special = or [specialNewlines, specialMinus] + specialNewlines = specialNewlinesChar `elem` specialCharacters scanner + specialMinus = specialMinusChar `elem` specialCharacters scanner + + pre = if special then map changeChar else id + post = if special then map changeToken else id + pos = UU.initPos $ fromMaybe "" (fileName scanner) + uuScan = UU.scan (keywords scanner) (keywordOperators scanner) + (specialCharacters scanner) (operatorCharacters scanner) pos + + changeChar :: Char -> Char + changeChar c + | c == '\n' && specialNewlines = specialNewlinesChar + | c == '-' && specialMinus = specialMinusChar + | otherwise = c + + changeToken :: UU.Token -> UU.Token + changeToken t = + case t of + UU.Reserved [c] pos + | c == specialNewlinesChar && specialNewlines -> UU.Reserved "\n" pos + | c == specialMinusChar && specialMinus -> UU.Reserved "-" pos + _ -> t + +---------------------------------------------------------- +-- Parsing + +-- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is +-- the result type. This data type is an instance of the @IsParser@ type class +-- defined in the UU libraries. +newtype Parser s a = P { unP :: UU.AnaParser [s] UU.Pair s (Maybe s) a } + +-- | A parser with characters as symbol type +type CharParser = Parser Char + +-- | A parser with tokens as symbol type +type TokenParser = Parser UU.Token + +instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where + ~(P p) <*> ~(P q) = P (p UU.<*> q) + ~(P p) <* ~(P q) = P (p UU.<* q) + ~(P p) *> ~(P q) = P (p UU.*> q) + ~(P p) <|> ~(P q) = P (p UU.<|> q) + a <$> ~(P p) = P (a UU.<$> p) + a <$ ~(P p) = P (a UU.<$ p) + pSucceed = P . UU.pSucceed + pFail = P UU.pFail + pLow = P . UU.pLow + pSym = P . UU.pSym + pRange a = P . UU.pRange a + pCostRange a b = P . UU.pCostRange a b + pCostSym a b = P . UU.pCostSym a b + getfirsts = UU.getfirsts . unP + setfirsts e = P . UU.setfirsts e . unP + getzerop = fmap P . UU.getzerop . unP + getonep = fmap P . UU.getonep . unP + +type Message s = (UU.Expecting s, Maybe s) + +-- Parsing an input string always returns a result and a list of error messages +parse :: UU.Symbol s => Parser s a -> [s] -> (a, [Message s]) +parse (P p) input = (result, map f messages) + where + steps = UU.parse p input + result = fstPair (UU.evalSteps steps) + messages = UU.getMsgs steps + fstPair (UU.Pair a _) = a + f (UU.Msg a b _) = (a, b) + +---------------------------------------------------------- +-- UU parser combinators + +infixl 3 <|> +infixl 4 <$>, <$, <*>, <*, *> + +(<$>) :: (Ord s, UU.Symbol s) => (a -> b) -> Parser s a -> Parser s b +(<$>) = (UU.<$>) + +(<$) :: (Ord s, UU.Symbol s) => a -> Parser s b -> Parser s a +(<$) = (UU.<$) + +(<*>) :: (Ord s, UU.Symbol s) => Parser s (a -> b) -> Parser s a -> Parser s b +(<*>) = (UU.<*>) + +(*>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s b +(*>) = (UU.*>) + +(<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a +(<*) a = (UU.<*) a + +(<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a +(<|>) a = (UU.<|>) a + +optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a +optional = UU.opt + +pList, pList1 :: (Ord s, UU.Symbol s) => Parser s a -> Parser s [a] +pList = UU.pList +pList1 = UU.pList1 + +pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a +pChainl = UU.pChainl +pChainr = UU.pChainr + +pChoice :: (Ord s, UU.Symbol s) => [Parser s a] -> Parser s a +pChoice = foldr (<|>) UU.pFail + +pFail :: (Ord s, UU.Symbol s) => Parser s a +pFail = UU.pFail + +---------------------------------------------------------- +-- Subexpressions + +-- | Abstract data type for expressions that ''know'' about the ranges of their +-- subexpressions +data Ranged a = Ranged + { fromRanged :: a -- ^ Forget about the subexpressions + , getRange :: Range + , special :: Bool + , children :: [Ranged a] + } + +instance Show a => Show (Ranged a) where + show = show . fromRanged + +-- | Data type for ranges +data Range = Range + { beginPos :: Pos + , endPos :: Pos + } + deriving (Show, Eq, Ord) + +-- | Data type for positions +data Pos = Pos + { line :: Int + , column :: Int + } + deriving (Show, Eq, Ord) + +-- | A value without subexpressions +toRanged :: a -> Range -> Ranged a +toRanged a r = Ranged a r False [] + +-- | Given a selection (range) and a ranged term, return the location of the selected +-- subexpression (or Nothing to indicate that the selection is invalid) +subExpressionAt :: Range -> Ranged a -> Maybe [Int] +subExpressionAt r ra + | r == getRange ra = return [] + | otherwise = + let f i | special ra = id + | otherwise = (i:) + in safeHead $ catMaybes + [ fmap (f i) (subExpressionAt r c) | (i, c) <- zip [0..] (children ra) ] + +pKey :: String -> TokenParser Range +pKey s = toRange 1 <$> UU.pKeyPos s + +pSpec :: Char -> TokenParser Range +pSpec c = toRange 1 <$> UU.pSpecPos c + +pVarid, pConid :: TokenParser (String, Range) +pVarid = second (toRange 1) <$> UU.pVaridPos +pConid = second (toRange 1) <$> UU.pConidPos + +unaryOp :: (a -> a) -> Range -> Ranged a -> Ranged a +unaryOp f r1 r2 = Ranged (f $ fromRanged r2) (r1 & getRange r2) False [r2] + +binaryOp :: (a -> a -> a) -> Ranged a -> Ranged a -> Ranged a +binaryOp f r1 r2 = Ranged (f (fromRanged r1) (fromRanged r2)) (getRange r1 & getRange r2) False [r1, r2] + +pParens :: TokenParser (Ranged a) -> TokenParser (Ranged a) +pParens p = (\p1 r p2 -> Ranged (fromRanged r) (toRange 1 p1 & toRange 1 p2) True [r]) <$> UU.pOParenPos <*> p <*> UU.pCParenPos + +-- TODO: fix inconsistency with pParens +pBracks :: TokenParser a -> TokenParser a +pBracks = UU.pBracks + +-- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should +-- be accepted or not. Make sure to configure the scanner to treat newlines as special characters! +pLines :: Bool -> TokenParser a -> TokenParser [a] +pLines allowEmptyLine p = catMaybes <$> pn + where + pOne | allowEmptyLine = optional (Just <$> p) Nothing + | otherwise = Just <$> p + pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne) + +-- TODO: fix inconsistency with pParens +pCurly :: TokenParser a -> TokenParser a +pCurly = UU.pCurly + +pInteger :: TokenParser Integer +pInteger = (maybe 0 fromIntegral . readInt) <$> UU.pInteger + +pFraction :: TokenParser Float +pFraction = read <$> UU.pFraction + +pString :: TokenParser String +pString = UU.pString + +pCommas :: TokenParser a -> TokenParser [a] +pCommas = UU.pCommas + +-- | Helper function to translate two indices on a string to a range: the positions of a range are line-based +indicesToRange :: String -> Int -> Int -> Range +indicesToRange s i j = Range (indexToPos s a) (indexToPos s b) + where (a, b) = trimIndexPair s i j + +-- local helper functions +(&) :: Range -> Range -> Range +Range p1 p2 & Range p3 p4 = Range (p1 `min` p3) (p2 `max` p4) + +toPos :: UU.Pos -> Pos +toPos p = Pos (UU.line p) (UU.column p) + +toRange :: Int -> UU.Pos -> Range +toRange n p = Range (toPos p) (toPos (UU.advc n p)) + +indexToPos :: String -> Int -> Pos +indexToPos = rec . zip [1..] . lines + where + rec [] _ = Pos 0 0 + rec ((lnr, x):rest) i + | i <= len = Pos lnr (i+1) + | otherwise = rec rest (i-len-1) + where + len = length x + +trimIndexPair :: String -> Int -> Int -> (Int, Int) +trimIndexPair s i j + | j < i = trimIndexPair s j i + | otherwise = (i + f sub, j - f (reverse sub)) + where + sub = take (j-i) (drop i s) + f = length . takeWhile isSpace + +---------------------------------------------------------- +-- Operator table (parser) + +-- | Type for an operator table. Operators with a low priority should appear in the front of the list. +type OperatorTable a = [(Associativity, [(String, a -> a -> a)])] + +-- | Data type to express the kind of associativity. The NoMix constructor expresses that the operators +-- in the list should not be mixed, but require extra parentheses in the input +data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix + +-- | Construct a parser using an operator table +pOperators :: OperatorTable a -> TokenParser (Ranged a) -> TokenParser (Ranged a) +pOperators table p = foldr op p table + where op (a, ops) q = + case a of + -- The NoMix variant is actually hard to define efficiently. Since we should not mix operators + -- that have the same priority, we have to inspect which operator we are dealing with before + -- we can use the chain combinator. + NoMix -> let make op = flip <$> f op <*> pChainr (f op) q + in flip ($) <$> q <*> optional (pChoice $ map make ops) id + _ -> pChain a (pChoice $ map f ops) q + f (s, g) = binaryOp g <$ pKey s + + +-- local helper function +pChain :: (Ord s, UU.Symbol s) => Associativity -> Parser s (a -> a -> a) -> Parser s a -> Parser s a +pChain a p q = case a of + LeftAssociative -> pChainl p q + RightAssociative -> pChainr p q + NonAssociative -> flip ($) <$> q <*> p <*> q + NoMix -> pChainr p q + +----------------------------------------------------------- +--- Syntax errors + +data SyntaxError + = Unexpected UU.Token + | ParNotClosed UU.Token + | ParNoOpen UU.Token + | ParMismatch UU.Token UU.Token + | ErrorMessage String + +instance Show SyntaxError where + show err = + case err of + Unexpected t -> "Unexpected " ++ show (tokenNoPosition t) + ParNotClosed t -> "Opening parenthesis " ++ show (tokenNoPosition t) ++ " is not closed" + ParNoOpen t -> "Closing parenthesis " ++ show (tokenNoPosition t) ++ " has no matching symbol" + ParMismatch t1 t2 -> "Opening parenthesis " ++ show (tokenNoPosition t1) ++ " is closed with " ++ show (tokenNoPosition t2) + ErrorMessage msg -> msg + +fromMessage :: Message UU.Token -> SyntaxError +fromMessage (_, Just t) = Unexpected t +fromMessage _ = ErrorMessage "Syntax error" + +errorToPositions :: SyntaxError -> [(Int, Int)] +errorToPositions err = + case err of + Unexpected t -> [toPosition t] + ParNotClosed t -> [toPosition t] + ParNoOpen t -> [toPosition t] + ParMismatch t1 t2 -> [toPosition t1, toPosition t2] + ErrorMessage _ -> [] + +----------------------------------------------------------- +--- Analyzing parentheses + +tokenText :: UU.Token -> String +tokenText (UU.Reserved s _) = "symbol " ++ s +tokenText (UU.ValToken s v _) = show s ++ " " ++ v + +showTokenPos :: UU.Token -> String +showTokenPos (UU.Reserved _ p) = showPosition p +showTokenPos (UU.ValToken _ _ p) = showPosition p + +toPosition :: UU.Token -> (Int, Int) +toPosition (UU.Reserved _ p) = (UU.line p, UU.column p) +toPosition (UU.ValToken _ _ p) = (UU.line p, UU.column p) + +showPosition :: UU.Position a => a -> String +showPosition p = show (UU.line p, UU.column p) + +tokenNoPosition :: UU.Token -> UU.Token +tokenNoPosition (UU.Reserved a _) = UU.Reserved a UU.noPos +tokenNoPosition (UU.ValToken a b _) = UU.ValToken a b UU.noPos + +checkParentheses :: [UU.Token] -> Maybe SyntaxError +checkParentheses = rec [] + where + rec [] [] = Nothing + rec (t:_) [] = Just (ParNotClosed t) + rec stack (t:ts) + | isOpening t = + rec (t:stack) ts + | isClosing t = + case stack of + [] -> Just (ParNoOpen t) + x:xs + | match x t -> rec xs ts + | otherwise -> Just (ParMismatch x t) + | otherwise = + rec stack ts + +isOpening, isClosing :: UU.Token -> Bool +isOpening (UU.Reserved ("(") _) = True +isOpening _ = False +isClosing (UU.Reserved (")") _) = True +isClosing _ = False + +match :: UU.Token -> UU.Token -> Bool +match (UU.Reserved ("(") _) (UU.Reserved (")") _) = True +match _ _ = False diff --git a/src/Text/UTF8.hs b/src/Text/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/Text/UTF8.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for the UTF8 encoding +-- +----------------------------------------------------------------------------- +module Text.UTF8 + ( encode, encodeM, decode, decodeM + , isUTF8, allBytes, testEncoding + ) where + +import Data.Char +import Data.Maybe +import Control.Monad.Error +import Test.QuickCheck + +------------------------------------------------------------------ +-- Interface + +-- | Encode a string to UTF8 format +encode :: String -> String +encode = either error id . encodeM + +-- | Decode an UTF8 format string to unicode points +decode :: String -> String +decode = either error id . decodeM + +-- | Encode a string to UTF8 format (monadic) +encodeM :: Monad m => String -> m String +encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord) + +-- | Decode an UTF8 format string to unicode points (monadic) +decodeM :: Monad m => String -> m String +decodeM = liftM (map chr) . fromUTF8 . map ord + +-- | Test whether the argument is a proper UTF8 string +isUTF8 :: String -> Bool +isUTF8 = isJust . decodeM + +-- | Test whether all characters are in the range 0-255 +allBytes :: String -> Bool +allBytes = all ((`between` (0, 255)) . ord) + +------------------------------------------------------------------ +-- Helper functions + +toUTF8 :: Monad m => Int -> m [Int] +toUTF8 n + | n < 128 = -- one byte + return [n] + | n < 2048 = -- two bytes + let (a, d) = n `divMod` 64 + in return [a+192, d+128] + | n < 65536 = -- three bytes + let (a, d1) = n `divMod` 4096 + (b, d2) = d1 `divMod` 64 + in return [a+224, b+128, d2+128] + | n < 1114112 = -- four bytes + let (a, d1) = n `divMod` 262144 + (b, d2) = d1 `divMod` 4096 + (c, d3) = d2 `divMod` 64 + in return [a+240, b+128, c+128, d3+128] + | otherwise = + fail "invalid character in UTF8" + +fromUTF8 :: Monad m => [Int] -> m [Int] +fromUTF8 xs + | null xs = return [] + | otherwise = do + (i, rest) <- f xs + is <- fromUTF8 rest + return (i:is) + where + f (a:rest) | a < 128 = -- one byte + return (a, rest) + f (a:b:rest) | a `between` (192, 223) = do -- two bytes + unless (isHigh b) $ + fail "invalid UTF8 character (two bytes)" + return ((a-192)*64 + b-128, rest) + f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes + unless (isHigh b && isHigh c) $ + fail "invalid UTF8 character (three bytes)" + return ((a-224)*4096 + (b-128)*64 + c-128, rest) + f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes + let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128 + unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $ + fail "invalid UTF8 character (four bytes)" + return (value, rest) + f _ = fail "invalid character in UTF8" + +isHigh :: Int -> Bool +isHigh i = i `between` (128, 191) + +between :: Ord a => a -> (a, a) -> Bool +between a (low, high) = low <= a && a <= high + +------------------------------------------------------------------ +-- Test encoding + +-- | QuickCheck internal encoding/decoding functions +testEncoding :: IO () +testEncoding = do + putStrLn "** UTF8 encoding" + quickCheck $ forAll (sized gen) valid + where + gen n = replicateM n someChar + someChar = liftM chr $ oneof + -- To get a nice distribution over the number of bytes used + -- in the encoding + [ choose (0, 127), choose (128, 2047) + , choose (2048, 65535), choose (65536, 1114111) + ] + +valid :: String -> Bool +valid xs = fromMaybe False $ + do us <- encodeM xs + bs <- decodeM us + return (xs == bs) diff --git a/src/Text/XML.hs b/src/Text/XML.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML.hs @@ -0,0 +1,178 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A datatype, parser, and pretty printer for XML documents. Re-exports +-- functions defined elsewhere. +-- +----------------------------------------------------------------------------- +module Text.XML + ( XML, Attr, AttrList, InXML(..), Element(..) + , XMLBuilder, makeXML, text, element, tag, attribute + , parseXML, showXML, compactXML, (.=.), findAttribute + , children, Attribute(..), builder, findChild, getData {-, extract, extractText -} + , {- isText, isTag, mkTag mkText , findChild-} + ) where + +import Common.Utils (trim) +import Control.Monad.State +import Control.Monad.Error () +import Data.Char +import Data.List +import Data.Monoid +import Text.XML.Interface hiding (parseXML) +import qualified Text.XML.Interface as I + +---------------------------------------------------------------- +-- Datatype definitions + +-- two helper types for attributes +type XML = Element +type Attr = Attribute -- (String, String) +type AttrList = Attributes -- [Attr] + +class InXML a where + toXML :: a -> XML + listToXML :: [a] -> XML + fromXML :: Monad m => XML -> m a + listFromXML :: Monad m => XML -> m [a] + -- default definitions + listToXML = Element "list" [] . map (Right . toXML) + listFromXML xml + | name xml == "list" && noAttributes xml = mapM fromXML (children xml) + | otherwise = fail "expecting a list tag" + +---------------------------------------------------------------- +-- XML parser (a scanner and a XML tree constructor) + +parseXML :: String -> Either String XML +parseXML input = do + xml <- I.parseXML input + return (ignoreLayout xml) + +ignoreLayout :: XML -> XML +ignoreLayout (Element n as xs) = + let f = either (Left . trim) (Right . ignoreLayout) + in Element n as (map f xs) + +indentXML :: XML -> XML +indentXML = rec 0 + where + rec i (Element n as xs) = + let ipl = i+2 + cd n = Left ('\n' : replicate n ' ') + f = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)]) + body | null xs = xs + | otherwise = concatMap f xs ++ [cd i] + in Element n as body + +showXML :: XML -> String +showXML = (++"\n") . show . indentXML . ignoreLayout + +compactXML :: XML -> String +compactXML = show . ignoreLayout + +---------------------------------------------------------------- +-- Monadic XML builder + +-- Uses the fast-append trick on lists +data BuilderState = BS { bsAttributes :: AttrList -> AttrList, bsElements :: Content -> Content } + +-- local helper +emptyBS :: BuilderState +emptyBS = BS id id + +appendAttrBS :: Attr -> BuilderState -> BuilderState +appendAttrBS a bs = bs { bsAttributes = bsAttributes bs . (a:) } + +appendElemBS :: Either String Element -> BuilderState -> BuilderState +appendElemBS e bs = bs { bsElements = bsElements bs . (e:) } + +type XMLBuilder = XMLBuilderM () + +newtype XMLBuilderM a = XMLBuilder { unBuild :: State BuilderState a } + +instance Monoid a => Monoid (XMLBuilderM a) where + mempty = return mempty + mappend = (>>) + +instance Monad XMLBuilderM where + return = XMLBuilder . return + m >>= f = XMLBuilder (unBuild m >>= (unBuild . f)) + +makeXML :: String -> XMLBuilder -> XML +makeXML s m = + let bs = execState (unBuild m) emptyBS + in Element s (bsAttributes bs []) (bsElements bs []) + +text :: String -> XMLBuilder +text = XMLBuilder . modify . appendElemBS . Left + +element :: String -> XMLBuilder -> XMLBuilder +element s = XMLBuilder . modify . appendElemBS . Right . makeXML s + +tag :: String -> XMLBuilder +tag s = element s (return ()) + +attribute :: Attr -> XMLBuilder +attribute = XMLBuilder . modify . appendAttrBS + +(.=.) :: String -> String -> XMLBuilder +n .=. s = attribute (n := s) + +builder :: Element -> XMLBuilder +builder = XMLBuilder . modify . appendElemBS . Right + +---------------------------------------------------------------- +-- XML utility functions + +{- +children :: XML -> [XML] +children (Element _ _ xs) = xs + +extract :: Monad m => String -> XML -> m [XML] +extract n xml = + case filter (children xml) of -- [ xs | Tagged (Element m _ xs) <- children xml, n==m ] of + [hd] -> return hd + _ -> fail ("missing tag " ++ show n) + +extractText :: Monad m => String -> XML -> m String +extractText n xml = do + xs <- extract n xml + case xs of + [hd] -> maybe (fail "extract text") return (isText hd) + _ -> fail ("invalid content for tag " ++ show n) + +isTag :: XML -> Maybe (String, AttrList, [XML]) +isTag = +isTag (Tagged (Element n as xs)) = + let f (x := y) = (x, concatMap (either return g) y) + g (CharRef n) = [chr n] + g (EntityRef n) + | otherwise = [] + in Just (n, map f as, xs) +isTag _ = Nothing + +mkTag :: String -> AttrList -> Content -> XML +mkTag n as = Element n (map f as) + where + f (x, y) = x := y + +mkText :: String -> XML +mkText = -- CharData + +isText :: XML -> Maybe String +isText = +isText (CharData s) = Just s +isText (CDATA s) = Just s +isText _ = Nothing + +findChild :: Monad m => String -> XML -> m XML +findChild s e = maybe (fail "child not found") return . safeHead $ + [ c | c <- children e, Just (n, _, _) <- [isTag c], s==n ]-} diff --git a/src/Text/XML/Document.hs b/src/Text/XML/Document.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Document.hs @@ -0,0 +1,256 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Datatype for representing XML documents +-- +----------------------------------------------------------------------------- +module Text.XML.Document where + +import Data.Char +import Data.List +import Data.Maybe + +type Name = String + +type Attributes = [Attribute] +data Attribute = Name := AttValue deriving Eq + +data Reference = CharRef Int | EntityRef String + deriving Eq + +data Parameter = Parameter String + deriving Eq + +data XMLDoc = XMLDoc + { versionInfo :: Maybe String + , encoding :: Maybe String + , standalone :: Maybe Bool + , dtd :: Maybe DTD + , externals :: [(String, External)] + , root :: Element + } + deriving Eq + +data XML = Tagged Element + | CharData String + | CDATA String + | Reference Reference + deriving Eq + +data Element = Element + { name :: Name + , attributes :: Attributes + , content :: Content + } + deriving Eq + +type Content = [XML] + +data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl] + deriving Eq + +data DocTypeDecl = ElementDecl Name ContentSpec + | AttListDecl Name [AttDef] + | EntityDecl Bool Name EntityDef + | NotationDecl Name (Either ExternalID PublicID) + | DTDParameter Parameter + | DTDConditional Conditional + deriving Eq + +data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP + deriving Eq + +-- content particles +data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name + deriving Eq + +data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType + | StringType | EnumerationType [String] | NotationType [String] + deriving Eq + +data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue + deriving Eq + +type AttDef = (Name, AttType, DefaultDecl) +type EntityDef = Either EntityValue (ExternalID, Maybe String) +type AttValue = [Either Char Reference] +type EntityValue = [Either Char (Either Parameter Reference)] + +data ExternalID = System String | Public String String + deriving Eq + +type PublicID = String + +data Conditional = Include [DocTypeDecl] | Ignore [String] + deriving Eq + +type TextDecl = (Maybe String, String) + +type External = (Maybe TextDecl, Content) + +--- + +instance Show XMLDoc where + show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc) + +instance Show Attribute where + show (n := v) = n ++ "=" ++ showAttValue v + +instance Show Element where + show (Element n as c) + | null c = showOpenTag True n as + | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n + +instance Show XML where + show xml = + case xml of + Tagged e -> show e + CharData s -> s + CDATA s -> "" + Reference r -> show r + +instance Show Reference where + show ref = + case ref of + CharRef n -> "&#" ++ show n ++ ";" + EntityRef s -> "&" ++ s ++ ";" + +instance Show Parameter where + show (Parameter s) = "%" ++ s ++ ";" + +instance Show DTD where + show (DTD n mid ds) = "" + where + list = n : catMaybes [fmap show mid, showDecls ds] + showDecls xs + | null xs = Nothing + | otherwise = Just $ "[" ++ concatMap show xs ++ "]" + +instance Show ExternalID where + show extID = + case extID of + System s -> "SYSTEM " ++ doubleQuote s + Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s] + +instance Show DocTypeDecl where + show decl = + case decl of + ElementDecl n c -> "" + AttListDecl n as -> "" + EntityDecl b n e -> + let xs = ["%" | not b] ++ [n, showEntityDef e] + in "" + NotationDecl n e -> + let f s = "PUBLIC " ++ doubleQuote s + in "" + DTDParameter r -> show r + DTDConditional c -> show c + +instance Show ContentSpec where + show cspec = + case cspec of + Empty -> "EMPTY" + Any -> "ANY" + Mixed b ns -> + let txt = concat (intersperse "|" ("#PCDATA":ns)) + in parenthesize txt ++ (if b then "*" else "") + Children cp -> show cp + +instance Show CP where + show cp = + case cp of + Choice xs -> parenthesize (concat (intersperse "|" (map show xs))) + Sequence xs -> parenthesize (concat (intersperse "," (map show xs))) + QuestionMark c -> show c ++ "?" + Star c -> show c ++ "*" + Plus c -> show c ++ "+" + CPName n -> n + +instance Show AttType where + show attType = + case attType of + IdType -> "ID" + IdRefType -> "IDREF" + IdRefsType -> "IDREFS" + EntityType -> "ENTITY" + EntitiesType -> "ENTITIES" + NmTokenType -> "NMTOKEN" + NmTokensType -> "NMTOKENS" + StringType -> "CDATA" + EnumerationType xs -> parenthesize (concat (intersperse "|" xs)) + NotationType xs -> "NOTATION " ++ parenthesize (concat (intersperse "|" xs)) + +instance Show DefaultDecl where + show defaultDecl = + case defaultDecl of + Required -> "#REQUIRED" + Implied -> "#IMPLIED" + Value v -> showAttValue v + Fixed v -> "#FIXED " ++ showAttValue v + +instance Show Conditional where + show conditional = + case conditional of + Include xs -> "" + Ignore _ -> "" -- ToDO undefined -- [String] + +showXMLDecl :: XMLDoc -> String +showXMLDecl doc + | isJust (versionInfo doc) = "" + | otherwise = "" + where + s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc) + s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc) + s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc) + +showOpenTag :: Bool -> Name -> Attributes -> String +showOpenTag close n as = "<" ++ unwords (n:map show as) ++ + (if close then "/>" else ">") + +showCloseTag :: Name -> String +showCloseTag n = "" + +showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped) +showAttValue = doubleQuote . concatMap (either f show) + where + f '"' = [] + f c = [c] + +showEntityValue :: EntityValue -> String +showEntityValue = doubleQuote . concatMap (either f (either show show)) + where + f '"' = [] + f c = [c] + +showAttDef :: AttDef -> String +showAttDef (s, tp, dd) = unwords [s, show tp, show dd] + +showEntityDef :: EntityDef -> String +showEntityDef entityDef = + case entityDef of + Left ev -> showEntityValue ev + Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms + +doubleQuote :: String -> String +doubleQuote s = "\"" ++ s ++ "\"" + +parenthesize :: String -> String +parenthesize s = "(" ++ s ++ ")" + +--------------------------------------------------- + +type M = [Either String Element] + +refToString :: Reference -> String +refToString (CharRef c) = [chr c] +refToString (EntityRef _) = undefined + +attribute_ :: AttValue -> String +attribute_ = concatMap (either return refToString) diff --git a/src/Text/XML/Interface.hs b/src/Text/XML/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Interface.hs @@ -0,0 +1,182 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Collection of common operation on XML documents +-- +----------------------------------------------------------------------------- +module Text.XML.Interface where + +import Text.XML.Document (Name) +import Text.XML.Unicode (decoding) +import Text.XML.Parser (document, extParsedEnt) +import Text.XML.ParseLib (parse) +import Control.Monad.Error () +import qualified Text.XML.Document as D +import System.FilePath (takeDirectory, pathSeparator) +import Data.Char (chr) + +data Element = Element + { name :: Name + , attributes :: Attributes + , content :: Content + } + +instance Show Element where + show = show . extend + +type Content = [Either String Element] + +type Attributes = [Attribute] +data Attribute = Name := String + +normalize :: D.XMLDoc -> Element +normalize doc = toElement (D.root doc) + where + toElement :: D.Element -> Element + toElement (D.Element n as c) = + Element n (map toAttribute as) (toContent c) + + toAttribute :: D.Attribute -> Attribute + toAttribute (n D.:= v) = + n := concatMap (either return refToString) v + + toContent :: D.Content -> Content + toContent = merge . concatMap f + where + f :: D.XML -> Content + f (D.Tagged e) = [Right (toElement e)] + f (D.CharData s) = [Left s] + f (D.CDATA s) = [Left s] + f (D.Reference r) = refToContent r + + refToString :: D.Reference -> String + refToString (D.CharRef i) = [chr i] + refToString (D.EntityRef _) = "" -- error + + refToContent :: D.Reference -> Content + refToContent (D.CharRef i) = [Left [chr i]] + refToContent (D.EntityRef s) = + case lookup s entities of + Just c -> c + Nothing -> [] -- error + + entities :: [(String, Content)] + entities = + [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] + + merge :: Content -> Content + merge (Left s:Left t:rest) = Left (s++t) : merge rest + merge (x:xs) = x:merge xs + merge [] = [] + +extend :: Element -> D.XMLDoc +extend e = D.XMLDoc + { D.versionInfo = Nothing + , D.encoding = Nothing + , D.standalone = Nothing + , D.dtd = Nothing + , D.externals = [] + , D.root = toElement e + } + where + toElement :: Element -> D.Element + toElement (Element n as c) = + D.Element n (map toAttribute as) (map toXML c) + + toAttribute :: Attribute -> D.Attribute + toAttribute (n := s) = (D.:=) n (map Left s) + + toXML :: Either String Element -> D.XML + toXML = either D.CharData (D.Tagged . toElement) + +----------------------------------------------------- + +parseXML :: String -> Either String Element +parseXML xs = do + input <- decoding xs + doc <- parse document input + return (normalize doc) + +parseIO :: String -> IO Element +parseIO baseFile = do + -- putStrLn $ "Reading " ++ show baseFile + xs <- readFile baseFile + input <- decoding xs + case parse document input of + Left err -> fail err + Right doc -> do + let exts = getExternals doc + rs <- mapM (parseExternal . snd) exts + let new = doc { D.externals = zip (map fst exts) rs } + return (normalize new) + + where + getExternals :: D.XMLDoc -> [(String, String)] + getExternals doc = + case D.dtd doc of + Just (D.DTD _ _ decls) -> + [ (n, s) | D.EntityDecl True n (Right (D.System s, Nothing)) <- decls ] + Nothing -> [] + + parseExternal :: String -> IO D.External + parseExternal extFile = do + let full = takeDirectory baseFile ++ [pathSeparator] ++ extFile + -- putStrLn $ "Reading " ++ show full + xs <- readFile full + input <- decoding xs + case parse extParsedEnt input of + Right doc -> return doc + Left err -> fail err + +----------------------------------------------------- + +noAttributes :: Element -> Bool +noAttributes = null . attributes + +findAttribute :: Monad m => String -> Element -> m String +findAttribute s (Element _ as _) = + case [ t | n := t <- as, s==n ] of + [hd] -> return hd + _ -> fail $ "Invalid attribute: " ++ show s + +findChild :: Monad m => String -> Element -> m Element +findChild s e = + case filter ((==s) . name) (children e) of + [a] -> return a + _ -> fail $ "Child not found: " ++ show s + +children :: Element -> [Element] +children e = [ c | Right c <- content e ] + +getData :: Element -> String +getData e = concat [ s | Left s <- content e ] + +{- +children :: D.Element -> [D.Element] +children (D.Element _ _ c) = [ e | D.Tagged e <- c ] + +getAttributes :: D.Element -> [(String, String)] +getAttributes (D.Element _ as _) = + [ (n, concatMap f av) | n D.:= av <- as ] + where + f :: Either Char D.Reference -> String + f (Left c) = [c] + f (Right (D.CharRef n)) = [chr $ fromIntegral n] + f (Right (D.EntityRef _)) = [] + +findAttribute :: Monad m => String -> D.Element -> m String +findAttribute n e = + case lookup n (getAttributes e) of + Just a -> return a + Nothing -> fail $ "Attribute not found: " ++ show n + +getData :: D.Element -> String +getData (D.Element _ _ c) = concat [ s | D.CharData s <- c ] +-} diff --git a/src/Text/XML/ParseLib.hs b/src/Text/XML/ParseLib.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/ParseLib.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- An interface to a parsing library. The Parsec library is used because +-- we need the back-tracking facilities (try combinator) in order not to +-- have to rewrite the complete grammar for XML. In addition, the stopOn +-- combinator is hard (or impossible?) to write using the UU library. This +-- abstraction should make it easier to switch to a different parsing library +-- in future, in case we want to. +-- +----------------------------------------------------------------------------- +module Text.XML.ParseLib + ( Parser, (<|>), (<..>) + , symbol, string, optionM, option, oneOf, ranges, many, doubleQuoted, bracketed + , singleQuoted, stopOn, parenthesized, choice, many1, try + , noneOf, chainr1, sepBy1, parse, accept, packed, recognize + ) where + +import qualified Text.ParserCombinators.Parsec as P + +infix 6 <..> +infixr 4 <|> + +type Parser a = P.CharParser () a + +parse :: Parser a -> String -> Either String a +parse p = either (Left . show) Right . P.parse (p >>= \a -> P.eof >> return a) "" + +accept :: Parser a -> String -> Bool +accept p = either (const False) (const True) . parse p + +try :: Parser a -> Parser a +try = P.try + +noneOf :: String -> Parser Char +noneOf = P.noneOf + +(<|>) :: Parser a -> Parser a -> Parser a +(<|>) = (P.<|>) + +(<..>) :: Char -> Char -> Parser Char +x <..> y = P.satisfy (\c -> c >= x && c <= y) + +recognize :: Parser a -> Parser () +recognize p = p >> return () + +stopOn :: [String] -> Parser String +stopOn list = many (try (noneOf hds <|> foldr1 (<|>) ps)) + where + (hds, ps) = unzip [ (x, make x xs) | x:xs <- list ] + make x xs + | null xs = fail "make" + | otherwise = do + symbol x + P.notFollowedBy (P.try (string xs >> return ' ')) + return x + +symbol :: Char -> Parser Char +symbol = P.char + +string :: String -> Parser String +string = P.string + +ranges :: [(Char, Char)] -> Parser Char +ranges xs = P.choice [ a <..> b | (a, b) <- xs ] + +oneOf :: String -> Parser Char +oneOf = P.oneOf + +many :: Parser a -> Parser [a] +many = P.many + +many1 :: Parser a -> Parser [a] +many1 = P.many1 + +sepBy1 :: Parser a -> Parser b -> Parser [a] +sepBy1 = P.sepBy1 + +chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a +chainr1 = P.chainr1 + +choice :: [Parser a] -> Parser a +choice = P.choice + +optionM :: Parser a -> Parser (Maybe a) +optionM = P.optionMaybe + +option :: a -> Parser a -> Parser a +option = P.option + +doubleQuoted :: Parser a -> Parser a +doubleQuoted p = packed (symbol '"') p (symbol '"') + +singleQuoted :: Parser a -> Parser a +singleQuoted p = packed (symbol '\'') p (symbol '\'') + +parenthesized :: Parser a -> Parser a +parenthesized p = packed (symbol '(') p (symbol ')') + +bracketed :: Parser a -> Parser a +bracketed p = packed (symbol '[') p (symbol ']') + +packed :: Parser a -> Parser b -> Parser c -> Parser b +packed l p r = l >> p >>= \a -> r >> return a diff --git a/src/Text/XML/Parser.hs b/src/Text/XML/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Parser.hs @@ -0,0 +1,683 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A parser for XML documents, directly derived from the specification: + +-- http://www.w3.org/TR/2006/REC-xml-20060816 + +----------------------------------------------------------------------------- + +module Text.XML.Parser where + +import Prelude hiding (seq) +import Control.Monad +import Data.Char (toUpper, ord, isSpace) +import Data.List (foldl') -- ' +import Data.Maybe (catMaybes) +import Text.XML.Unicode +import Text.XML.Document hiding (versionInfo, name, content) +import qualified Text.XML.Document as D +import Text.XML.ParseLib + +letter, digit, combiningChar, extender :: Parser Char +letter = ranges letterMap +digit = ranges digitMap +combiningChar = ranges combiningCharMap +extender = ranges extenderMap + +-------------------------------------------------- +-- * 2 Documents + +-------------------------------------------------- +-- ** 2.1 Well-Formed XML Documents + +-- [1] document ::= prolog element Misc* +document :: Parser XMLDoc +document = do + (mxml, dtd) <- prolog + rt <- element + miscs + let (ver, enc, sa) = + case mxml of + Just (a, b, c) -> (Just a, b, c) + Nothing -> (Nothing, Nothing, Nothing) + return $ XMLDoc + { D.versionInfo = ver + , D.encoding = enc + , D.standalone = sa + , D.dtd = dtd + , D.externals = [] + , root = rt + } + +-------------------------------------------------- +-- ** 2.2 Characters + +-- [2] Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] +char :: Parser Char +char = ranges xs <|> oneOf "\x9\xA\xD" + where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')] + +-------------------------------------------------- +-- ** 2.3 Common Syntactic Constructs + +-- [3] S ::= (#x20 | #x9 | #xD | #xA)+ +space :: Parser String +space = many1 (oneOf "\x20\x9\xA\xD") + +mspace :: Parser String -- for S? +mspace = many (oneOf "\x20\x9\xA\xD") + +-- [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender +nameChar :: Parser Char +nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:" + +-- [5] Name ::= (Letter | '_' | ':') (NameChar)* +name :: Parser String +name = do + c <- letter <|> oneOf "_:" + cs <- many nameChar + return (c:cs) + +-- [6] Names ::= Name (#x20 Name)* +names :: Parser [String] +names = sepBy1 name (symbol '\x20') + +-- [7] Nmtoken ::= (NameChar)+ +nmtoken :: Parser String +nmtoken = many1 nameChar + +-- [8] Nmtokens ::= Nmtoken (#x20 Nmtoken)* +nmtokens :: Parser [String] +nmtokens = sepBy1 nmtoken (symbol '\x20') + +-- [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"' +-- | "'" ([^%&'] | PEReference | Reference)* "'" +entityValue :: Parser EntityValue +entityValue = doubleQuoted (p "%&\"") <|> singleQuoted (p "%&'") + where + p s = many (fmap Left (noneOf s) + <|> fmap Right (fmap Left peReference <|> fmap Right reference)) + +-- [10] AttValue ::= '"' ([^<&"] | Reference)* '"' +-- | "'" ([^<&'] | Reference)* "'" +attValue :: Parser AttValue +attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'") + where p s = many (fmap Left (noneOf s) <|> fmap Right reference) + +-- [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") +systemLiteral :: Parser String +systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'") + where p s = many (noneOf s) + +-- [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" +pubidLiteral :: Parser String +pubidLiteral = doubleQuoted (many (pubidChar True)) <|> singleQuoted (many (pubidChar False)) + +-- [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%] +pubidChar :: Bool -> Parser Char +pubidChar withSingleQuote = + ranges xs <|> oneOf "\x20\xD\xA-()+,./:=?;!*#@$_%" <|> singleQuote + where + xs = [('a', 'z'), ('A', 'Z'), ('0', '9')] + singleQuote + | withSingleQuote = symbol '\'' + | otherwise = fail "pubidChar" + +-------------------------------------------------- +-- ** 2.4 Character Data and Markup + +-- [14] CharData ::= [^<&]* - ([^<&]* ']]>' [^<&]*) +charData :: Parser String -- This implementation is too liberal since it allows "]]>" +charData = stopOn ["<", "&", "]]>"] + + +-------------------------------------------------- +-- ** 2.5 Comments + +-- [15] Comment ::= '' +comment :: Parser String +comment = packed (string "") + +-------------------------------------------------- +-- ** 2.6 Processing Instructions + +-- [16] PI ::= '' Char*)))? '?>' +pInstr :: Parser String +pInstr = packed (string "") + where + p = do + piTarget + option "" (space >> stopOn ["?>"]) + +-- [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) +piTarget :: Parser String +piTarget = do + n <- name + when (map toUpper n == "XML") $ fail "XML in piTarget" + return n + +-------------------------------------------------- +-- ** 2.7 CDATA Sections + +-- [18] CDSect ::= CDStart CData CDEnd +-- [19] CDStart ::= '' Char*)) +-- [21] CDEnd ::= ']]>' +cdSect :: Parser XML +cdSect = packed (string "") + where + p = do + s <- stopOn ["]]>"] + return (CDATA s) + +-------------------------------------------------- +-- ** 2.8 Prolog and Document Type Declaration + +type XMLDecl = (String, Maybe String, Maybe Bool) + +-- [22] prolog ::= XMLDecl? Misc* (doctypedecl Misc*)? +prolog :: Parser (Maybe XMLDecl, Maybe DTD) +prolog = do + ma <- optionM (try xmlDecl) + miscs + mb <- optionM $ try $ do + mb <- doctypedecl + miscs + return mb + return (ma, mb) + +-- [23] XMLDecl ::= '' +xmlDecl :: Parser XMLDecl +xmlDecl = do + string "" + return (x, y, z) + +-- [24] VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') +versionInfo :: Parser String +versionInfo = space >> string "version" >> eq >> p + where p = singleQuoted versionNum <|> doubleQuoted versionNum + +-- [25] Eq ::= S? '=' S? +eq :: Parser () +eq = recognize (mspace >> symbol '=' >> mspace) + +-- [26] VersionNum ::= '1.0' +versionNum :: Parser String +versionNum = string "1.0" + +-- [27] Misc ::= Comment | PI | S +misc :: Parser () +misc = try (recognize comment) <|> try (recognize pInstr) <|> recognize space + +miscs :: Parser () +miscs = recognize (many misc) + +-- [28] doctypedecl ::= '' +doctypedecl :: Parser DTD +doctypedecl = do + string "> externalID)) + mspace + z <- option [] $ do + z <- bracketed intSubset + mspace + return z + symbol '>' + return (DTD x y z) + +-- [28a] DeclSep ::= PEReference | S +declSep :: Parser (Maybe DocTypeDecl) +declSep = fmap (Just . DTDParameter) peReference + <|> (space >> return Nothing) + +-- [28b] intSubset ::= (markupdecl | DeclSep)* +intSubset :: Parser [DocTypeDecl] +intSubset = fmap catMaybes (many (markupdecl <|> declSep)) + +-- [29] markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment +markupdecl :: Parser (Maybe DocTypeDecl) +markupdecl = fmap Just (choice (map try list)) + <|> ((try pInstr <|> comment) >> return Nothing) + where + list = [elementdecl, attlistDecl, entityDecl, notationDecl] + +-- [30] extSubset ::= TextDecl? extSubsetDecl +extSubset :: Parser (Maybe TextDecl, [DocTypeDecl]) +extSubset = do + m <- optionM textDecl + e <- extSubsetDecl + return (m, e) + +-- [31] extSubsetDecl ::= ( markupdecl | conditionalSect | DeclSep)* +extSubsetDecl :: Parser [DocTypeDecl] +extSubsetDecl = fmap catMaybes (many (choice [markupdecl, fmap (Just . DTDConditional) conditionalSect, declSep])) + +-------------------------------------------------- +-- ** 2.9 Standalone Document Declaration +-- [32] SDDecl ::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) +sdDecl :: Parser Bool +sdDecl = space >> string "standalone" >> eq >> (singleQuoted bool <|> doubleQuoted bool) + where bool = (string "yes" >> return True) + <|> (string "no" >> return False) + +-------------------------------------------------- +-- ** 2.10 White Space Handling + +-------------------------------------------------- +-- * 3 Logical Structures + +-- [39] element ::= EmptyElemTag | STag content ETag +element :: Parser Element +element = do + (s1, as, closed) <- sTag + if closed + then return (Element s1 as []) + else do + c <- content + s2 <- eTag + when (s1/=s2) $ fail "WFC: element" + return (Element s1 as c) + +-------------------------------------------------- +-- ** 3.1 Start-Tags, End-Tags, and Empty-Element Tags + +-- [40] STag ::= '<' Name (S Attribute)* S? '>' +-- [44] EmptyElemTag ::= '<' Name (S Attribute)* S? '/>' +-- The boolean indicates whether the tag was closed immediately (an EmptyElemTag) +sTag :: Parser (Name, Attributes, Bool) +sTag = do + symbol '<' + n <- name + as <- many (try (space >> attribute)) + mspace + b <- (symbol '>' >> return False) <|> + (string "/>" >> return True) + return (n, as, b) + +-- [41] Attribute ::= NSAttName Eq AttValue +-- | Name Eq AttValue +attribute :: Parser Attribute +attribute = do + n <- name + eq + a <- attValue + return (n := a) + +-- [42] ETag ::= '' +eTag :: Parser Name +eTag = do + string "' + return n + +-- [43] content ::= CharData? ((element | Reference | CDSect | PI | Comment) CharData?)* +-- Note: since CharData accepts epsilon, there is no need to make it optional +content :: Parser Content +content = chainr1 (fmap g charData) (fmap f ps) + where + f ma l r = l ++ maybe [] return ma ++ r + g s = [ CharData s | any (not . isSpace) s ] -- quick fix, ignores layout + ps = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect])) + <|> ((try pInstr <|> comment) >> return Nothing)) + +-------------------------------------------------- +-- ** 3.2 Element Type Declarations + +-- [45] elementdecl ::= '' +elementdecl :: Parser DocTypeDecl +elementdecl = do + string "' + return (ElementDecl n cs) + +-- [46] contentspec ::= 'EMPTY' | 'ANY' | Mixed | children +contentspec :: Parser ContentSpec +contentspec = choice + [ string "EMPTY" >> return Empty + , string "ANY" >> return Any + , try mixed + , children + ] + +-- [47] children ::= (choice | seq) ('?' | '*' | '+')? +children :: Parser ContentSpec +children = do + a <- try cpChoice <|> cpSeq + f <- option id multi + return (Children (f a)) + +multi :: Parser (CP -> CP) +multi = (symbol '?' >> return QuestionMark) + <|> (symbol '*' >> return Star) + <|> (symbol '+' >> return Plus) + +-- [48] cp ::= (Name | choice | seq) ('?' | '*' | '+')? +cp :: Parser CP +cp = do + a <- (fmap CPName name <|> try cpChoice <|> cpSeq) + f <- option id multi + return (f a) + +-- [49] choice ::= '(' S? cp ( S? '|' S? cp )+ S? ')' +cpChoice :: Parser CP +cpChoice = parenthesized $ do + mspace + x <- cp + xs <- many1 (try (mspace >> symbol '|' >> mspace >> cp)) + mspace + return (Choice (x:xs)) + +-- [50] seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' +cpSeq :: Parser CP +cpSeq = parenthesized $ do + mspace + x <- cp + xs <- many (try (mspace >> symbol ',' >> mspace >> cp)) + mspace + return (Sequence (x:xs)) + +-- [51] Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' +-- | '(' S? '#PCDATA' S? ')' +mixed :: Parser ContentSpec +mixed = symbol '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2) + where + p = mspace >> symbol '|' >> mspace >> name + rest1 = try $ do + xs <- many (try p) + mspace + string ")*" + return (Mixed True xs) + rest2 = mspace >> symbol ')' >> return (Mixed False []) + +-------------------------------------------------- +-- ** 3.3 Attribute-List Declarations + +-- [52] AttlistDecl ::= '' +attlistDecl :: Parser DocTypeDecl +attlistDecl = do + string "' + return (AttListDecl n ds) + +-- [53] AttDef ::= S Name S AttType S DefaultDecl +attDef :: Parser AttDef +attDef = do + space + n <- name + space + tp <- attType + space + dd <- defaultDecl + return (n, tp, dd) + +-- [54] AttType ::= StringType | TokenizedType | EnumeratedType +attType :: Parser AttType +attType = stringType <|> tokenizedType <|> enumeratedType + +-- [55] StringType ::= 'CDATA' +stringType :: Parser AttType +stringType = string "CDATA" >> return StringType + +-- [56] TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' +tokenizedType :: Parser AttType +tokenizedType = choice (map f xs) + where + f (tp, s) = try (string s) >> return tp + xs = [ (IdRefsType, "IDREFS"), (IdRefType, "IDREF"), (IdType, "ID"), (EntityType, "ENTITY") + , (EntitiesType, "ENTITIES"), (NmTokensType, "NMTOKENS"), (NmTokenType, "NMTOKEN") + ] + +-- [57] EnumeratedType ::= NotationType | Enumeration +enumeratedType :: Parser AttType +enumeratedType = notationType <|> enumeration + +-- [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' +notationType :: Parser AttType +notationType = string "NOTATION" >> space >> parenthesized p + where + p = do + mspace + n <- name + ns <- many (try (mspace >> symbol '|' >> mspace >> name)) + mspace + return (NotationType (n:ns)) + +-- [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' +enumeration :: Parser AttType +enumeration = parenthesized $ do + mspace + x <- nmtoken + xs <- many (try (mspace >> symbol '|' >> mspace >> nmtoken)) + mspace + return (EnumerationType (x:xs)) + +-- [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) +defaultDecl :: Parser DefaultDecl +defaultDecl = try (string "#REQUIRED" >> return Required) + <|> try (string "#IMPLIED" >> return Implied) + <|> do f <- option Value (string "#FIXED" >> space >> return Fixed) + a <- attValue + return (f a) + +-------------------------------------------------- +-- ** 3.4 Conditional Sections + +-- [61] conditionalSect ::= includeSect | ignoreSect +conditionalSect :: Parser Conditional +conditionalSect = try includeSect <|> ignoreSect + +-- [62] includeSect ::= '' +includeSect :: Parser Conditional +includeSect = do + string "" + return (Include ds) + +-- [63] ignoreSect ::= '' +ignoreSect :: Parser Conditional +ignoreSect = do + string "" + return (Ignore (concat xss)) + +-- [64] ignoreSectContents ::= Ignore ('' Ignore)* +ignoreSectContents :: Parser [String] +ignoreSectContents = + do x <- ignore + xss <- many $ do + string "" + y <- ignore + return (ys++[y]) + return (x:concat xss) + +-- [65] Ignore ::= Char* - (Char* ('') Char*) +ignore :: Parser String +ignore = stopOn [""] + +-------------------------------------------------- +-- * 4 Physical Structures + +-------------------------------------------------- +-- ** 4.1 Character and Entity References + +-- [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' +charRef :: Parser Reference +charRef = do + string "&#" + n <- p <|> (symbol 'x' >> q) + symbol ';' + return (CharRef n) + where + p = fmap (foldl' (\a b -> a*10+ord b-48) 0) (many1 ('0' <..> '9')) + q = fmap hexa (many1 (ranges [('0', '9'), ('a', 'f'), ('A', 'F')])) + +hexa :: String -> Int +hexa = rec 0 + where + rec n [] = n + rec n (x:xs) = rec (16*n + ord x - correct) xs + where + correct + | x <= '9' = ord '0' + | x <= 'F' = ord 'A' - 10 + | otherwise = ord 'a' - 10 + +-- [67] Reference ::= EntityRef | CharRef +reference :: Parser Reference +reference = try entityRef <|> charRef + +-- [68] EntityRef ::= '&' Name ';' +entityRef :: Parser Reference +entityRef = packed (symbol '&') (fmap EntityRef name) (symbol ';') + +-- [69] PEReference ::= '%' Name ';' +peReference :: Parser Parameter +peReference = packed (symbol '%') (fmap Parameter name) (symbol ';') + +-------------------------------------------------- +-- ** 4.2 Entity Declarations + +-- [70] EntityDecl ::= GEDecl | PEDecl +entityDecl :: Parser DocTypeDecl +entityDecl = try geDecl <|> peDecl + +-- [71] GEDecl ::= '' +geDecl :: Parser DocTypeDecl +geDecl = do + string "' + return (EntityDecl True n ed) + +-- [72] PEDecl ::= '' +peDecl :: Parser DocTypeDecl +peDecl = do + string "' + return (EntityDecl False n (either Left (\a -> Right (a, Nothing)) e)) + +-- [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) +entityDef :: Parser EntityDef +entityDef = fmap Left entityValue <|> do + e <- externalID + ms <- optionM (try nDataDecl) + return (Right (e, ms)) + +-- [74] PEDef ::= EntityValue | ExternalID +peDef :: Parser (Either EntityValue ExternalID) +peDef = fmap Left entityValue <|> fmap Right externalID + +-- [75] ExternalID ::= 'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral +externalID :: Parser ExternalID +externalID = (string "SYSTEM" >> space >> fmap System systemLiteral) <|> do + string "PUBLIC" + space + x <- pubidLiteral + space + y <- systemLiteral + return (Public x y) + +-- [76] NDataDecl ::= S 'NDATA' S Name +nDataDecl :: Parser String +nDataDecl = space >> string "NDATA" >> space >> name + +-------------------------------------------------- +-- ** 4.3 Parsed Entities + +-- [77] TextDecl ::= '' + +textDecl :: Parser TextDecl +textDecl = do + string "" + return (v, e) + +-- [78] extParsedEnt ::= TextDecl? content +extParsedEnt :: Parser (Maybe TextDecl, Content) +extParsedEnt = do + td <- optionM (try textDecl) + c <- content + return (td, c) + +-- [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) +encodingDecl :: Parser String +encodingDecl = space >> string "encoding" >> eq >> + (singleQuoted encName <|> doubleQuoted encName) + +-- [81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* +encName :: Parser String +encName = do + x <- ranges [('A', 'Z'), ('a', 'z')] + xs <- many (ranges [('A', 'Z'), ('a', 'z'), ('0', '9')] <|> oneOf "._-") + return (x:xs) + +-------------------------------------------------- +-- ** 4.7 Notation Declarations + +-- [82] NotationDecl ::= '' +notationDecl :: Parser DocTypeDecl +notationDecl = do + string " fmap Right publicID + mspace + symbol '>' + return (NotationDecl n e) + +-- [83] PublicID ::= 'PUBLIC' S PubidLiteral +publicID :: Parser PublicID +publicID = string "PUBLIC" >> space >> pubidLiteral diff --git a/src/Text/XML/TestSuite.hs b/src/Text/XML/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/TestSuite.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- The XML specification comes with a test suite for testing the correctness +-- of a parser. This module performs these tests. +-- +----------------------------------------------------------------------------- +module Main (main) where + +import Text.XML.Interface +import Common.Utils (trim) +import Control.Monad.Error +import Data.List +import Data.Maybe + +{-testje = do + xs <- readFile "tmp.xml" >>= decoding + print xs + --print (take 3 $ drop 318 $ lines xs) + print (parse document xs) + print (map (\x -> (x, ord x)) xs) -} + +rootDir :: String +rootDir = "D:/xmlts20080827/xmlconf" + +main :: IO () +main = parseIO (rootDir ++ "/xmlconf.xml") >>= runTestSuite + +printProfile :: Element -> IO () +printProfile = + maybe (return ()) putStrLn . findAttribute "PROFILE" + +runTestSuite :: Element -> IO () +runTestSuite e + | name e /= "TESTSUITE" = fail "expected TESTSUITE" + | otherwise = do + printProfile e + is <- mapM (runTestCases ".") (children e) + putStrLn (replicate 40 '*') + putStrLn $ "Test cases failed: " ++ show (sum is) + +runTestCases :: String -> Element -> IO Int +runTestCases base e + | name e /= "TESTCASES" = fail "expected TESTCASES" + | otherwise = do + printProfile e + let newbase = fromMaybe base (findAttribute "xml:base" e) + is <- forM (children e) $ \x -> + if name x == "TESTCASES" + then runTestCases newbase x + else do b <- runTest newbase x + return (if b then 0 else 1) + return (sum is) + +runTest :: String -> Element -> IO Bool +runTest base e + | name e /= "TEST" = fail "expected TEST" + | otherwise = do + let filename = rootDir ++ "/" ++ base ++ "/" ++ uri + uri = fromMaybe "." (findAttribute "URI" e) + testtype = fromMaybe "" (findAttribute "TYPE" e) + reccom = findAttribute "RECOMMENDATION" e + {-case reccom of + Nothing -> return () + Just "XML1.1" -> return () + Just "XML1.0-errata2e" -> return () + Just "NS1.0" -> return () + Just "NS1.1" -> return () + Just "XML1.0-errata3e" -> return () + Just "XML1.0-errata4e" -> return () + Just "NS1.0-errata1e" -> return () -} + if reccom /= Nothing then return True else do + putChar '.' + mdoc <- (do a <- parseIO filename; return (Just a)) + `catch` (\_ -> return Nothing) + case mdoc of + Just _ + -- not (accept document (show doc)) -> error ("pretty-print error: " ++ show doc) + | testtype == "valid" -> return True + Nothing + | testtype == "not-wf" -> return True + | testtype == "error" -> return True + | testtype == "invalid" -> return True + _ | testtype /= "valid" {- && testtype /= "not-wf" -} -> return True + _ -> do + putStrLn $ "\nFilename: " ++ show filename + putStrLn $ "Test type: " ++ show testtype + putStrLn $ "Description: " ++ trim (getData e) + return False diff --git a/src/Text/XML/Unicode.hs b/src/Text/XML/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Unicode.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for Unicode +-- +----------------------------------------------------------------------------- +module Text.XML.Unicode + ( isExtender, isLetter, isDigit, isCombiningChar + , extenderMap, letterMap, digitMap, combiningCharMap + , decoding + ) where + +import Data.Char (chr, ord) +import qualified Text.UTF8 as UTF8 + +data Tree a = Node (Tree a) a (Tree a) | Leaf + +isLetter = checkTree $ makeTree letterMap +isExtender = checkTree $ makeTree extenderMap +isDigit = checkTree $ makeTree digitMap +isCombiningChar = checkTree $ makeTree combiningCharMap + +checkTree :: Tree (Char, Char) -> Char -> Bool +checkTree Leaf _ = False +checkTree (Node l (c1, c2) r) c = + case compare c1 c of + LT -> case compare c c2 of + LT -> True + EQ -> True + GT -> checkTree r c + EQ -> True + GT -> checkTree l c + +makeTree :: [a] -> Tree a +makeTree [] = Leaf +makeTree xs = Node (makeTree ys) z (makeTree zs) + where (ys, z:zs) = splitAt n xs + n = length xs `div` 2 + +f :: Char -> (Char, Char) +f c = (c, c) + +letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap + +merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)] +merge (x:xs) (y:ys) + | x <= y = x:merge xs (y:ys) + | otherwise = y:merge (x:xs) ys +merge xs ys = xs++ys + +extraMap = map f "\161\170\184\185" + +controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'), + ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'), + ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'), + ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'), + ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'), + ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'), + ('\x10FFFE', '\x10FFFF')] + +baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), + ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'), + ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), + ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'), + ('\x01FA','\x0217'), ('\x0250','\x02A8'), ('\x02BB','\x02C1'), f '\x0386' , + ('\x0388','\x038A'), f '\x038C' , ('\x038E','\x03A1'), ('\x03A3','\x03CE'), + ('\x03D0','\x03D6'), f '\x03DA' , f '\x03DC' , f '\x03DE' , f '\x03E0' , + ('\x03E2','\x03F3'), ('\x0401','\x040C'), ('\x040E','\x044F'), + ('\x0451','\x045C'), ('\x045E','\x0481'), ('\x0490','\x04C4'), + ('\x04C7','\x04C8'), ('\x04CB','\x04CC'), ('\x04D0','\x04EB'), + ('\x04EE','\x04F5'), ('\x04F8','\x04F9'), ('\x0531','\x0556'), f '\x0559' , + ('\x0561','\x0586'), ('\x05D0','\x05EA'), ('\x05F0','\x05F2'), + ('\x0621','\x063A'), ('\x0641','\x064A'), ('\x0671','\x06B7'), + ('\x06BA','\x06BE'), ('\x06C0','\x06CE'), ('\x06D0','\x06D3'), f '\x06D5' , + ('\x06E5','\x06E6'), ('\x0905','\x0939'), f '\x093D' , ('\x0958','\x0961'), + ('\x0985','\x098C'), ('\x098F','\x0990'), ('\x0993','\x09A8'), + ('\x09AA','\x09B0'), f '\x09B2' , ('\x09B6','\x09B9'), ('\x09DC','\x09DD'), + ('\x09DF','\x09E1'), ('\x09F0','\x09F1'), ('\x0A05','\x0A0A'), + ('\x0A0F','\x0A10'), ('\x0A13','\x0A28'), ('\x0A2A','\x0A30'), + ('\x0A32','\x0A33'), ('\x0A35','\x0A36'), ('\x0A38','\x0A39'), + ('\x0A59','\x0A5C'), f '\x0A5E' , ('\x0A72','\x0A74'), ('\x0A85','\x0A8B'), + f '\x0A8D' , ('\x0A8F','\x0A91'), ('\x0A93','\x0AA8'), ('\x0AAA','\x0AB0'), + ('\x0AB2','\x0AB3'), ('\x0AB5','\x0AB9'), f '\x0ABD' , f '\x0AE0' , + ('\x0B05','\x0B0C'), ('\x0B0F','\x0B10'), ('\x0B13','\x0B28'), + ('\x0B2A','\x0B30'), ('\x0B32','\x0B33'), ('\x0B36','\x0B39'), f '\x0B3D' , + ('\x0B5C','\x0B5D'), ('\x0B5F','\x0B61'), ('\x0B85','\x0B8A'), + ('\x0B8E','\x0B90'), ('\x0B92','\x0B95'), ('\x0B99','\x0B9A'), f '\x0B9C' , + ('\x0B9E','\x0B9F'), ('\x0BA3','\x0BA4'), ('\x0BA8','\x0BAA'), + ('\x0BAE','\x0BB5'), ('\x0BB7','\x0BB9'), ('\x0C05','\x0C0C'), + ('\x0C0E','\x0C10'), ('\x0C12','\x0C28'), ('\x0C2A','\x0C33'), + ('\x0C35','\x0C39'), ('\x0C60','\x0C61'), ('\x0C85','\x0C8C'), + ('\x0C8E','\x0C90'), ('\x0C92','\x0CA8'), ('\x0CAA','\x0CB3'), + ('\x0CB5','\x0CB9'), f '\x0CDE' , ('\x0CE0','\x0CE1'), ('\x0D05','\x0D0C'), + ('\x0D0E','\x0D10'), ('\x0D12','\x0D28'), ('\x0D2A','\x0D39'), + ('\x0D60','\x0D61'), ('\x0E01','\x0E2E'), f '\x0E30' , ('\x0E32','\x0E33'), + ('\x0E40','\x0E45'), ('\x0E81','\x0E82'), f '\x0E84' , ('\x0E87','\x0E88'), + f '\x0E8A' , f '\x0E8D' , ('\x0E94','\x0E97'), ('\x0E99','\x0E9F'), + ('\x0EA1','\x0EA3'), f '\x0EA5' , f '\x0EA7' , ('\x0EAA','\x0EAB'), + ('\x0EAD','\x0EAE'), f '\x0EB0' , ('\x0EB2','\x0EB3'), f '\x0EBD' , + ('\x0EC0','\x0EC4'), ('\x0F40','\x0F47'), ('\x0F49','\x0F69'), + ('\x10A0','\x10C5'), ('\x10D0','\x10F6'), f '\x1100' , ('\x1102','\x1103'), + ('\x1105','\x1107'), f '\x1109' , ('\x110B','\x110C'), ('\x110E','\x1112'), + f '\x113C' , f '\x113E' , f '\x1140' , f '\x114C' , f '\x114E' , f '\x1150' , ('\x1154','\x1155') , + f '\x1159' , ('\x115F','\x1161'), f '\x1163' , f '\x1165' , f '\x1167' , f '\x1169' , + ('\x116D','\x116E'), ('\x1172','\x1173'), f '\x1175' , f '\x119E' , f '\x11A8' , + f '\x11AB' , ('\x11AE','\x11AF'), ('\x11B7','\x11B8'), f '\x11BA' , + ('\x11BC','\x11C2'), f '\x11EB' , f '\x11F0' , f '\x11F9' , ('\x1E00','\x1E9B'), + ('\x1EA0','\x1EF9'), ('\x1F00','\x1F15'), ('\x1F18','\x1F1D'), + ('\x1F20','\x1F45'), ('\x1F48','\x1F4D'), ('\x1F50','\x1F57'), f '\x1F59' , + f '\x1F5B' , f '\x1F5D' , ('\x1F5F','\x1F7D'), ('\x1F80','\x1FB4'), + ('\x1FB6','\x1FBC'), f '\x1FBE' , ('\x1FC2','\x1FC4'), ('\x1FC6','\x1FCC'), + ('\x1FD0','\x1FD3'), ('\x1FD6','\x1FDB'), ('\x1FE0','\x1FEC'), + ('\x1FF2','\x1FF4'), ('\x1FF6','\x1FFC'), f '\x2126' , ('\x212A','\x212B'), + f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'), + ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] + +ideographicMap = [ ('\x4E00','\x9FA5'), + f '\x3007' , ('\x3021','\x3029') ] + +combiningCharMap = [('\x0300','\x0345'), + ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), + ('\x05A3','\x05B9'), ('\x05BB','\x05BD'), f '\x05BF' , ('\x05C1','\x05C2'), + f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'), + ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'), + ('\x06EA','\x06ED'), ('\x0901','\x0903'), f '\x093C' , ('\x093E','\x094C'), + f '\x094D' , ('\x0951','\x0954'), ('\x0962','\x0963'), ('\x0981','\x0983'), + f '\x09BC' , f '\x09BE' , f '\x09BF' , ('\x09C0','\x09C4'), ('\x09C7','\x09C8'), + ('\x09CB','\x09CD'), f '\x09D7' , ('\x09E2','\x09E3'), f '\x0A02' , f '\x0A3C' , + f '\x0A3E' , f '\x0A3F' , ('\x0A40','\x0A42'), ('\x0A47','\x0A48'), + ('\x0A4B','\x0A4D'), ('\x0A70','\x0A71'), ('\x0A81','\x0A83'), f '\x0ABC' , + ('\x0ABE','\x0AC5'), ('\x0AC7','\x0AC9'), ('\x0ACB','\x0ACD'), + ('\x0B01','\x0B03'), f '\x0B3C' , ('\x0B3E','\x0B43'), ('\x0B47','\x0B48'), + ('\x0B4B','\x0B4D'), ('\x0B56','\x0B57'), ('\x0B82','\x0B83'), + ('\x0BBE','\x0BC2'), ('\x0BC6','\x0BC8'), ('\x0BCA','\x0BCD'), f '\x0BD7' , + ('\x0C01','\x0C03'), ('\x0C3E','\x0C44'), ('\x0C46','\x0C48'), + ('\x0C4A','\x0C4D'), ('\x0C55','\x0C56'), ('\x0C82','\x0C83'), + ('\x0CBE','\x0CC4'), ('\x0CC6','\x0CC8'), ('\x0CCA','\x0CCD'), + ('\x0CD5','\x0CD6'), ('\x0D02','\x0D03'), ('\x0D3E','\x0D43'), + ('\x0D46','\x0D48'), ('\x0D4A','\x0D4D'), f '\x0D57' , f '\x0E31' , + ('\x0E34','\x0E3A'), ('\x0E47','\x0E4E'), f '\x0EB1' , ('\x0EB4','\x0EB9'), + ('\x0EBB','\x0EBC'), ('\x0EC8','\x0ECD'), ('\x0F18','\x0F19'), f '\x0F35' , + f '\x0F37' , f '\x0F39' , f '\x0F3E' , f '\x0F3F' , ('\x0F71','\x0F84'), + ('\x0F86','\x0F8B'), ('\x0F90','\x0F95'), f '\x0F97' , ('\x0F99','\x0FAD'), + ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' , + ('\x302A','\x302F'), f '\x3099' , f '\x309A' ] + +digitMap = [ ('\x0030','\x0039'), + ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'), + ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), + ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'), + ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'), + ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] + +extenderMap = [f '\x00B7' , f '\x02D0' , + f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') + , ('\x309D','\x309E'), ('\x30FC','\x30FE') ] + +decoding :: Monad m => String -> m String +decoding xs + | take 2 xs == "\255\254" = + return (decode16 $ drop 2 xs) + | take 2 xs == "\254\255" = + return (decode16X $ drop 2 xs) + | take 3 xs == "\239\187\191" = + UTF8.decodeM (drop 3 xs) + | otherwise = + UTF8.decodeM xs + +decode16 :: [Char] -> [Char] +decode16 [] = [] +decode16 [x] = [x] +decode16 (a:b:rest) = chr (ord b * 256 + ord a) : decode16 rest + +decode16X :: [Char] -> [Char] +decode16X [] = [] +decode16X [x] = [x] +decode16X (a:b:rest) = chr (ord b + ord a * 256) : decode16X rest