packages feed

ideas (empty) → 0.5.8

raw patch · 135 files changed

+19683/−0 lines, 135 filesdep +QuickCheckdep +basedep +cgisetup-changed

Dependencies added: QuickCheck, base, cgi, containers, filepath, mtl, parsec, random, time, uulib

Files

+ CREDITS.txt view
@@ -0,0 +1,7 @@+AUTHORS++Bastiaan Heeren, Alex gerdes, Johan Jeuring++CREDITS++Harrie Passier, Arthur van Leeuwen, Josje Lodder
+ LICENSE.txt view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+  The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works.  By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.  We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors.  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+  To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights.  Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received.  You must make sure that they, too, receive
+or can get the source code.  And you must show them these terms so they
+know their rights.
+
+  Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+  For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software.  For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+  Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so.  This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software.  The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable.  Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products.  If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+  Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary.  To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                       TERMS AND CONDITIONS
+
+  0. Definitions.
+
+  "This License" refers to version 3 of the GNU General Public License.
+
+  "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+  "The Program" refers to any copyrightable work licensed under this
+License.  Each licensee is addressed as "you".  "Licensees" and
+"recipients" may be individuals or organizations.
+
+  To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy.  The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+  A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+  To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy.  Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+  To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies.  Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+  An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License.  If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+  1. Source Code.
+
+  The "source code" for a work means the preferred form of the work
+for making modifications to it.  "Object code" means any non-source
+form of a work.
+
+  A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+  The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form.  A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+  The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities.  However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work.  For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+  The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+  The Corresponding Source for a work in source code form is that
+same work.
+
+  2. Basic Permissions.
+
+  All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met.  This License explicitly affirms your unlimited
+permission to run the unmodified Program.  The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work.  This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+  You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force.  You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright.  Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+  Conveying under any other circumstances is permitted solely under
+the conditions stated below.  Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+  No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+  When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+  4. Conveying Verbatim Copies.
+
+  You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+  You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+  5. Conveying Modified Source Versions.
+
+  You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+    a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+
+    b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under section
+    7.  This requirement modifies the requirement in section 4 to
+    "keep intact all notices".
+
+    c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy.  This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged.  This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+
+    d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+  A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit.  Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+  6. Conveying Non-Source Forms.
+
+  You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+    a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+
+    b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the
+    Corresponding Source from a network server at no charge.
+
+    c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source.  This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+
+    d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge.  You need not require recipients to copy the
+    Corresponding Source along with the object code.  If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source.  Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+
+    e) Convey the object code using peer-to-peer transmission, provided
+    you inform other peers where the object code and Corresponding
+    Source of the work are being offered to the general public at no
+    charge under subsection 6d.
+
+  A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+  A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling.  In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage.  For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product.  A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+  "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source.  The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+  If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information.  But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+  The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed.  Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+  Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+  7. Additional Terms.
+
+  "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law.  If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+  When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it.  (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.)  You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+  Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+    a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+
+    b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+
+    c) Prohibiting misrepresentation of the origin of that material, or
+    requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+
+    d) Limiting the use for publicity purposes of names of licensors or
+    authors of the material; or
+
+    e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+
+    f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions of
+    it) with contractual assumptions of liability to the recipient, for
+    any liability that these contractual assumptions directly impose on
+    those licensors and authors.
+
+  All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10.  If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term.  If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+  If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+  Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+  8. Termination.
+
+  You may not propagate or modify a covered work except as expressly
+provided under this License.  Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+  However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+  Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+  Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+  9. Acceptance Not Required for Having Copies.
+
+  You are not required to accept this License in order to receive or
+run a copy of the Program.  Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance.  However,
+nothing other than this License grants you permission to propagate or
+modify any covered work.  These actions infringe copyright if you do
+not accept this License.  Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+  10. Automatic Licensing of Downstream Recipients.
+
+  Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License.  You are not responsible
+for enforcing compliance by third parties with this License.
+
+  An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations.  If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+  You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License.  For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+  11. Patents.
+
+  A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based.  The
+work thus licensed is called the contributor's "contributor version".
+
+  A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version.  For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+  Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+  In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement).  To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+  If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients.  "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+  If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+  A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License.  You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+  Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+  12. No Surrender of Others' Freedom.
+
+  If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all.  For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+  13. Use with the GNU Affero General Public License.
+
+  Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work.  The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+  14. Revised Versions of this License.
+
+  The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+  Each version is given a distinguishing version number.  If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation.  If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+  If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+  Later license versions may give you additional or different
+permissions.  However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+  If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+    <program>  Copyright (C) <year>  <name of author>
+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+  You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+  The GNU General Public License does not permit incorporating your program
+into proprietary programs.  If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.  But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ ideas.cabal view
@@ -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++--------------------------------------------------------------------------------+
+ src/Common/Apply.hs view
@@ -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
+ src/Common/Context.hs view
@@ -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)
+ src/Common/Derivation.hs view
@@ -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
+ src/Common/Exercise.hs view
@@ -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    = "<<description>>" +   , exerciseCode   = noCode+   , status         = Experimental+     -- parsing and pretty-printing+   , parser         = const $ Left $ ErrorMessage "<<no parser>>"+   , prettyPrinter  = const "<<no pretty-printer>>"+     -- 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 = "<<no derivation>>"+       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)
+ src/Common/Grammar.hs view
@@ -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
+ src/Common/Rewriting.hs view
@@ -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
+ src/Common/Rewriting/AC.hs view
@@ -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)+-}
+ src/Common/Rewriting/Confluence.hs view
@@ -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
+ src/Common/Rewriting/Difference.hs view
@@ -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)
+ src/Common/Rewriting/MetaVar.hs view
@@ -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
+ src/Common/Rewriting/RewriteRule.hs view
@@ -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
+ src/Common/Rewriting/Substitution.hs view
@@ -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)
+ src/Common/Rewriting/Unification.hs view
@@ -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 _ _ = []
+ src/Common/Strategy.hs view
@@ -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
+ src/Common/Transformation.hs view
@@ -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)
+ src/Common/Traversable.hs view
@@ -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
+ src/Common/Uniplate.hs view
@@ -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
+ src/Common/Utils.hs view
@@ -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 _ = "<function>"+   +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))
+ src/Common/View.hs view
@@ -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
+ src/Domain/LinearAlgebra.hs view
@@ -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
+ src/Domain/LinearAlgebra/Checks.hs view
@@ -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)
+ src/Domain/LinearAlgebra/EquationsRules.hs view
@@ -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)
+ src/Domain/LinearAlgebra/Exercises.hs view
@@ -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)
+ src/Domain/LinearAlgebra/GramSchmidtRules.hs view
@@ -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)
+ src/Domain/LinearAlgebra/LinearSystem.hs view
@@ -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!!
+ src/Domain/LinearAlgebra/LinearView.hs view
@@ -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
+ src/Domain/LinearAlgebra/Matrix.hs view
@@ -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
+ src/Domain/LinearAlgebra/MatrixRules.hs view
@@ -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
+ src/Domain/LinearAlgebra/Parser.hs view
@@ -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
+ src/Domain/LinearAlgebra/Strategies.hs view
@@ -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
+ src/Domain/LinearAlgebra/Symbols.hs view
@@ -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)
+ src/Domain/LinearAlgebra/Vector.hs view
@@ -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
+ src/Domain/Logic.hs view
@@ -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
+
+ src/Domain/Logic/BuggyRules.hs view
@@ -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)+   ]
+ src/Domain/Logic/Exercises.hs view
@@ -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
+-}
+ src/Domain/Logic/FeedbackText.hs view
@@ -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 +
+ src/Domain/Logic/Formula.hs view
@@ -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
+ src/Domain/Logic/GeneralizedRules.hs view
@@ -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
+ src/Domain/Logic/Generator.hs view
@@ -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
+ src/Domain/Logic/Parser.hs view
@@ -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"
+ src/Domain/Logic/Rules.hs view
@@ -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
+ src/Domain/Logic/Strategies.hs view
@@ -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
+ src/Domain/Math/Approximation.hs view
@@ -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) -}
+ src/Domain/Math/Data/Equation.hs view
@@ -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
+ src/Domain/Math/Data/OrList.hs view
@@ -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))
+ src/Domain/Math/Data/Polynomial.hs view
@@ -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]
+ src/Domain/Math/Data/PrimeFactors.hs view
@@ -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+                 )
+ src/Domain/Math/Data/SquareRoot.hs view
@@ -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
+ src/Domain/Math/DerivativeExercise.hs view
@@ -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
+ src/Domain/Math/DerivativeRules.hs view
@@ -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
+ src/Domain/Math/Equation/CoverUpExercise.hs view
@@ -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) -}
+ src/Domain/Math/Equation/CoverUpRules.hs view
@@ -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
+ src/Domain/Math/Equation/Views.hs view
@@ -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
+ src/Domain/Math/Examples/DWO1.hs view
@@ -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)+     ]+   ]
+ src/Domain/Math/Examples/DWO2.hs view
@@ -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+      ]+    ]
+ src/Domain/Math/Expr.hs view
@@ -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
+ src/Domain/Math/Expr/Conversion.hs view
@@ -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
+ src/Domain/Math/Expr/Data.hs view
@@ -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
+ src/Domain/Math/Expr/Parser.hs view
@@ -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
+ src/Domain/Math/Expr/Symbolic.hs view
@@ -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
+ src/Domain/Math/Expr/Symbols.hs view
@@ -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
+ src/Domain/Math/Expr/Views.hs view
@@ -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
+ src/Domain/Math/Numeric/Exercises.hs view
@@ -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)+   }
+ src/Domain/Math/Numeric/Generators.hs view
@@ -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))
+ src/Domain/Math/Numeric/Laws.hs view
@@ -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)
+ src/Domain/Math/Numeric/Rules.hs view
@@ -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
+ src/Domain/Math/Numeric/Strategies.hs view
@@ -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 -}
+ src/Domain/Math/Numeric/Views.hs view
@@ -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)
+ src/Domain/Math/Polynomial/BuggyRules.hs view
@@ -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 (-) ]
+ src/Domain/Math/Polynomial/CleanUp.hs view
@@ -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
+ src/Domain/Math/Polynomial/Exercises.hs view
@@ -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
+ src/Domain/Math/Polynomial/Generators.hs view
@@ -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
+ src/Domain/Math/Polynomial/Rules.hs view
@@ -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
+ src/Domain/Math/Polynomial/Strategies.hs view
@@ -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)
+ src/Domain/Math/Polynomial/Views.hs view
@@ -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
+ src/Domain/Math/Power/Views.hs view
@@ -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)) -}
+ src/Domain/Math/Simplification.hs view
@@ -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
+ src/Domain/Math/SquareRoot/Views.hs view
@@ -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)
+ src/Domain/Math/Strategy/BrokenEquations.hs view
@@ -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 []
+ src/Domain/Math/Strategy/Modulus.hs view
@@ -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 []
+ src/Domain/Math/Strategy/SquareRootEquations.hs view
@@ -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 []
+ src/Domain/Math/Strategy/SquareRootSimplification.hs view
@@ -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 [] -}
+ src/Domain/Programming.hs view
@@ -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
+
+ src/Domain/RelationAlgebra.hs view
@@ -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 -}
+ src/Domain/RelationAlgebra/Equivalence.hs view
@@ -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
+ src/Domain/RelationAlgebra/Exercises.hs view
@@ -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
+ src/Domain/RelationAlgebra/Formula.hs view
@@ -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
+ src/Domain/RelationAlgebra/Generator.hs view
@@ -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)
+ src/Domain/RelationAlgebra/Parser.hs view
@@ -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
+ src/Domain/RelationAlgebra/Rules.hs view
@@ -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
+-}
+ src/Domain/RelationAlgebra/Strategies.hs view
@@ -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
+   
+
+
+   
+
+ src/Service/ExerciseList.hs view
@@ -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
+ src/Service/FeedbackText.hs view
@@ -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)
+ src/Service/LoggingDatabase.hs view
@@ -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
+
+ src/Service/Main.hs view
@@ -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 -}
+ src/Service/ModeJSON.hs view
@@ -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
+ src/Service/ModeXML.hs view
@@ -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
+
+ src/Service/Options.hs view
@@ -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
+ src/Service/ProblemDecomposition.hs view
@@ -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
+ src/Service/Request.hs view
@@ -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
+ src/Service/Revision.hs view
@@ -0,0 +1,4 @@+module Service.Revision where+version = "0.5.8"+revision = 2376+lastChanged = "Fri, 23 Oct 2009"
+ src/Service/SearchSpace.hs view
@@ -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 -}
+ src/Service/ServiceList.hs view
@@ -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)
+ src/Service/TypedAbstractService.hs view
@@ -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
+ src/Service/Types.hs view
@@ -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"
+ src/Text/HTML.hs view
@@ -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 "&nbsp;"++image :: String -> HTMLBuilder +image n = element "img" ("src" .=. n) ++text :: String -> HTMLBuilder+text = XML.text . escape++escape :: String -> String+escape = concatMap f + where+   f '<'  = "&lt;"+   f '>'  = "&gt;"+   f '\n' = "<br>"+   f c   = [c]
+ src/Text/JSON.hs view
@@ -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)
+ src/Text/OpenMath/ContentDictionary.hs view
@@ -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
+ src/Text/OpenMath/Dictionary/Arith1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Calculus1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Fns1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Linalg2.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/List1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Logic1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Nums1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Relation1.hs view
@@ -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"
+
+ src/Text/OpenMath/Dictionary/Transc1.hs view
@@ -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"
+
+ src/Text/OpenMath/MakeSymbols.hs view
@@ -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)
+ src/Text/OpenMath/Object.hs view
@@ -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
+ src/Text/OpenMath/Reply.hs view
@@ -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
+ src/Text/OpenMath/Request.hs view
@@ -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)
+ src/Text/OpenMath/Symbol.hs view
@@ -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
+ src/Text/Parsing.hs view
@@ -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
+ src/Text/UTF8.hs view
@@ -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)
+ src/Text/XML.hs view
@@ -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 ]-}
+ src/Text/XML/Document.hs view
@@ -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     -> "<![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) = "<!DOCTYPE " ++ unwords list ++ ">"+    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  -> "<!ELEMENT " ++ n ++ " " ++ show c ++ ">"+         AttListDecl n as -> "<!ATTLIST " ++ unwords (n:map showAttDef as) ++ ">"+         EntityDecl b n e -> +            let xs = ["%" | not b] ++ [n, showEntityDef e]+            in "<!ENTITY " ++ unwords xs ++ ">"+         NotationDecl n e ->+            let f s = "PUBLIC " ++ doubleQuote s+            in "<!NOTATION " ++ n ++ " " ++ either show f e ++ ">"+         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 -> "<![INCLUDE[" ++ concatMap show xs ++ "]]>"+         Ignore _ -> "" -- ToDO undefined -- [String]+             +showXMLDecl :: XMLDoc -> String+showXMLDecl doc+   | isJust (versionInfo doc) = "<?xml " ++ unwords (catMaybes [s1,s2,s3]) ++ "?>"+   | 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 = "</" ++ 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)
+ src/Text/XML/Interface.hs view
@@ -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 ]+-}
+ src/Text/XML/ParseLib.hs view
@@ -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
+ src/Text/XML/Parser.hs view
@@ -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	   ::=   	'<!--' ((Char - '-') | ('-' (Char - '-')))* '-->'+comment :: Parser String+comment = packed (string "<!--") (stopOn ["--"]) (string "-->")++--------------------------------------------------+-- ** 2.6 Processing Instructions++-- [16]   	PI	   ::=   	'<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'+pInstr :: Parser String+pInstr = packed (string "<?") p (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	   ::=   	'<![CDATA['+-- [20]   	CData	   ::=   	(Char* - (Char* ']]>' Char*))+-- [21]   	CDEnd	   ::=   	']]>'+cdSect :: Parser XML+cdSect = packed (string "<![CDATA[") p (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	   ::=   	'<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'+xmlDecl :: Parser XMLDecl+xmlDecl = do +   string "<?xml"+   x <- versionInfo+   y <- optionM (try encodingDecl)+   z <- optionM (try sdDecl)+   mspace+   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	   ::=   	'<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'+doctypedecl :: Parser DTD+doctypedecl = do +   string "<!DOCTYPE" +   space+   x <- name+   y <- optionM (try (space >> 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	   ::=   	'</' Name S? '>'+eTag :: Parser Name+eTag = do +   string "</" +   n <- name +   mspace +   symbol '>'+   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	   ::=   	'<!ELEMENT' S Name S contentspec S? '>'+elementdecl :: Parser DocTypeDecl+elementdecl = do +   string "<!ELEMENT" +   space +   n <- name +   space +   cs <- contentspec+   mspace+   symbol '>'+   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	   ::=   	'<!ATTLIST' S Name AttDef* S? '>'+attlistDecl :: Parser DocTypeDecl+attlistDecl = do+   string "<!ATTLIST"+   space +   n  <- name+   ds <- many (try attDef)+   mspace +   symbol '>'+   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	   ::=   	'<![' S? 'INCLUDE' S? '[' extSubsetDecl ']]>'+includeSect :: Parser Conditional+includeSect = do +   string "<![" +   mspace +   string "INCLUDE" +   mspace+   symbol '['+   ds <- extSubsetDecl+   string "]]>"+   return (Include ds)++-- [63]   	ignoreSect	   ::=   	'<![' S? 'IGNORE' S? '[' ignoreSectContents* ']]>'+ignoreSect :: Parser Conditional+ignoreSect = do +   string "<![" +   mspace +   string "IGNORE" +   mspace+   symbol '['+   xss <- many ignoreSectContents +   string "]]>"+   return (Ignore (concat xss))++-- [64]   	ignoreSectContents	   ::=   	 Ignore ('<![' ignoreSectContents ']]>' Ignore)*+ignoreSectContents :: Parser [String]+ignoreSectContents = +   do x   <- ignore  +      xss <- many $ do+         string "<![" +         ys <- ignoreSectContents+         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	   ::=   	'<!ENTITY' S Name S EntityDef S? '>'+geDecl :: Parser DocTypeDecl+geDecl = do +   string "<!ENTITY" +   space +   n <- name +   space +   ed <- entityDef+   mspace+   symbol '>'+   return (EntityDecl True n ed)++-- [72]   	PEDecl	   ::=   	'<!ENTITY' S '%' S Name S PEDef S? '>'+peDecl :: Parser DocTypeDecl+peDecl = do+   string "<!ENTITY"+   space +   symbol '%' +   space +   n <- name +   space+   e <- peDef+   mspace+   symbol '>'+   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	   ::=   	'<?xml' VersionInfo? EncodingDecl S? '?>'++textDecl :: Parser TextDecl+textDecl = do +   string "<?xml" +   v <- optionM versionInfo+   e <- encodingDecl +   mspace +   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	   ::=   	'<!NOTATION' S Name S (ExternalID | PublicID) S? '>'+notationDecl :: Parser DocTypeDecl+notationDecl = do+   string "<!NOTATION" +   space +   n <- name +   space+   e <- fmap Left (try externalID) <|> fmap Right publicID+   mspace +   symbol '>' +   return (NotationDecl n e) ++-- [83]   	PublicID	   ::=   	'PUBLIC' S PubidLiteral+publicID :: Parser PublicID+publicID = string "PUBLIC" >> space >> pubidLiteral
+ src/Text/XML/TestSuite.hs view
@@ -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
+ src/Text/XML/Unicode.hs view
@@ -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