packages feed

ideas-math (empty) → 1.0

raw patch · 113 files changed

+18705/−0 lines, 113 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, ideas, parsec, random

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-math.cabal view
@@ -0,0 +1,162 @@+name:                   ideas-math+version:                1.0+synopsis:               Interactive domain reasoner for logic and mathematics+homepage:               http://ideas.cs.uu.nl/www/+description:++   Interactive domain reasoner for logic and mathematics, based on the +   feedback services of the Ideas framework. Domains supported include +   propositional logic (disjunctive normal form and equivalence proofs), +   mathematics (fractions, polynomial equations, powers, derivatives), +   linear algebra (Gaussian elimination and linear systems), and relation+   algebra. The domain reasoner is used by learning environments such as+   the digital mathematical environment of the Freudenthal Institute, MathDox,+   ActiveMath, and the GenExas logic tool. ++category:               Education+copyright:              (c) 2013+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.8.0.2+tested-with:            GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1++-- feedback scripts+extra-source-files: +  scripts/logic.txt+  scripts/math.lineq-en.txt+  scripts/math.polyeq-en.txt+  scripts/math.quadreq-en.txt++source-repository head+  type:     svn+  location: https://ideas.cs.uu.nl/svn/MathTutor/trunk+  +--------------------------------------------------------------------------------++++Executable ideas-math+  Main-is:           Main.hs+  ghc-options:       -Wall+  hs-source-dirs:    src+  Build-Depends:     base >= 4.2 && < 5, +                     QuickCheck >= 2.4.1,+                     containers,+                     random,+                     parsec,+                     ideas == 1.1++  Other-modules:+    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.Vector+    Domain.LinearAlgebra+    Domain.Logic.BuggyRules+    Domain.Logic.Examples+    Domain.Logic.Exercises+    Domain.Logic.Formula+    Domain.Logic.GeneralizedRules+    Domain.Logic.Generator+    Domain.Logic.Parser+    Domain.Logic.Proofs+    Domain.Logic.Rules+    Domain.Logic.Strategies+    Domain.Logic.Views+    Domain.Logic+    Domain.Math.Approximation+    Domain.Math.CleanUp+    Domain.Math.Data.DecimalFraction+    Domain.Math.Data.Interval+    Domain.Math.Data.MixedFraction+    Domain.Math.Data.OrList+    Domain.Math.Data.Polynomial+    Domain.Math.Data.PrimeFactors+    Domain.Math.Data.Primes+    Domain.Math.Data.Relation+    Domain.Math.Data.SquareRoot+    Domain.Math.Data.TestingClassLaws+    Domain.Math.Data.WithBool+    Domain.Math.Derivative.Examples+    Domain.Math.Derivative.Exercises+    Domain.Math.Derivative.Rules+    Domain.Math.Derivative.Strategies+    Domain.Math.Equation.BalanceRules+    Domain.Math.Equation.CoverUpExercise+    Domain.Math.Equation.CoverUpRules+    Domain.Math.Equation.Examples+    Domain.Math.Equation.Views+    Domain.Math.ExerciseList+    Domain.Math.Expr.Clipboard+    Domain.Math.Expr.Data+    Domain.Math.Expr.Parser+    Domain.Math.Expr.Symbols+    Domain.Math.Expr.Views+    Domain.Math.Expr+    Domain.Math.Fraction.Exercises+    Domain.Math.Fraction.Rules+    Domain.Math.Fraction.Strategies+    Domain.Math.Numeric.Examples+    Domain.Math.Numeric.Exercises+    Domain.Math.Numeric.Generators+    Domain.Math.Numeric.Rules+    Domain.Math.Numeric.Strategies+    Domain.Math.Numeric.Tests+    Domain.Math.Numeric.Views+    Domain.Math.Polynomial.Balance+    Domain.Math.Polynomial.BalanceUtils+    Domain.Math.Polynomial.BuggyBalance+    Domain.Math.Polynomial.BuggyRules+    Domain.Math.Polynomial.Equivalence+    Domain.Math.Polynomial.Examples+    Domain.Math.Polynomial.Exercises+    Domain.Math.Polynomial.Generators+    Domain.Math.Polynomial.IneqExercises+    Domain.Math.Polynomial.LeastCommonMultiple+    Domain.Math.Polynomial.RationalExamples+    Domain.Math.Polynomial.RationalExercises+    Domain.Math.Polynomial.RationalRules+    Domain.Math.Polynomial.Rules+    Domain.Math.Polynomial.Strategies+    Domain.Math.Polynomial.Tests+    Domain.Math.Polynomial.Views+    Domain.Math.Power.Equation.Examples+    Domain.Math.Power.Equation.Exercises+    Domain.Math.Power.Equation.NormViews+    Domain.Math.Power.Equation.Rules+    Domain.Math.Power.Equation.Strategies+    Domain.Math.Power.Examples+    Domain.Math.Power.Exercises+    Domain.Math.Power.NormViews+    Domain.Math.Power.OldViews+    Domain.Math.Power.Rules+    Domain.Math.Power.Strategies+    Domain.Math.Power.Utils+    Domain.Math.Power.Views+    Domain.Math.Safe+    Domain.Math.Simplification+    Domain.Math.SquareRoot.Tests+    Domain.Math.SquareRoot.Views+    Domain.RelationAlgebra.Exercises+    Domain.RelationAlgebra.Formula+    Domain.RelationAlgebra.Generator+    Domain.RelationAlgebra.Parser+    Domain.RelationAlgebra.Rules+    Domain.RelationAlgebra.Strategies+    Domain.RelationAlgebra+    Main++--------------------------------------------------------------------------------+
+ scripts/logic.txt view
@@ -0,0 +1,193 @@+namespace logic.propositional
+
+supports logic.propositional.dnf, logic.propositional.dnf.unicode
+
+string okay      = Well done!
+string incorrect = This is incorrect. 
+string multiple  = You have combined multiple steps (or made a mistake). 
+string finished  = Are you aware that you already reached disjunctive normal form?
+
+string commText = { 
+   You have applied one of the commutativity rules correctly. 
+   This step is not mandatory, but sometimes helps to simplify the formula.
+}
+
+string youRewroteInto = You rewrote @diffbefore into @diffafter. 
+string appliedRule    = You have applied @recognized correctly.
+string pressBack      = Press the Back button and try again.
+
+string suggested 
+   | @hasexpected = However, the standard strategy suggests to use @expected.
+   | true         = However, the standard strategy suggests a different step.
+
+string askForHint 
+   | not @oldready = You may ask for a hint.
+   | true          = {} # empty text
+
+feedback same = {
+   You have submitted a similar term. Maybe you inserted 
+   or removed parentheses (the tool supports associativity)?
+}
+
+feedback ok      = @okay @appliedRule
+feedback noteq   = @youRewroteInto @incorrect @pressBack @askForHint
+feedback unknown = @youRewroteInto @multiple @pressBack @askForHint
+feedback buggy   = @youRewroteInto @incorrect @recognized @pressBack @askForHint
+
+feedback detour 
+   | @oldready         = @appliedRule @finished
+   | recognize commor  = @commText
+   | recognize command = @commText
+   | true              = @appliedRule This is correct. @suggested
+
+feedback hint 
+   | @hasexpected = Use @expected.
+   | true         = Sorry, no hint available.
+
+feedback step 
+   | @hasexpected = Use @expected to rewrite @diffbefore into @diffafter.
+   | true         = Sorry, no hint available.
+
+#-------------------------------------------------
+# Rewrite rules rules
+# text declarations define the textual appearance of identifiers 
+
+text falsezeroor, truezeroor, falsezeroand, truezeroand,
+     nottrue, notfalse = one of the False/True rules
+
+text compland, complor = a complement rule
+
+text notnot   = double negation
+text defimpl  = implication elimination
+text defequiv = equivalence elimination
+
+text command, commor   = commutativity
+text assocor, assocand = associativity
+
+text oroverand, genoroverand = distribution of or over and
+text andoveror, genandoveror = distribution of and over or
+
+text idempor, idempand = idempotency
+
+text absorpor, absorpand = absorption
+
+text demorganor, demorganand, gendemorganor, gendemorganand, 
+     invdemorganor, invdemorganand = De Morgan
+
+text invandoveror, invoroverand = distributivity
+
+#-------------------------------------------------
+# Buggy rules
+
+string thinkthat = Did you think that
+string notcase   = This is not the case.
+string tryto     = Did you try to
+
+text buggy.commimp = @thinkthat implication is commutative? @notcase
+
+text buggy.assimp = @thinkthat implication is associative? @notcase 
+
+text buggy.implelim2 = {
+   Make sure that you use the rule for implication 
+   elimination, you seemed to use equivalence elimination
+}
+
+text buggy.equivelim3 = {
+   Make sure that you use the rule for equivalence 
+   elimination, you seemed to use implication elimination
+}
+
+text buggy.idemimp = @thinkthat implication is idempotent? @notcase 
+
+text buggy.idemequi = @thinkthat equivalence is idempotent? @notcase  
+
+text buggy.andsame = {
+   @thinkthat phi AND phi is equivalent to True? @notcase Idempotency of 
+   AND means that phi AND phi is equivalent to phi. 
+}
+
+text buggy.orsame = {
+   @thinkthat phi OR phi is equivalent to True? @notcase Idempotency of 
+   OR means that phi OR phi is equivalent to phi. 
+}
+
+text buggy.equivelim1 = {
+   Be careful with the elimination of an equivalence; take care 
+   of the negations. 
+}
+
+text buggy.equivelim2 = {
+   Be careful with the elimination of an equivalence; make sure that the 
+   disjunctions and the conjunctions are at the right place. 
+}
+
+text buggy.implelim = {
+   Be careful with the elimination of an implication; 
+   make sure the negation is at the right place. 
+}
+
+text buggy.implelim1 = {
+   @tryto eliminate an implication? In that case you used an 
+   AND instead of an OR.
+}
+
+text buggy.demorgan1 = @tryto apply DeMorgan? Be careful with the negations. 
+
+text buggy.demorgan2 = {
+   @tryto apply DeMorgan? Make sure that you remove the outer 
+   negation when applying this rule.
+}
+
+text buggy.demorgan3 = {
+   @tryto apply DeMorgan? Make sure that you replace AND by OR. 
+}
+
+text buggy.demorgan4 = {
+   @tryto apply DeMorgan? Make sure that you replace OR by AND. 
+}
+
+text buggy.demorgan5 = {
+   @tryto apply DeMorgan? Take care of the  scope of the negations. 
+}
+
+text buggy.notoverimpl = {
+   Did you think that you can distribute a negation over an 
+   implication? This is not the case. 
+}
+
+text buggy.parenth1 = Take care of the negations and the parentheses. 
+
+text buggy.parenth2 = {
+   Take care of the outer negation when you eliminate an equivalence. 
+}
+
+text buggy.parenth3 = {
+   @tryto apply double negation? At this place this is not allowed, 
+   because of the parenthesis between the negations. 
+}
+
+text buggy.assoc = {
+   Did you change the parentheses? This is not allowed in a subformula 
+   consisting of a disjunction and a conjunction. 
+}
+
+text buggy.absor = {
+   @tryto apply absorption? You can't apply this rule at this place 
+   since the resulting sub formula is not a subformula of the bigger term. 
+}
+
+text buggy.distr = {
+   @tryto apply distribution? Take care of the place of the disjunctions 
+   and the conjunctions. 
+}
+
+text buggy.distrnot = @tryto apply distribution? Don't forget the negations! 
+
+text buggy.andcompl, buggy.orcompl = {
+   Be careful in the application of the complement-rules 
+}
+
+text buggy.trueprop, buggy.falseprop = {
+   Be careful in the application of the True-False rules 
+}
+
+ scripts/math.lineq-en.txt view
@@ -0,0 +1,55 @@+namespace algebra.equations
+
+supports algebra.equations.linear
+
+# -------------------------------------------------------------
+# Feedback
+
+feedback same = @ok
+feedback noteq = @incorrect
+feedback unknown = @ok
+feedback ok = {Well done!}
+feedback buggy = {@incorrect @recognized}
+feedback detour = @ok
+
+feedback hint = hint
+feedback step = Use @expected to rewrite the equation into: @after
+
+string incorrect = {This step is incorrect.}
+
+# -------------------------------------------------------------
+# Rules
+
+text coverup.negate = {rule negate}
+text coverup.onevar.minus-left = {rule minus left}
+text coverup.onevar.minus-right = {rule minus right}
+text coverup.onevar.plus = {rule plus}
+text coverup.times = {rule times}
+text linear.distr-times = distribution multiplication
+text linear.flip = flip equation
+text linear.merge = merge similar terms
+text linear.norm-mixed = normalize mixed fraction
+text linear.norm-rational = normalize rational number
+text linear.remove-div = remove division
+text linear.var-left = variable to left
+
+# -------------------------------------------------------------
+# Buggy rules
+
+text buggy.cancel-minus = Cancel terms on both sides, but terms have different signs.
+text buggy.distr-times-denom = Incorrect distribution of times over plus: one of the terms is a fraction, and the outer expression is multiplied by the fraction's denominator.
+text buggy.distr-times-plus = Distribution of times over plus: one term is not multiplied.
+text buggy.distr-times-plus-forget = Incorrect distribution of times over plus: one term is forgotten.
+text buggy.distr-times-plus-sign = Incorrect distribution of times over plus: changing sign of addition.
+text buggy.distr-times-too-many = Strange distribution of times over plus: a*(b+c)+d, where 'a' is also multiplied to d.
+text buggy.divide-negate = Dividing, but wrong sign.
+text buggy.divide-numdenom = Dividing both sides, but swapping numerator/denominator.
+text buggy.flip-negate-one-side = Negate terms on one side only.
+text buggy.minus-minus = Incorrect rewriting of a-(b-c): forgetting to change sign.
+text buggy.multiply-forget-one = Multiply the terms on both sides of the equation, but forget one.
+text buggy.multiply-one-side = Multiplication on one side of the equation only
+text buggy.negate-all = Negating all terms (on both sides of the equation, but forgetting one term.
+text buggy.negate-one-side = Negate terms on one side only.
+text buggy.plus = Moving a term from the left-hand side to the right-hand side (or the other way around), but forgetting to change the sign.
+text buggy.priority-times = Prioity of operators is changed, possibly by ignoring some parentheses.
+
+ scripts/math.polyeq-en.txt view
@@ -0,0 +1,29 @@+supports algebra.equations.polynomial
+namespace algebra.equations
+
+include math.quadreq-en.txt
+
+# -------------------------------------------------------------
+# Feedback
+
+# feedback same = {}
+# feedback noteq = {}
+# feedback unknown = {}
+# feedback ok = {}
+# feedback buggy = {}
+# feedback detour = {}
+# feedback hint = {}
+# feedback step = {}
+
+# -------------------------------------------------------------
+# Rules
+
+text polynomial.back-subst = Substitute back a variable
+text polynomial.expose-factor = expose same factor
+text polynomial.power-factors = all power factors
+text polynomial.subst = Substitute variable
+
+# -------------------------------------------------------------
+# Buggy rules
+
+# (none at the moment)
+ scripts/math.quadreq-en.txt view
@@ -0,0 +1,61 @@+namespace algebra.equations
+
+supports algebra.equations.quadratic
+
+include math.lineq-en.txt
+
+# -------------------------------------------------------------
+# Feedback
+
+# feedback same = {}
+# feedback noteq = {}
+# feedback unknown = {}
+# feedback ok = {}
+# feedback buggy = {}
+# feedback detour = {}
+# feedback hint = {}
+# feedback step = {}
+
+# -------------------------------------------------------------
+# Rules
+
+text coverup.numerator = {}
+text coverup.power = {}
+text quadratic.abc = quadratic formula (abc formule)
+text quadratic.approx = Approximate irrational number
+text quadratic.cancel = Cancel terms
+text quadratic.common-factor = {}
+text quadratic.distr-div = distribution division
+text quadratic.distr-square = distribution square
+text quadratic.left-square = factor left as square
+text quadratic.move-left = Move to left
+text quadratic.nice-factors = {}
+text quadratic.no-lin = No linear term ('b=0')
+text quadratic.prepare-split = prepare split square
+text quadratic.product-zero = multiplication is zero
+text quadratic.same-con-factor = same constant factor
+text quadratic.same-factor = same factor
+text quadratic.scale = {}
+text quadratic.simpler-poly = simpler polynomial
+text quadratic.simpler-sqrt = simpler square root
+text quadratic.square-both = square both sides
+
+# -------------------------------------------------------------
+# Buggy rules
+
+text buggy.abc.minus-4ac = {}
+text buggy.abc.minus-b = {}
+text buggy.abc.one-solution = {}
+text buggy.abc.two-a = {}
+text buggy.coverup.even-power = Covering up an even power, but forgetting the negative root
+text buggy.coverup.even-power-forget = Trying to cover up an even power, but there is some other operation to be done first. Example: 9*x^2=81, and rewriting this into x=9 or x=-9.
+text buggy.coverup.even-power-too-early = Trying to cover up an even power, but there is some other operation to be done first. Example: x^2+1=9
+text buggy.coverup.square-minus = A squared term is equal to a negative term on the right-hand side, resulting in an error in the signs
+text buggy.coverup.times-mul = Covering-up a multiplication, but instead of dividing the right-hand side, multiplication is used.
+text buggy.coverup.times-with-plus = Covering-up a multiplication, with an addition on the other side. Only one of the terms is divided.
+text buggy.distr-square = Incorrect removal of parentheses in a squared addition: forgetting the 2ab term
+text buggy.distr-square-forget = Incorrect removal of parentheses in a squared addition: squaring only one term
+text buggy.division-by-var-both = Divide both sides by variable, without introducing the x=0 alternative.
+text buggy.division-by-var-zero = Divide both sides by variable, without introducing the x=0 alternative.
+text buggy.square-multiplication = Incorrect square of a term that involves a multiplication.
+
+ src/Domain/LinearAlgebra.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Export) where
+
+import Domain.LinearAlgebra.EquationsRules as Export
+import Domain.LinearAlgebra.Exercises as Export
+import Domain.LinearAlgebra.LinearSystem as Export
+import Domain.LinearAlgebra.Matrix as Export
+import Domain.LinearAlgebra.MatrixRules as Export
+import Domain.LinearAlgebra.Parser as Export
+import Domain.LinearAlgebra.Strategies as Export
+ src/Domain/LinearAlgebra/Checks.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Data.Maybe
+import Domain.LinearAlgebra hiding (getSolution)
+import Domain.Math.Expr
+import Domain.Math.Simplification (simplify)
+import Ideas.Common.Classes
+import Ideas.Common.Context
+import Ideas.Common.Exercise
+import Ideas.Common.Utils.TestSuite
+import Test.QuickCheck
+
+-----------------------------------------------------------
+--- QuickCheck properties
+
+checks :: TestSuite
+checks = suite "Linear algebra" $ do
+   let thorough = stdArgs {maxSize = 500, maxSuccess = 500}
+   addPropertyWith "echelon"         thorough propEchelon
+   addPropertyWith "reduced echelon" thorough propReducedEchelon
+   addPropertyWith "sound"           thorough propSound
+   addPropertyWith "solution"        thorough propSolution
+
+propEchelon :: Matrix Rational -> Bool
+propEchelon =
+   fromMaybe False . fromContextWith inRowEchelonForm . applyD forwardPass . gaussContext
+
+propReducedEchelon :: Matrix Rational -> Bool
+propReducedEchelon =
+   fromMaybe False . fromContextWith inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext
+
+propSound :: Matrix Rational -> Bool
+propSound m =
+   (fromContext . applyD gaussianElimStrategy . gaussContext) m
+   == Just (fmap fromRational (reduce m))
+
+propSolution :: Matrix Rational -> Property
+propSolution m1 =
+   forAll (arbSolution m1) $ \(solution, m2) ->
+      let m3  = (fromContext . applyD gaussianElimStrategy . gaussContext) m2
+          p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0
+          g   = (*) . fromRational
+      in maybe False (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)
+
+gaussContext :: Matrix Rational -> Context (Matrix Expr)
+gaussContext = inContext gaussianElimExercise . fmap fromRational
+ src/Domain/LinearAlgebra/EquationsRules.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( ruleCoverAllEquations, ruleUncoverEquation, ruleScaleEquation
+   , ruleBackSubstitution, ruleIdentifyFreeVariables, ruleExchangeEquations
+   , ruleEliminateVar, ruleCoverUpEquation, ruleInconsistentSystem
+   , ruleDropEquation, equationsRules
+   , simplifySystem, remaining, linId
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Domain.LinearAlgebra.LinearSystem
+import Domain.LinearAlgebra.LinearView
+import Domain.LinearAlgebra.MatrixRules (covered, getCovered) -- for context
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Simplification (simplify)
+import Ideas.Common.Library hiding (simplify)
+import Ideas.Common.Utils
+import Prelude
+
+linId :: Id
+linId = newId "linearalgebra.linsystem"
+
+equationsRules :: [Rule (Context (LinearSystem Expr))]
+equationsRules =
+   [ ruleExchangeEquations, ruleEliminateVar, ruleDropEquation
+   , ruleInconsistentSystem
+   , ruleScaleEquation, ruleBackSubstitution, ruleIdentifyFreeVariables
+   , ruleCoverUpEquation, ruleUncoverEquation, ruleCoverAllEquations
+   ]
+
+ruleExchangeEquations :: Rule (Context (LinearSystem Expr))
+ruleExchangeEquations = describe "Exchange two equations" $
+   simplifySystem $ ruleTrans (linId, "exchange") $
+   supplyContextParameters exchangeEquations $ \ls -> do
+      mv  <- minvar ls
+      eqs <- remaining ls
+      i   <- findIndexM (elem mv . getVarsSystem . return) eqs
+      cov <- getCovered
+      return (cov, cov + i)
+
+ruleEliminateVar :: Rule (Context (LinearSystem Expr))
+ruleEliminateVar = describe "Eliminate a variable (using addition)" $
+   simplifySystem $ ruleTrans (linId, "eliminate") $
+   supplyContextParameters addEquations $ \ls -> do
+      mv <- minvar ls
+      hd:rest <- remaining ls
+      let getCoef = coefficientOf mv . leftHandSide
+      (i, coef) <- msum [ return (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ]
+      guard (getCoef hd /= 0)
+      let v = negate coef / getCoef hd
+      cov <- getCovered
+      return (i + cov + 1, cov, v)
+
+ruleDropEquation :: Rule (Context (LinearSystem Expr))
+ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $
+   simplifySystem $ ruleTrans (linId, "trivial") $ makeTransLiftContext $ \ls -> do
+      i   <- findIndexM (fromMaybe False . testConstants (==)) ls
+      cov <- getCovered
+      let f n = if i < n then n-1 else n
+      covered := f cov
+      return (deleteIndex i ls)
+
+ruleInconsistentSystem :: Rule (Context (LinearSystem Expr))
+ruleInconsistentSystem = describe "Inconsistent system (0=1)" $
+   simplifySystem $ ruleTrans (linId, "inconsistent") $ makeTransLiftContext $ \ls -> do
+      let stop = [0 :==: 1]
+      guard (invalidSystem ls && ls /= stop)
+      covered := 1
+      return stop
+
+ruleScaleEquation :: Rule (Context (LinearSystem Expr))
+ruleScaleEquation = describe "Scale equation to one" $
+   simplifySystem $ ruleTrans (linId, "scale") $
+   supplyContextParameters scaleEquation $ \ls -> do
+      cov <- getCovered
+      eq  <- elementAt cov ls
+      let expr = leftHandSide eq
+      mv <- minvar ls
+      guard (coefficientOf mv expr /= 0)
+      let coef = 1 / coefficientOf mv expr
+      return (cov, coef)
+
+ruleBackSubstitution :: Rule (Context (LinearSystem Expr))
+ruleBackSubstitution = describe "Back substitution" $
+   simplifySystem $ ruleTrans (linId, "subst") $
+   supplyContextParameters addEquations $ \ls -> do
+      cov <- getCovered
+      eq  <- elementAt cov ls
+      let expr = leftHandSide eq
+      mv <- headM (vars expr)
+      i  <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls)
+      let coef = negate $ coefficientOf mv (leftHandSide (ls !! i))
+      return (i, cov, coef)
+
+ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a))
+ruleIdentifyFreeVariables = describe "Identify free variables" $
+   liftToContext $ minorRule (linId, "freevars") $ \ls ->
+      let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ]
+          f eq =
+             let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1
+             in e2 :==: rightHandSide eq - e1
+      in Just (map f ls)
+
+ruleCoverUpEquation :: Rule (Context (LinearSystem a))
+ruleCoverUpEquation = describe "Cover up first equation" $
+   minor $ ruleTrans (linId, "coverup") $ changeCover succ
+
+ruleUncoverEquation :: Rule (Context (LinearSystem a))
+ruleUncoverEquation = describe "Uncover one equation" $
+   minor $ ruleTrans (linId, "uncover") $ changeCover pred
+
+ruleCoverAllEquations :: Rule (Context (LinearSystem a))
+ruleCoverAllEquations = describe "Cove all equations" $
+   minorRule (linId, "coverall") $ \cls -> do
+      ls <- fromContext cls
+      Just (insertRef covered (length ls) cls)
+
+-- 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)
+   | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs)
+   | otherwise = Nothing
+
+-- simplify a linear system
+simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr))
+simplifySystem = doAfter $ changeInContext (map (fmap f))
+ where f = simplifyWith (fmap simplify) linearView
+
+---------------------------------------------------------------------------------
+-- Parameterized transformations
+
+exchangeEquations :: ParamTrans (Int, Int) (LinearSystem a)
+exchangeEquations = parameter2 "equation 1" "equation 2" exchange
+ where
+   exchange i j
+      | i > j     = exchange j i
+      | otherwise = transMaybe $ \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 :: (Eq a, Reference a, IsLinear a) => ParamTrans (Int, a) (LinearSystem a)
+scaleEquation = parameter2 "equation" "scale factor" $ \i a -> transMaybe $ \xs -> do
+   guard (a `notElem` [0,1])
+   changeAt i (fmap (a*)) xs
+
+addEquations :: (Reference a, IsLinear a) => ParamTrans (Int, Int, a) (LinearSystem a)
+addEquations = parameter3 "equation 1" "equation 2" "scale factor" $ \i j a -> transMaybe $ \xs -> do
+   guard (i/=j)
+   j1 :==: j2 <- liftM (fmap (a*)) (elementAt j xs)
+   let f (i1 :==: i2) = i1+j1 :==: i2+j2
+   changeAt i f xs
+
+changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a))
+changeCover f = makeTransLiftContext_ $ \ls -> do
+   new <- liftM f getCovered
+   guard (new >= 0 && new <= length ls)
+   covered := new
+
+-- local helper function
+validEquation :: Int -> [a] -> Bool
+validEquation n xs = n >= 0 && n < length xs
+
+-- | The equations that remain to be solved
+remaining :: LinearSystem a -> EnvMonad (Equations a)
+remaining ls = do
+   cov <- getCovered
+   return (drop cov ls)
+
+-- | The minimal variable in the remaining equations
+minvar :: IsLinear a => LinearSystem a -> EnvMonad String
+minvar ls = do
+   xs <- liftM getVarsSystem (remaining ls)
+   guard (not $ null xs)
+   return (minimum xs)
+ src/Domain/LinearAlgebra/Exercises.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Data.Function
+import Domain.LinearAlgebra.EquationsRules
+import Domain.LinearAlgebra.GramSchmidtRules
+import Domain.LinearAlgebra.LinearSystem
+import Domain.LinearAlgebra.Matrix
+import Domain.LinearAlgebra.Parser
+import Domain.LinearAlgebra.Strategies
+import Domain.LinearAlgebra.Vector
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Simplification
+import Ideas.Common.Library hiding (simplify)
+import Test.QuickCheck
+
+gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr))
+gramSchmidtExercise = makeExercise
+   { exerciseId     = describe "Gram-Schmidt" $
+                         newId "linearalgebra.gramschmidt"
+   , status         = Alpha
+   , parser         = \s -> case parseVectorSpace s of
+                              Right a  -> Right (fmap simplified a)
+                              Left msg -> Left msg
+   , prettyPrinter  = unlines . map show . vectors
+   , equivalence    = withoutContext $
+                      \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt
+                              in f x == f y
+   , extraRules     = rulesGramSchmidt
+   , ready          = predicate (orthonormalList . filter (not . isZero) . vectors)
+   , strategy       = gramSchmidtStrategy
+   , randomExercise = let f = simplified . fromInteger . (`mod` 25)
+                      in simpleGenerator (liftM (fmap f) arbitrary)
+   }
+
+linearSystemExercise :: Exercise (Equations Expr)
+linearSystemExercise = makeExercise
+   { exerciseId     = describe "Solve Linear System" $
+                         newId "linearalgebra.linsystem"
+   , status         = Stable
+   , parser         = \s -> case parseSystem s of
+                               Right a  -> Right (simplify a)
+                               Left msg -> Left msg
+   , prettyPrinter  = unlines . map show
+   , equivalence    = withoutContext $
+                      \x y -> let f = fromContext . applyD linearSystemStrategy
+                                    . inContext linearSystemExercise . map toStandardForm
+                              in case (f x, f y) of
+                                    (Just a, Just b) -> getSolution a == getSolution b
+                                    _ -> False
+   , extraRules     = equationsRules
+   , ruleOrdering   = ruleOrderingWithId [getId ruleScaleEquation]
+   , ready          = predicate inSolvedForm
+   , strategy       = linearSystemStrategy
+   , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix)
+   }
+
+gaussianElimExercise :: Exercise (Matrix Expr)
+gaussianElimExercise = makeExercise
+   { exerciseId     = describe "Gaussian Elimination" $
+                         newId "linearalgebra.gaussianelim"
+   , status         = Stable
+   , parser         = \s -> case parseMatrix s of
+                               Right a  -> Right (simplify a)
+                               Left msg -> Left msg
+   , prettyPrinter  = ppMatrixWith show
+   , equivalence    = withoutContext (eqMatrix `on` fmap simplified)
+   , ready          = predicate inRowReducedEchelonForm
+   , strategy       = gaussianElimStrategy
+   , randomExercise = simpleGenerator arbMatrix
+   , testGenerator  = Just arbMatrix
+   }
+
+systemWithMatrixExercise :: Exercise Expr
+systemWithMatrixExercise = makeExercise
+   { exerciseId     = describe "Solve Linear System with Matrix" $
+                         newId "linearalgebra.systemwithmatrix"
+   , status         = Provisional
+   , parser         = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of
+                               (Right ok, _) -> Right $ toExpr ok
+                               (_, Right ok) -> Right $ toExpr ok
+                               (Left _, Left _) -> Left "Syntax error"
+   , prettyPrinter  = \expr -> case (fromExpr expr, fromExpr expr) of
+                                  (Just ls, _) -> (unlines . map show) (ls :: Equations Expr)
+                                  (_, Just m)  -> ppMatrix (m :: Matrix Expr)
+                                  _            -> show expr
+   , equivalence    = withoutContext $
+                      \x y -> let f expr = case (fromExpr expr, fromExpr expr) of
+                                              (Just ls, _) -> Just (ls :: Equations Expr)
+                                              (_, Just m)  -> Just $ matrixToSystem (m :: Matrix Expr)
+                                              _            -> Nothing
+                              in case (f x, f y) of
+                                    (Just a, Just b) -> simpleEquivalence linearSystemExercise a b
+                                    _ -> False
+   , ready          = predicate (inSolvedForm . (fromExpr :: Expr -> Equations Expr))
+   , strategy       = systemWithMatrixStrategy
+   , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr)))
+   , testGenerator  = fmap (liftM toExpr) (testGenerator linearSystemExercise)
+   }
+
+--------------------------------------------------------------
+-- Other stuff (to be cleaned up)
+
+arbMatrix :: Num a => Gen (Matrix a)
+arbMatrix = fmap (fmap fromInteger) arbNiceMatrix
+
+arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a)
+arbUpperMatrix = threeNums $ \a b c ->
+   makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]]
+
+arbAugmentedMatrix :: (Enum a, Num a) => Gen (Matrix a)
+arbAugmentedMatrix = threeNums $ \a b c ->
+   makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]]
+
+threeNums :: (Enum a, Num a) => (a -> a -> a -> b) -> Gen b
+threeNums f = let m = elements [-5 .. 5]
+              in liftM3 f m m m
+
+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,90 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( ruleNext, ruleNextOrthogonal
+   , ruleOrthogonal, ruleNormalize
+   , rulesGramSchmidt
+   ) where
+
+import Control.Monad
+import Domain.LinearAlgebra.Vector
+import Ideas.Common.Library
+import Ideas.Common.Utils
+
+varI, varJ :: Ref Int
+varI = makeRef "considered"
+varJ = makeRef "j"
+
+getVarI, getVarJ :: EnvMonad Int
+getVarI = varI :? 0
+getVarJ = varJ :? 0
+
+rulesGramSchmidt :: (Eq a, Floating a, Reference 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 :: (Eq a, Floating a) => Rule (Context (VectorSpace a))
+ruleNormalize = ruleTrans "Turn into unit Vector" $ makeTransLiftContext $ \vs -> do
+   v  <- current vs
+   guard (norm v `notElem` [0, 1])
+   setCurrent (toUnit v) vs
+
+-- Make the current vector orthogonal with some other vector
+-- that has already been considered
+ruleOrthogonal :: (Eq a, Floating a, Reference a) => Rule (Context (VectorSpace a))
+ruleOrthogonal = ruleTrans "Make orthogonal" $
+   supplyContextParameters transOrthogonal $ \_ -> do
+      i <- getVarI
+      j <- getVarJ
+      guard (i>j)
+      return (pred j, pred i)
+
+-- Variable "j" is for administrating which vectors are already orthogonal
+ruleNextOrthogonal :: Rule (Context (VectorSpace a))
+ruleNextOrthogonal = minor $ ruleTrans "Orthogonal to next" $
+   makeTransLiftContext_ $ const $ do
+      i <- getVarI
+      j <- liftM succ getVarJ
+      guard (j < i)
+      varJ := j
+
+-- Consider the next vector
+-- This rule should fail if there are no vectors left
+ruleNext :: Rule (Context (VectorSpace a))
+ruleNext = minor $ ruleTrans "Consider next vector" $
+   makeTransLiftContext_ $ \vs -> do
+      i <- getVarI
+      guard (i < length (vectors vs))
+      varI := i+1
+      varJ := 0
+
+-- Two indices, change the second vector and make it orthogonal
+-- to the first
+transOrthogonal :: (Eq a, Reference a, Floating a) => ParamTrans (Int, Int) (VectorSpace a)
+transOrthogonal = parameter2 "vector 1" "vector 2" $ \i j ->
+   transMaybe $ \a -> do
+      guard (i /= j && i >=0 && j >= 0)
+      let vs = vectors a
+      u <- elementAt i vs
+      guard (isUnit u)
+      liftM makeVectorSpace $ changeAt j (makeOrthogonal u) vs
+
+current :: VectorSpace a -> EnvMonad (Vector a)
+current vs = do
+   i <- getVarI
+   elementAt (i-1) (vectors vs)
+
+setCurrent :: Vector a -> VectorSpace a -> EnvMonad (VectorSpace a)
+setCurrent v vs = do
+   i <- getVarI
+   liftM makeVectorSpace $ replaceAt (i-1) v $ vectors vs
+ src/Domain/LinearAlgebra/LinearSystem.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Data.Foldable (toList)
+import Data.List
+import Data.Maybe
+import Domain.LinearAlgebra.LinearView
+import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows)
+import Domain.Math.Data.Relation
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils
+import Ideas.Common.Utils.Uniplate
+import qualified Data.Set as S
+
+type LinearSystem a = Equations a
+
+getVarsSystem :: IsLinear a => LinearSystem a -> [String]
+getVarsSystem = S.toList . S.unions . map varSet . concatMap toList
+
+evalSystem :: (Eq a,Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool
+evalSystem f =
+   let evalEq (x :==: y) = x==y
+   in all (evalEq . fmap (evalLinearExpr f))
+
+invalidSystem :: (Eq a,IsLinear a) => LinearSystem a -> Bool
+invalidSystem = any invalidEquation
+
+invalidEquation :: (Eq a,IsLinear a) => Equation a -> Bool
+invalidEquation (lhs :==: rhs) = hasNoVar lhs && hasNoVar rhs && getConstant lhs /= getConstant rhs
+
+getSolution :: IsLinear a => LinearSystem a -> Maybe [(String, a)]
+getSolution xs = do
+   guard (distinct vs)
+   guard (null (vs `intersect` frees))
+   mapM make xs
+ where
+   vs    = concatMap (vars . leftHandSide) xs
+   frees = concatMap (vars . rightHandSide) xs
+   make (lhs :==: rhs) = do
+      v <- getVariable lhs
+      return (v, rhs)
+
+-- No constant on the left, no variables on the right
+inStandardForm :: (Eq a,IsLinear a) => Equation a -> Bool
+inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && hasNoVar rhs
+
+toStandardForm :: IsLinear a => Equation a -> Equation a
+toStandardForm (lhs :==: rhs) =
+      let c = getConstant rhs - getConstant lhs
+      in (lhs - rhs + c) :==: c
+
+inSolvedForm :: (Eq a,IsLinear a) => LinearSystem a -> Bool
+inSolvedForm xs = invalidSystem xs || isJust (getSolution xs)
+
+homogeneous :: (Eq a,IsLinear a) => LinearSystem a -> Bool
+homogeneous = all ((== 0) . rightHandSide)
+
+-- Conversions
+systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String])
+systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vs)
+ where
+   vs = getVarsSystem system
+   makeRow (lhs :==: rhs) =
+      map (`coefficientOf` lhs) vs ++ [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 * variable 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,107 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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(..), LinearMap, renameVariables
+   , splitLinearExpr, evalLinearExpr, linearView
+   ) where
+
+import Control.Monad
+import Data.List
+import Domain.Math.Expr
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils.Uniplate
+import Ideas.Common.View
+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 _    -> return $ LM M.empty expr
+         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)
+         Number _ -> return $ LM M.empty expr
+         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 :: (Eq a,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 :: WithFunctions 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, Uniplate a, WithVars a) => IsLinear a where
+   isLinear      :: a -> Bool
+   getConstant   :: a -> a
+   coefficientOf :: String -> a -> a
+
+instance IsLinear Expr where
+   isLinear        = (`belongsTo` linearView)
+   getConstant     = maybe 0 lmConstant . match linearView
+   coefficientOf s = maybe 0 (M.findWithDefault 0 s . lmMap) . match linearView
+
+splitLinearExpr :: IsLinear a => (String -> Bool) -> a -> (a, a)
+splitLinearExpr f a = (make (getConstant a) xs, make 0 ys)
+ where
+   (xs, ys) = partition f (vars a)
+   make = foldr (\v r -> coefficientOf v a * variable v + r)
+
+evalLinearExpr :: IsLinear a => (String -> a) -> a -> a
+evalLinearExpr f a =
+   case getVariable a of
+      Just s  -> f s
+      Nothing -> descend (evalLinearExpr f) a
+
+renameVariables :: IsLinear a => (String -> String) -> a -> a
+renameVariables f a =
+   case getVariable a of
+      Just s  -> variable (f s)
+      Nothing -> descend (renameVariables f) a
+ src/Domain/LinearAlgebra/Matrix.hs view
@@ -0,0 +1,298 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, eqMatrix
+   , switchRows, scaleRow, addRow
+   , inRowEchelonForm, inRowReducedEchelonForm
+   , nonZero, pivot, isPivotColumn
+   , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Foldable (Foldable, foldMap)
+import Data.List hiding (transpose)
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable (Traversable, sequenceA)
+import Domain.Math.Simplification
+import Ideas.Common.Rewriting
+import Test.QuickCheck
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Ideas.Text.OpenMath.Dictionary.Linalg2 as OM
+
+-- 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 rs) = M (map (map f) rs)
+
+instance Foldable Matrix where
+   foldMap f (M xss) = foldMap (mconcat . map f) xss
+
+instance Traversable Matrix where
+   sequenceA (M xss) = M <$> sequenceA (map sequenceA xss)
+
+instance IsTerm a => IsTerm (Matrix a) where
+   toTerm =
+      let f = function matrixrowSymbol . map toTerm
+      in function matrixSymbol . map f . rows
+   fromTerm a = do
+      rs  <- isFunction matrixSymbol a
+      xss <- mapM (isFunction matrixrowSymbol) rs
+      yss <- mapM (mapM fromTerm) xss
+      guard (isRectangular yss)
+      return (makeMatrix yss)
+
+instance Arbitrary a => Arbitrary (Matrix a) where
+   arbitrary = do
+      (i, j) <- arbitrary
+      arbSizedMatrix (i `mod` 5, j `mod` 5)
+
+instance CoArbitrary a => CoArbitrary (Matrix a) where
+   coarbitrary = coarbitrary . rows
+
+arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
+arbSizedMatrix (i, j) =
+   do rs <- replicateM i (vector j)
+      return (makeMatrix rs)
+
+matrixSymbol, matrixrowSymbol :: Symbol
+matrixSymbol    = newSymbol OM.matrixSymbol
+matrixrowSymbol = newSymbol OM.matrixrowSymbol
+
+instance Simplify a => Simplify (Matrix a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
+-- 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 rs
+   | null (concat rs) = M []
+   | isRectangular rs = M rs
+   | 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 rs) = rs
+
+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 rs) = M $ zipWith g [0..] rs
+ 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 :: (Eq a,Fractional a) => Matrix a -> Matrix a
+reduce = backward . forward
+
+forward :: (Eq a,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 :: (Eq a,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 :: (Eq a,Fractional a) => Matrix a -> Int
+rank = length . filter (isJust . pivot) . rows . reduce
+
+nullity :: (Eq a,Fractional a) => Matrix a -> Int
+nullity m = snd (dimensions m) - rank m
+
+inverse :: (Eq a,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 :: (Eq a,Fractional a) => Matrix a -> Bool
+invertible = isJust . inverse
+
+eqMatrix :: (Eq a,Fractional a) => Matrix a -> Matrix a -> Bool
+eqMatrix 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 rs) = M (L.transpose rs)
+
+-------------------------------------------------------
+
+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 rs)
+   | i == j = m
+   | i >  j = switchRows j i m
+   | checkRow i m && checkRow j m =
+        let (before, r1:rest)  = splitAt i       rs
+            (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 rs)
+   | checkRow i m =
+        let f y = if y==i then map (*a) else id
+        in M $ zipWith f [0..] rs
+   | otherwise =
+        error "scaleRow: invalid row"
+
+addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a
+addRow i j a m@(M rs)
+   | 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..] rs
+   | otherwise =
+        error "addRow: invalid row"
+
+-------------------------------------------------------
+
+isLowerTriangular :: (Eq a,Num a) => Matrix a -> Bool
+isLowerTriangular = and . zipWith check [1..] . rows
+ where check n = all (==0) . drop n
+
+isUpperTriangular :: (Eq a,Num a) => Matrix a -> Bool
+isUpperTriangular = and . zipWith check [0..] . rows
+ where check n = all (==0) . take n
+
+inRowEchelonForm :: (Eq a,Num a) => Matrix a -> Bool
+inRowEchelonForm (M rs) =
+   not (any nonZero (dropWhile nonZero rs)) &&
+   increasing (map (length . takeWhile (==0)) (filter nonZero rs))
+ where
+   increasing (x:ys@(y:_)) = x < y && increasing ys
+   increasing _ = True
+
+nonZero :: (Eq a,Num a) => [a] -> Bool
+nonZero = any (/=0)
+
+-- or row canonical form
+inRowReducedEchelonForm :: (Eq a,Num a) => Matrix a -> Bool
+inRowReducedEchelonForm m@(M rs) =
+   inRowEchelonForm m &&
+   all (==1) (mapMaybe pivot rs) &&
+   all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs)
+
+pivot :: (Eq a,Num a) => Row a -> Maybe a
+pivot r = case dropWhile (==0) r of
+             hd:_ -> Just hd
+             _    -> Nothing
+
+isPivotColumn :: (Eq a,Num a) => Column a -> Bool
+isPivotColumn c =
+   case filter (/=0) c of
+      [1] -> True
+      _   -> False
+ src/Domain/LinearAlgebra/MatrixRules.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( ruleFindColumnJ, ruleExchangeNonZero, ruleScaleToOne
+   , ruleZerosFP, ruleCoverRow, ruleUncoverRow, ruleZerosBP
+   , covered, getCovered
+   ) where
+
+import Control.Monad
+import Domain.LinearAlgebra.Matrix
+import Domain.Math.Simplification
+import Ideas.Common.Library hiding (simplify, isEmpty)
+import Ideas.Common.Utils
+
+ruleFindColumnJ :: (Eq a, Num a) => Rule (Context (Matrix a))
+ruleFindColumnJ = minor $ ruleTrans (gaussId, "FindColumnJ") $
+   makeTransLiftContext_ $ \m -> do
+      cols <- liftM columns (subMatrix m)
+      i    <- findIndexM nonZero cols
+      columnJ := i
+
+ruleExchangeNonZero :: (Eq a, Simplify a, Num a) => Rule (Context (Matrix a))
+ruleExchangeNonZero = simplify $ ruleTrans (gaussId, "exchange") $
+   supplyContextParameters rowExchange $ \m -> do
+      nonEmpty m
+      j   <- getColumnJ
+      col <- liftM (column j) (subMatrix m)
+      i   <- findIndexM (/= 0) col
+      cov <- getCovered
+      return (cov, i + cov)
+
+ruleScaleToOne :: (Eq a, Reference a, Simplify a, Fractional a) => Rule (Context (Matrix a))
+ruleScaleToOne = simplify $ ruleTrans (gaussId, "scale") $
+   supplyContextParameters rowScale $ \m -> do
+      nonEmpty m
+      j   <- getColumnJ
+      cov <- getCovered
+      pv  <- liftM (entry (0, j)) (subMatrix m)
+      guard (pv /= 0)
+      return (cov, 1 / pv)
+
+ruleZerosFP :: (Eq a, Reference a, Simplify a, Fractional a) => Rule (Context (Matrix a))
+ruleZerosFP = simplify $ ruleTrans (gaussId, "add") $
+   supplyContextParameters rowAdd $ \m -> do
+      nonEmpty m
+      j   <- getColumnJ
+      col <- liftM (drop 1 . column j) (subMatrix m)
+      i   <- findIndexM (/= 0) col
+      cov <- getCovered
+      let v = negate (col!!i)
+      return (i + cov + 1, cov, v)
+
+ruleZerosBP :: (Eq a, Reference a, Simplify a, Fractional a) => Rule (Context (Matrix a))
+ruleZerosBP = simplify $ ruleTrans (gaussId, "add") $
+   supplyContextParameters rowAdd $ \m -> do
+      nonEmpty m
+      ri <- liftM (row 0) (subMatrix m)
+      let j   = length $ takeWhile (==0) ri
+          col = column j m
+      guard (any (/= 0) ri)
+      k <- findIndexM (/= 0) col
+      let v = negate (col!!k)
+      cov <- getCovered
+      return (k, cov, v)
+
+ruleCoverRow :: Rule (Context (Matrix a))
+ruleCoverRow = minor $ ruleTrans (gaussId, "CoverRow") $ changeCover succ
+
+ruleUncoverRow :: Rule (Context (Matrix a))
+ruleUncoverRow = minor $ ruleTrans (gaussId, "UncoverRow") $ changeCover pred
+
+---------------------------------------------------------------------------------
+-- Parameterized transformations
+
+rowExchange :: ParamTrans (Int, Int) (Matrix a)
+rowExchange = parameter2 "row1" "row2" $ \i j ->
+   transMaybe $ \m -> do
+      guard (i /= j && validRow i m && validRow j m)
+      return (switchRows i j m)
+
+rowScale :: (Eq a, Reference a, Num a) => ParamTrans (Int, a) (Matrix a)
+rowScale = parameter2 "row" "scale factor" $ \i k ->
+   transMaybe $ \m -> do
+      guard (k `notElem` [0, 1] && validRow i m)
+      return (scaleRow i k m)
+
+rowAdd :: (Eq a, Reference a, Num a) => ParamTrans (Int, Int, a) (Matrix a)
+rowAdd = parameter3 "row1" "row2" "scale factor" $ \i j k ->
+   transMaybe $ \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 = makeTransLiftContext_ $ \m -> do
+   new <- liftM f getCovered
+   guard (new >= 0 && new <= fst (dimensions m))
+   covered := new
+
+-- local helper functions
+validRow :: Int -> Matrix a -> Bool
+validRow i m = i >= 0 && i < fst (dimensions m)
+
+nonEmpty :: Matrix a -> EnvMonad ()
+nonEmpty m = subMatrix m >>= guard . not . isEmpty
+
+covered, columnJ :: Ref Int
+covered = makeRef "covered"
+columnJ = makeRef "columnj"
+
+getCovered, getColumnJ :: EnvMonad Int
+getCovered = covered :? 0
+getColumnJ = columnJ :? 0
+
+subMatrix :: Matrix a -> EnvMonad (Matrix a)
+subMatrix m = do
+    cov <- getCovered
+    return $ makeMatrix $ drop cov $ rows m
+
+gaussId :: Id
+gaussId = newId "linearalgebra.gaussianelim"
+ src/Domain/LinearAlgebra/Parser.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, parseSystem
+   , ppMatrix, ppMatrixWith
+   ) where
+
+import Data.Char
+import Data.Either
+import Data.List
+import Domain.LinearAlgebra.LinearSystem
+import Domain.LinearAlgebra.LinearView (isLinear)
+import Domain.LinearAlgebra.Matrix
+import Domain.LinearAlgebra.Vector
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+
+parseSystem :: String -> Either String (LinearSystem Expr)
+parseSystem input =
+   case foreachLine parseEqExpr input of
+      Left msg -> Left msg
+      Right eqs
+         | all f eqs -> Right eqs
+         | otherwise -> Left "System is not linear"
+        where
+          f (a :==: b) = isLinear a && isLinear b
+
+-----------------------------------------------------------
+--- Parser
+
+parseMatrix :: String -> Either String (Matrix Expr)
+parseMatrix input =
+   case foreachLine parseExprTuple input of
+      Left msg -> Left msg
+      Right xss
+         | isRectangular xss -> Right (makeMatrix xss)
+         | otherwise         -> Left "Matrix is not rectangular"
+
+parseVectorSpace :: String -> Either String (VectorSpace Expr)
+parseVectorSpace input =
+   case foreachLine parseExprTuple input of
+      Left msg -> Left msg
+      Right xss
+         | sameDimension vs -> Right (makeVectorSpace vs)
+         | otherwise        -> Left "Vectors have different dimensions"
+       where
+         vs = map fromList xss
+
+nonEmptyLines :: String -> [String]
+nonEmptyLines = filter (not . all isSpace) . lines
+
+foreachLine :: (String -> Either String a) -> String -> Either String [a]
+foreachLine p input =
+   case (partitionEithers . map p . nonEmptyLines) input of
+      (msg:_, _) -> Left msg
+      ([],   as) -> Right as
+
+-----------------------------------------------------------
+--- 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 ' ')
+                  par s = "(" ++ s ++ ")"
+              in unlines $ map (par . intercalate ", " . zipWith align ws) m
+ src/Domain/LinearAlgebra/Strategies.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ) where
+
+import Domain.LinearAlgebra.EquationsRules
+import Domain.LinearAlgebra.GramSchmidtRules
+import Domain.LinearAlgebra.LinearSystem
+import Domain.LinearAlgebra.Matrix
+import Domain.LinearAlgebra.MatrixRules
+import Domain.LinearAlgebra.Vector
+import Domain.Math.Expr
+import Domain.Math.Simplification
+import Ideas.Common.Library hiding (simplify)
+
+gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr))
+gaussianElimStrategy = label "Gaussian elimination" $
+   forwardPass <*> backwardPass
+
+forwardPass :: LabeledStrategy (Context (Matrix Expr))
+forwardPass = label "Forward pass" $
+   simplifyRule <*>
+   repeatS  (   label "Find j-th column"      ruleFindColumnJ
+           <*>  label "Exchange rows"         (try ruleExchangeNonZero)
+           <*>  label "Scale row"             (try ruleScaleToOne)
+           <*>  label "Zeros in j-th column"  (repeatS ruleZerosFP)
+           <*>  label "Cover up top row"      ruleCoverRow
+            )
+
+backwardPass :: LabeledStrategy (Context (Matrix Expr))
+backwardPass = label "Backward pass" $
+   simplifyRule <*>
+   repeatS  (   label "Uncover row"  ruleUncoverRow
+           <*>  label "Sweep"        (repeatS ruleZerosBP)
+            )
+
+backSubstitutionSimple :: LabeledStrategy (Context (LinearSystem Expr))
+backSubstitutionSimple =
+   label "Back substitution with equally many variables and equations" $
+       simplifyFirst
+   <*> label "Cover all equations" ruleCoverAllEquations
+   <*> repeatS (   label "Uncover one equation"  ruleUncoverEquation
+               <*> label "Scale equation to one" (try ruleScaleEquation)
+               <*> label "Back Substitution"     (repeatS 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 <*>
+   repeatS (  dropEquation
+          <|> check hasRemaining
+          <*> label "Exchange equations"        (try ruleExchangeEquations)
+          <*> label "Scale equation to one"     (option ruleScaleEquation)
+          <*> label "Eliminate variable"        (repeatS 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 Expr)
+systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $
+       repeatS (useC dropEquation)
+   <*> conv1
+   <*> useC gaussianElimStrategy
+   <*> conv2
+   <*> repeatS (useC dropEquation)
+
+gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr)))
+gramSchmidtStrategy =
+   label "Gram-Schmidt" $ repeatS $ label "Iteration" $
+       label "Consider next vector"   ruleNext
+   <*> label "Make vector orthogonal" (repeatS (ruleNextOrthogonal <*> try ruleOrthogonal))
+   <*> label "Normalize"              (try ruleNormalize)
+
+varVars :: Ref [Expr]
+varVars = makeRef "variables"
+
+simplifyFirst :: Rule (Context (LinearSystem Expr))
+simplifyFirst = simplifySystem (idRule "simplify")
+
+conv1 :: Rule (Context Expr)
+conv1 = describe "Convert linear system to matrix" $
+   ruleTrans (linId, "tomatrix") $ makeTransLiftContext $ \expr -> do
+      ls   <- fromExpr expr
+      let (m, vs) = systemToMatrix ls
+      varVars := map Var vs
+      return (toExpr (simplify (m :: Matrix Expr)))
+
+conv2 :: Rule (Context Expr)
+conv2 = describe "Convert matrix to linear system" $
+   ruleTrans (linId, "frommatrix") $ makeTransLiftContext $ \expr -> do
+      evs <- varVars :? []
+      m   <- fromExpr expr
+      let vs     = [ v | Var v <- evs ]
+          linsys = matrixToSystemWith vs (m :: Matrix Expr)
+      return $ simplify $ toExpr linsys
+
+hasRemaining :: Context (LinearSystem a) -> Bool
+hasRemaining c =
+   let f = maybe (fail "") remaining (currentInContext c)
+   in any (not . null) $ evalEnvMonad f $ environment c
+ src/Domain/LinearAlgebra/Vector.hs view
@@ -0,0 +1,189 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Applicative
+import Control.Monad
+import Data.Foldable (Foldable, foldMap)
+import Data.List
+import Data.Traversable (Traversable, sequenceA)
+import Domain.Math.Simplification
+import Ideas.Common.Rewriting
+import Test.QuickCheck
+import qualified Ideas.Text.OpenMath.Dictionary.Linalg2 as OM
+
+-------------------------------------------------------------------------------
+-- 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 Foldable Vector where
+   foldMap f (V xs) = foldMap f xs
+
+instance Traversable Vector where
+   sequenceA (V xs) = V <$> sequenceA 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 IsTerm a => IsTerm (Vector a) where
+   toTerm = function vectorSymbol . map toTerm . toList
+   fromTerm a = do
+      xs <- isFunction vectorSymbol a
+      ys <- mapM fromTerm xs
+      return (fromList ys)
+
+instance Arbitrary a => Arbitrary (Vector a) where
+   arbitrary   = liftM fromList $ oneof $ map vector [0..2]
+
+instance CoArbitrary a => CoArbitrary (Vector a) where
+   coarbitrary = coarbitrary . toList
+
+vectorSymbol :: Symbol
+vectorSymbol = newSymbol OM.vectorSymbol
+
+instance Simplify a => Simplify (Vector a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
+instance Functor VectorSpace where
+   fmap f (VS xs) = VS (map (fmap f) xs)
+
+instance Show a => Show (VectorSpace a) where
+   show = show . vectors
+
+instance IsTerm a => IsTerm (VectorSpace a) where
+   toTerm = toTerm . vectors
+   fromTerm a = do
+      xs <- fromTerm a
+      guard (sameDimension xs)
+      return (makeVectorSpace xs)
+
+instance Simplify a => Simplify (VectorSpace a) where
+   simplifyWith opt = fmap (simplifyWith opt)
+
+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
+
+instance CoArbitrary a => CoArbitrary (VectorSpace a) where
+   coarbitrary = coarbitrary . 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) = "(" ++ intercalate "," (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 :: (Eq a,Floating a) => Vector a -> Bool
+isUnit v = norm v == 1
+
+isZero :: (Eq a,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 :: (Eq a,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 :: (Eq a,Floating a) => [Vector a] -> Bool
+orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs
+ where
+   pairs = [ (a, b) | (i, a) <- zip [0::Int ..] 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,21 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Export) where
+
+import Domain.Logic.BuggyRules as Export
+import Domain.Logic.Exercises as Export
+import Domain.Logic.Formula as Export
+import Domain.Logic.GeneralizedRules as Export
+import Domain.Logic.Generator as Export
+import Domain.Logic.Parser as Export
+import Domain.Logic.Rules as Export
+import Domain.Logic.Strategies as Export
+ src/Domain/Logic/BuggyRules.hs view
@@ -0,0 +1,226 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 (buggyRules) where
+
+import Domain.Logic.Formula
+import Domain.Logic.Generator()
+import Ideas.Common.Library hiding (ruleList)
+import qualified Ideas.Common.Library as C
+
+-- Collection of all known buggy rules
+buggyRules :: [Rule SLogic]
+buggyRules =
+   [ buggyCommImp, buggyAssImp, buggyIdemImp, buggyIdemEqui
+   , buggyEquivElim1, buggyImplElim2, buggyEquivElim2, buggyEquivElim3
+   , buggyImplElim, buggyImplElim1, buggyDeMorgan1, buggyDeMorgan2, buggyDeMorgan3
+   , buggyDeMorgan4, buggyDeMorgan5, buggyNotOverImpl, buggyParenth1, buggyParenth2
+   , buggyParenth3, buggyAssoc, buggyAbsor
+   , buggyAndSame, buggyAndCompl, buggyOrSame, buggyOrCompl
+   , buggyTrueProp, buggyFalseProp, buggyDistr, buggyDistrNot
+   ]
+
+rule :: RuleBuilder f a => String -> f -> Rule a
+rule = C.rewriteRule . ( "logic.propositional.buggy" # )
+
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
+ruleList = C.rewriteRules . ( "logic.propositional.buggy" # )
+
+-----------------------------------------------------------------------------
+-- Buggy rules
+
+buggyAndSame :: Rule SLogic
+buggyAndSame = buggy $ rule "AndSame" $
+   \x -> x :&&: x  :~>  T
+
+buggyAndCompl :: Rule SLogic
+buggyAndCompl = buggy $ ruleList "AndCompl"
+   [ \x -> x :&&: Not x  :~>  T
+   , \x -> Not x :&&: x  :~>  T
+   , \x -> x :&&: Not x  :~>  x
+   , \x -> Not x :&&: x  :~>  x
+   ]
+
+buggyOrSame :: Rule SLogic
+buggyOrSame = buggy $ rule "OrSame" $
+   \x -> x :||: x  :~>  T
+
+buggyOrCompl :: Rule SLogic
+buggyOrCompl = buggy $ ruleList "OrCompl"
+   [ \x -> x :||: Not x  :~>  F
+   , \x -> Not x :||:  x :~>  F
+   , \x -> x :||: Not x  :~>  x
+   , \x -> Not x :||:  x :~>  x
+   ]
+
+buggyTrueProp :: Rule SLogic
+buggyTrueProp = buggy $ ruleList "TrueProp"
+   [ \x -> x :||: T  :~>  x
+   , \x -> T :||: x  :~>  x
+   , \x -> x :&&: T  :~>  T
+   , \x -> T :&&: x  :~>  T
+   ]
+
+buggyFalseProp :: Rule SLogic
+buggyFalseProp = buggy $ ruleList "FalseProp"
+   [ \x -> x :||: F  :~>  F
+   , \x -> F :||: x  :~>  F
+   , \x -> x :&&: F  :~>  x
+   , \x -> F :&&: x  :~>  x
+   ]
+
+buggyCommImp :: Rule SLogic
+buggyCommImp = buggy $ rule "CommImp" $
+   \x y -> x :->: y  :~>  y :->: x --this does not hold: T->T => T->x
+
+buggyAssImp :: Rule SLogic
+buggyAssImp = buggy $ ruleList "AssImp"
+   [ \x y z -> x :->: (y :->: z)  :~>  (x :->: y) :->: z
+   , \x y z -> (x :->: y) :->: z  :~>  x :->: (y :->: z)
+   ]
+
+buggyIdemImp :: Rule SLogic
+buggyIdemImp = buggy $ rule "IdemImp" $
+   \x -> x :->: x  :~>  x
+
+buggyIdemEqui :: Rule SLogic
+buggyIdemEqui = buggy $ rule "IdemEqui" $
+   \x -> x :<->: x  :~>  x
+
+buggyEquivElim1 :: Rule SLogic
+buggyEquivElim1 = buggy $ ruleList "EquivElim1"
+    [ \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)
+    ]
+
+buggyEquivElim2 :: Rule SLogic
+buggyEquivElim2 = buggy $ ruleList "EquivElim2"
+    [ \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)
+    ]
+
+buggyEquivElim3 :: Rule SLogic
+buggyEquivElim3 = buggy $ rule "EquivElim3"  $
+     \x y -> x :<->: y :~> Not x :||: y
+
+buggyImplElim :: Rule SLogic
+buggyImplElim = buggy $ ruleList "ImplElim"
+   [\x y -> x :->: y :~> Not (x :||: y)
+   ,\x y -> x :->: y :~> (x :||: y)
+   ,\x y -> x :->: y :~> Not (x :&&: y)
+   ]
+
+buggyImplElim1 :: Rule SLogic
+buggyImplElim1 = buggy $ rule "ImplElim1"  $
+     \x y -> x :->: y :~> Not x :&&: y
+
+buggyImplElim2 :: Rule SLogic
+buggyImplElim2 = buggy $ rule "ImplElim2" $
+     \x y -> x :->: y :~>  (x :&&: y) :||: (Not x :&&: Not y)
+
+buggyDeMorgan1 :: Rule SLogic
+buggyDeMorgan1 = buggy $ ruleList "DeMorgan1"
+    [ \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
+    ]
+
+buggyDeMorgan2 :: Rule SLogic
+buggyDeMorgan2 = buggy $ ruleList "DeMorgan2"
+    [ \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!
+    ]
+buggyDeMorgan3 :: Rule SLogic
+buggyDeMorgan3 = buggy $  rule "DeMorgan3" $
+    \x y -> Not (x :&&: y) :~>  Not x :&&: Not y
+
+buggyDeMorgan4 :: Rule SLogic
+buggyDeMorgan4 = buggy $  rule "DeMorgan4" $
+     \x y -> Not (x :||: y) :~>  Not x :||: Not y
+
+buggyDeMorgan5 :: Rule SLogic
+buggyDeMorgan5 = buggy $ ruleList "DeMorgan5"
+    [ \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
+    ]
+
+buggyNotOverImpl :: Rule SLogic
+buggyNotOverImpl = buggy $ rule "NotOverImpl" $
+    \x y -> Not (x :->: y) :~> Not x :->: Not y
+
+buggyParenth1 :: Rule SLogic
+buggyParenth1 = buggy $ ruleList "Parenth1"
+    [ \x y -> Not (x :&&: y)     :~> Not x :&&: y
+    , \x y -> Not (x :||: y)     :~> Not x :||: y
+    ]
+
+buggyParenth2 :: Rule SLogic
+buggyParenth2 = buggy $ rule "Parenth2" $
+    \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y)
+
+buggyParenth3 :: Rule SLogic
+buggyParenth3 = buggy $ ruleList "Parenth3"
+    [ \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
+    ]
+
+buggyAssoc :: Rule SLogic
+buggyAssoc = buggy $ ruleList "Assoc"
+    [ \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
+    ]
+
+buggyAbsor :: Rule SLogic
+buggyAbsor = buggy $ ruleList "Absor"
+    [ \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)
+    ]
+
+buggyDistr :: Rule SLogic
+buggyDistr = buggy $ ruleList "Distr"
+   [ \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)
+   ]
+
+buggyDistrNot :: Rule SLogic
+buggyDistrNot = buggy $ ruleList "DistrNot"
+   [ \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/Examples.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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  :  josje.lodder@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A set of example proofs
+--
+-----------------------------------------------------------------------------
+module Domain.Logic.Examples
+   ( exampleProofs
+   ) where
+
+import Domain.Logic.Formula
+import Ideas.Common.Exercise
+import Ideas.Common.Utils (ShowString(..))
+
+exampleProofs :: [(Difficulty, (SLogic, SLogic))]
+exampleProofs =
+   [ {-  1 -} ok        (Not(p :||: (Not p :&&: q)), Not(p :||: q))
+   , {-  2 -} ok        ((p :->: q):||: Not p, (p :->: q) :||: q)
+   , {-  3 -} difficult ((p :&&: Not q):||:(q :&&: Not p), (p :||:q):&&:Not(p :&&: q))
+   , {-  4 -} ok        (Not(p :||: Not(p :||: Not q)), Not(p :||: q))
+   , {-  5 -} difficult (p :<->: q, (p :->: q) :&&: (q :->: p))
+   , {-  6 -} ok        ((p :&&: q) :->: p, T)
+   , {-  7 -} ok        ((p :->: q) :||: (q :->: p), T)
+   , {-  8 -} difficult ((q :->: (Not p :->: q)) :->: p, Not p :->: (q :&&: ((p :&&: q) :&&: q)))
+   , {-  9 -} ok        ((p :->: Not q):->:q, (s :||:(s :->:(q :||: p))) :&&: q)
+   , {- 10 -} difficult (p :->: (q :->: r), (p :->: q) :->: (p :->:r))
+   , {- 11 -} difficult (Not((p :->: q) :->: Not(q :->: p)), p :<->: q)
+   , {- 12 -} ok        ((p :->: q):->: (p :->: s), (Not q :->: Not p) :->: (Not s :->: Not p))
+   , {- 13 -} ok        (Not((p :->:q) :->: (p:&&:q)), (p :->: q) :&&: (Not p :||: Not q))
+   , {- 14 -} ok        (Not((p :<->: q) :->: (p :||: (p :<->: q))), F)
+   , {- 15 -} easy      (q :&&: p, p :&&: (q :||: q))
+   , {- 16 -} easy      (Not(p :&&: q) :||: (s :||: Not r), (p :&&: q) :->: (r :->: s))
+   , {- 17 -} easy      (Not(Not p :&&: Not(q :||: r)),  p :||: (q :||: r))
+   , {- 18 -} easy      (Not (p :&&: (q :||: r)), Not p :||: (Not q :&&: Not r))
+   , {- 19 -} easy      (p :&&: q, Not(p :->: Not q))
+   , {- 20 -} difficult (p :<->: (q :<->: p),q)
+   , {- 21 -} ok        ((p :->: q) :->: Not p, (p :->: (q :->: Not p)))
+   , {- 22 -} ok        ((Not q :&&: p) :->: p, (Not q :<->: q) :->: p)
+   , {- 23 -} easy      (p :<->: q, Not p :<->: Not q)
+   , {- 24 -} difficult ((p :->: q) :<->: (p :->: r), (p :->: (q :&&: r)) :||: Not(p :->: (q :||: r)))
+   , {- 25 -} ok        ((p :<->: (p :&&: q), p :->: q))
+   , {- 26 -} ok        (p :<->: (p :->: q), p :&&: q)
+   , {- 27 -} ok        ((p :->: q ) :&&: (r :->: q), (p :||: r) :->: q)
+   , {- 28 -} difficult ((p :&&: (q :&&: r)) :||: (Not p :&&: q), (Not p :&&: (q :&&: Not r)) :||: ( q :&&: r))
+   , {- 29 -} difficult (p :||: (q :&&: r), ( p :&&: Not q) :||: ( p :&&: Not r):||: ( q :&&: r))
+   , {- 30 -} difficult ((p :&&: q) :||: (Not q :&&: r), ( p :&&: r) :||: ( p :&&: q :&&: Not r):||: (Not p :&&: Not q :&&: r))
+   ]
+ where
+   easy      x = (Easy, x)
+   ok        x = (Medium, x)
+   difficult x = (Difficult, x)
+
+   p = Var (ShowString "p")
+   q = Var (ShowString "q")
+   s = Var (ShowString "s")
+   r = Var (ShowString "r")
+
+{-
+makeTestCases :: IO ()
+makeTestCases = zipWithM_ makeTestCase [0..] exampleProofs
+
+makeTestCase :: Int -> (SLogic, SLogic) -> IO ()
+makeTestCase n (p, q) =
+   writeFile ("proof" ++ show n ++ ".json")
+      (json $ show p ++ " == " ++ show q)
+
+json :: String -> String
+json s = unlines
+   [ "{ \"method\" : \"derivation\""
+   , ", \"params\" : [[\"logic.proof\", \"[]\", " ++ show s ++ ", \"\"]]"
+   , ", \"id\"     : 42"
+   , "}"
+   ] -}
+ src/Domain/Logic/Exercises.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 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 Ideas.Common.Library
+import Test.QuickCheck
+
+-- Currently, we use the DWA strategy
+dnfExercise :: Exercise SLogic
+dnfExercise = makeExercise
+   { exerciseId     = describe "Proposition to DNF" $
+                         newId "logic.propositional.dnf"
+   , status         = Stable
+   , parser         = parseLogicPars
+   , prettyPrinter  = ppLogicPars
+   , equivalence    = withoutContext eqLogic
+   , similarity     = withoutContext equalLogicA
+   , ready          = predicate isDNF
+   , suitable       = predicate mySuitable
+   , extraRules     = map liftToContext (extraLogicRules ++ buggyRules)
+   , strategy       = dnfStrategyDWA
+   , navigation     = navigator
+   , testGenerator  = Just (restrictGenerator mySuitable arbitrary)
+   , randomExercise = useGenerator (const True) logicExercise
+   }
+
+-- Direct support for unicode characters
+dnfUnicodeExercise :: Exercise SLogic
+dnfUnicodeExercise = dnfExercise
+   { exerciseId    = describe "Proposition to DNF (unicode support)" $
+                        newId "logic.propositional.dnf.unicode"
+   , parser        = parseLogicUnicodePars
+   , prettyPrinter = ppLogicUnicodePars
+   }
+
+logicExercise :: Maybe Difficulty -> Gen SLogic
+logicExercise mdif =
+   let (gen, (minStep, maxStep)) = generateLevel (fromMaybe Medium mdif)
+       ok p = let i = fromMaybe maxBound (stepsRemaining maxStep p)
+              in countEquivalences p <= 2 && i >= minStep && i <= maxStep
+   in restrictGenerator ok gen
+
+mySuitable :: SLogic -> Bool
+mySuitable = (<=2) . countEquivalences
+
+stepsRemaining :: Int -> SLogic -> Maybe Int
+stepsRemaining i =
+   lengthMax i . derivationTree False dnfStrategyDWA . inContext dnfExercise
+
+-- 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
+
+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/Formula.hs view
@@ -0,0 +1,207 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( module Domain.Logic.Formula
+   , conjunctions, disjunctions, ors, ands
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Foldable (Foldable, foldMap, toList)
+import Data.List
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Classes
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils (ShowString, subsets)
+import Ideas.Common.Utils.Uniplate
+import qualified Data.Traversable as T
+import qualified Ideas.Text.OpenMath.Dictionary.Logic1 as OM
+
+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 (Eq, Ord)
+
+-- | For simple use, we assume the variables to be strings
+type SLogic = Logic ShowString
+
+instance Show a => Show (Logic a) where
+   show = ppLogic
+
+instance Functor Logic where
+   fmap = T.fmapDefault
+
+instance Foldable Logic where
+   foldMap = T.foldMapDefault
+
+instance T.Traversable Logic where
+   traverse f = foldLogic
+      ( fmap Var . f, liftA2 (:->:), liftA2 (:<->:), liftA2 (:&&:)
+      , liftA2 (:||:), liftA Not, pure T, pure F
+      )
+
+instance BoolValue (Logic a) where
+   fromBool b = if b then T else F
+   isTrue T  = True
+   isTrue _  = False
+   isFalse F = True
+   isFalse _ = False
+
+instance Boolean (Logic a) where
+   (<&&>)     = (:&&:)
+   (<||>)     = (:||:)
+   complement = Not
+
+instance CoBoolean (Logic a) where
+   isAnd (p :&&: q)     = Just (p, q)
+   isAnd _              = Nothing
+   isOr  (p :||: q)     = Just (p, q)
+   isOr  _              = Nothing
+   isComplement (Not p) = Just p
+   isComplement _       = Nothing
+
+instance Container Logic where
+   singleton            = Var
+   getSingleton (Var a) = Just a
+   getSingleton _       = Nothing
+
+-- | 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, conj, disj, neg, tr, fl) = 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 `conj`  rec q
+         p :||: q  -> rec p `disj`  rec q
+         Not p     -> neg (rec p)
+         T         -> tr
+         F         -> fl
+
+-- | Pretty-printer for propositions
+ppLogic :: Show a => Logic a -> String
+ppLogic = ppLogicPrio 0
+
+ppLogicPrio :: Show a => Int -> Logic a -> String
+ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg)
+ where
+   alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\"
+         , binop 1 "||", nott, pp "T", pp "F")
+   binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio)
+   pp s      = const (s++)
+   nott p _  = ("~"++) . p 4
+   parIf b f = if b then ("("++) . f . (")"++) else f
+
+-- | The monadic join for logic
+catLogic :: Logic (Logic a) -> Logic a
+catLogic = foldLogic (id, (:->:), (:<->:), (:&&:), (:||:), Not, T, F)
+
+-- | 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)
+
+-- | 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
+      Not (Var _) -> True
+      _           -> null (children logic)
+
+-- | 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
+
+-- | Count the number of equivalences
+countEquivalences :: Logic a -> Int
+countEquivalences p = length [ () | _ :<->: _ <- universe p ]
+
+-- | Function varsLogic returns the variables that appear in a Logic expression.
+varsLogic :: Eq a => Logic a -> [a]
+varsLogic = nub . toList
+
+instance Uniplate (Logic a) where
+   uniplate this =
+      case this of
+         p :->: q  -> plate (:->:)  |* p |* q
+         p :<->: q -> plate (:<->:) |* p |* q
+         p :&&: q  -> plate (:&&:)  |* p |* q
+         p :||: q  -> plate (:||:)  |* p |* q
+         Not p     -> plate Not     |* p
+         _         -> plate this
+
+instance Different (Logic a) where
+   different = (T, F)
+
+instance IsTerm a => IsTerm (Logic a) where
+   toTerm = foldLogic
+      ( toTerm, binary impliesSymbol, binary equivalentSymbol
+      , binary andSymbol, binary orSymbol, unary notSymbol
+      , symbol trueSymbol, symbol falseSymbol
+      )
+
+   fromTerm a =
+      fromTermWith f a `mplus` liftM Var (fromTerm a)
+    where
+      f s []
+         | s == trueSymbol       = return T
+         | s == falseSymbol      = return F
+      f s [x]
+         | s == notSymbol        = return (Not x)
+      f s [x, y]
+         | s == impliesSymbol    = return (x :->: y)
+         | s == equivalentSymbol = return (x :<->: y)
+      f s xs
+         | s == andSymbol        = return (ands xs)
+         | s == orSymbol         = return (ors xs)
+      f _ _ = fail "fromTerm"
+
+trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol,
+   andSymbol, orSymbol :: Symbol
+
+trueSymbol       = newSymbol OM.trueSymbol
+falseSymbol      = newSymbol OM.falseSymbol
+notSymbol        = newSymbol OM.notSymbol
+impliesSymbol    = newSymbol OM.impliesSymbol
+equivalentSymbol = newSymbol OM.equivalentSymbol
+andSymbol        = makeAssociative $ newSymbol OM.andSymbol
+orSymbol         = makeAssociative $ newSymbol OM.orSymbol
+ src/Domain/Logic/GeneralizedRules.hs view
@@ -0,0 +1,142 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( 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 Control.Monad
+import Domain.Logic.Formula
+import Ideas.Common.Library
+import qualified Ideas.Common.Library as C
+
+makeSimpleRule :: String -> (a -> Maybe a) -> Rule a
+makeSimpleRule s = C.makeRule ("logic.propositional." ++ s)
+
+-----------------------------------------------------------------------------
+-- 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 $ ors 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 $ ands 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 :&&: ors ys)
+    `mplus` do
+      pairs <- mapM isAndLast xs
+      let (ys, as) = unzip pairs
+      guard (allSame as)
+      return (ors 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 :||: ands ys)
+    `mplus` do
+      pairs <- mapM isOrLast xs
+      let (ys, as) = unzip pairs
+      guard (allSame as)
+      return (ands 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 (ands (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 (ors (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 (ors (map (:&&: y) xs))
+         (_, ys) | length ys > 2 ->
+            return (ors (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 (ands (map (:||: y) xs))
+         (_, ys) | length ys > 2 ->
+            return (ands (map (x :||:) ys))
+         _ -> Nothing
+   f _ = Nothing
+ src/Domain/Logic/Generator.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, equalLogicACI
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.Function
+import Data.List
+import Domain.Logic.Formula
+import Ideas.Common.Exercise
+import Ideas.Common.Utils (ShowString(..))
+import Ideas.Common.Utils.Uniplate
+import Test.QuickCheck
+
+-------------------------------------------------------------
+-- Code that doesn't belong here
+
+-- | Equality modulo associativity of operators
+equalLogicA :: Eq a => Logic a -> Logic a -> Bool
+equalLogicA = (==) `on` rec
+ where
+   rec a = case a of
+              _ :&&: _ -> ands (map rec (conjunctions a))
+              _ :||: _ -> ors  (map rec (disjunctions a))
+              _        -> descend rec a
+
+-- | Equality modulo associativity/commutativity/idempotency of operators,
+--   and there units/absorbing elements
+equalLogicACI :: Ord a => Logic a -> Logic a -> Bool
+equalLogicACI p q = rec p == rec q
+ where
+   rec a@(_ :&&: _) =
+      let xs = filter (/=T) $ nub $ sort $ conjunctions a
+      in if F `elem` xs then F else ands (map rec xs)
+   rec a@(_ :||: _) =
+      let xs = filter (/=F) $ nub $ sort $ disjunctions a
+      in if T `elem` xs then T else ors (map rec xs)
+   rec a = descend rec a
+
+-----------------------------------------------------------
+-- Logic generator
+
+generateLogic :: Gen SLogic
+generateLogic = normalGenerator
+
+generateLevel :: Difficulty -> (Gen SLogic, (Int, Int))
+generateLevel dif
+   | dif <= Easy      = (easyGenerator,      (3, 6))
+   | dif >= Difficult = (difficultGenerator, (7, 18))
+   | otherwise        = (normalGenerator,    (4, 12))
+
+-- Use the propositions with 3-6 steps
+easyGenerator :: Gen SLogic
+easyGenerator = do
+   n  <- elements [2, 4] -- , return 8]
+   sizedGen True varGen n
+
+-- Use the propositions with 4-12 steps
+normalGenerator :: Gen SLogic
+normalGenerator = do
+   p0 <- sizedGen False varGen 4
+   p1 <- preventSameVar varList p0
+   return (removePartsInDNF p1)
+
+-- Use the propositions with 7-18 steps
+difficultGenerator :: Gen SLogic
+difficultGenerator = do
+   let vs = ShowString "s" : varList
+   p0 <- sizedGen False (elements vs) 4
+   p1 <- preventSameVar vs p0
+   return (removePartsInDNF p1)
+
+varList :: [ShowString]
+varList = map ShowString ["p", "q", "r"]
+
+varGen :: Gen ShowString
+varGen = elements 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 = rec
+ where
+   rec p = case holes p of
+              [(Var a, _), (Var b, update)] | a==b -> do
+                 c <- elements $ filter (/=a) xs
+                 return $ update (Var c)
+              _ -> descendM rec 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 (\i -> sizedGen True varGen (i `min` 4))
+
+instance CoArbitrary SLogic where
+   coarbitrary = foldLogic
+      (var, bin 1, bin 2, bin 3, bin 4, un 5, con 6, con 7)
+    where
+      con       = variant :: Int -> Gen a -> Gen a
+      var       = un 0 . coarbitrary . map ord . fromShowString
+      un  n a   = con n . a
+      bin n a b = con n . a . b
+ src/Domain/Logic/Parser.hs view
@@ -0,0 +1,169 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, parseLogicProof
+   , ppLogicPars, ppLogicUnicodePars
+   ) where
+
+import Domain.Logic.Formula
+import Ideas.Common.Utils (ShowString(..))
+import Ideas.Text.Parsing
+import qualified Text.ParserCombinators.Parsec.Token as P
+
+-----------------------------------------------------------
+--- Parser
+
+parseLogic :: String -> Either String SLogic
+parseLogic = parseBalanced (parserSLogic False False)
+
+parseLogicUnicode :: String -> Either String SLogic
+parseLogicUnicode = parseBalanced (parserSLogic True False)
+
+parseLogicPars :: String -> Either String SLogic
+parseLogicPars input =
+     either (Left . ambiguousOperators parseLogic input) suspiciousVariable
+   $ parseBalanced (parserSLogic False True) input
+
+parseLogicUnicodePars :: String -> Either String SLogic
+parseLogicUnicodePars input =
+   either (Left . ambiguousOperators parseLogicUnicode input) suspiciousVariable
+   $ parseBalanced (parserSLogic True True) input
+
+parseBalanced :: Parser a -> String -> Either String a
+parseBalanced p input =
+   maybe (parseSimple p input) (Left . show) (balanced [('(', ')')] input)
+
+parseLogicProof :: Bool -> String -> Either String (SLogic, SLogic)
+parseLogicProof unicode = parseSimple $ do
+   p <- parserSLogic unicode True
+   reservedOp "=="
+   q <- parserSLogic unicode True
+   return (p, q)
+
+-- generalized parser
+parserSLogic :: Bool -> Bool -> Parser SLogic
+parserSLogic unicode extraPars = pLogic
+ where
+   pLogic
+      | extraPars = atom <**> option id composed
+      | otherwise = buildExpressionParser table atom
+
+   composed = choice
+      [ flip (:->:)  <$ reservedOp implSym  <*> atom
+      , flip (:<->:) <$ reservedOp equivSym <*> atom
+      , (\xs x -> ors (x:xs))  <$> many1 (reservedOp disjSym >> atom)
+      , (\xs x -> ands (x:xs)) <$> many1 (reservedOp conjSym >> atom)
+      ]
+
+   atom = choice
+      [ T <$ P.reserved lexer trSym
+      , F <$ P.reserved lexer flSym
+      , Var . ShowString <$> P.identifier lexer
+      , P.parens lexer pLogic
+      , Not <$ reservedOp negSym <*> atom
+      ]
+
+   table =
+      [ [Infix ((:->:)  <$ reservedOp implSym)  AssocRight ]
+      , [Infix ((:&&:)  <$ reservedOp conjSym)  AssocRight ]
+      , [Infix ((:||:)  <$ reservedOp disjSym)  AssocRight ]
+      , [Infix ((:<->:) <$ reservedOp equivSym) AssocRight ]
+      ]
+
+   (implSym, equivSym, conjSym, disjSym, negSym, trSym, flSym)
+      | unicode   = unicodeTuple
+      | otherwise = asciiTuple
+
+lexer :: P.TokenParser a
+lexer = P.makeTokenParser $ emptyDef
+   { reservedNames   = ["T", "F"]
+   , reservedOpNames = ["~", "<->", "->", "||", "/\\", "=="]
+   , identStart      = lower
+   , identLetter     = lower
+   , opStart         = fail ""
+   , opLetter        = fail ""
+   }
+
+reservedOp :: String -> Parser ()
+reservedOp = P.reservedOp lexer
+
+-----------------------------------------------------------
+--- Helper-functions for syntax warnings
+
+ambiguousOperators :: (String -> Either a b) -> String -> String -> String
+ambiguousOperators p s err =
+   let msg = "Syntax error: ambiguous use of operators (write parentheses)"
+   in either (const err) (const msg) (p s)
+
+-- Report variables
+suspiciousVariable :: SLogic -> Either String SLogic
+suspiciousVariable r =
+   case filter p (map fromShowString (varsLogic r)) of
+      v:_ -> Left $ "Unexpected variable " ++ v
+                 ++ ". Did you forget an operator?"
+      _   -> Right r
+ where
+   p xs = length xs > 1 && all (`elem` "pqrst") xs
+
+-----------------------------------------------------------
+--- Pretty-Printer
+
+-- | 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 :: SymbolTuple -> SLogic -> String
+ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) =
+   (\f -> f 0 "") . foldLogic alg
+ where
+   alg = ( pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 conj
+         , binop 2 disj, nott, pp tr, pp fl
+         )
+   binop :: Int -> String -> (Int -> String -> String) -> (Int -> String -> String) -> Int -> String -> String
+   binop prio op p q n =
+      parIf (n/=0 && (n==3 || prio/=n))
+            (p prio . ((" "++op++" ")++) . q prio)
+   pp s = const (s++)
+   nott  p _ = (neg++) . p 3
+   parIf b f = if b then ("("++) . f . (")"++) else f
+
+-----------------------------------------------------------
+--- Ascii symbols
+
+type SymbolTuple = (String, String, String, String, String, String, String)
+
+asciiTuple :: SymbolTuple
+asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F")
+
+implASym, equivASym, andASym, orASym, notASym :: String
+implASym  = "->"
+equivASym = "<->"
+andASym   = "/\\"
+orASym    = "||"
+notASym   = "~"
+
+-----------------------------------------------------------
+--- Unicode symbols
+
+unicodeTuple :: SymbolTuple
+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/Proofs.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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: to prove two propositions equivalent
+--
+-----------------------------------------------------------------------------
+module Domain.Logic.Proofs
+   ( proofExercise, proofUnicodeExercise
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Foldable (toList)
+import Data.Function (on)
+import Data.List
+import Data.Maybe
+import Domain.Logic.BuggyRules
+import Domain.Logic.Examples
+import Domain.Logic.Formula
+import Domain.Logic.GeneralizedRules
+import Domain.Logic.Generator (equalLogicA)
+import Domain.Logic.Parser
+import Domain.Logic.Rules
+import Domain.Logic.Strategies (somewhereOr)
+import Domain.Math.Expr ()
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Library
+import Ideas.Common.Rewriting.AC
+import Ideas.Common.Traversal.Navigator
+import Ideas.Common.Traversal.Utils
+import Ideas.Common.Utils
+
+{-
+see :: Int -> IO ()
+see n = do
+   let a   = snd (examples proofExercise !! n)
+       der = defaultDerivation proofExercise a
+   printDerivation proofExercise a
+   putStrLn $ ">> " ++ show (derivationLength der) ++ " steps\n"
+-}
+
+-- Currently, we use the DWA strategy
+proofExercise :: Exercise Proof
+proofExercise = makeExercise
+   { exerciseId     = describe "Prove two propositions equivalent" $
+                         newId "logic.proof"
+   , status         = Experimental
+   , parser         = mapSecond makeProof . parseLogicProof False
+   , prettyPrinter  = showProof
+   , equivalence    = withoutContext equivalentProofs
+   , similarity     = withoutContext similarProofs
+   , suitable       = predicate $ all (uncurry eqLogic) . subProofs
+   , ready          = predicate $ all (uncurry equalLogicA) . subProofs
+   , strategy       = proofStrategy
+   , extraRules     = map use extraLogicRules ++ inverseRules ++ map use buggyRules
+   , navigation     = termNavigator
+   , examples       = map (second makeProof) exampleProofs
+   }
+
+proofUnicodeExercise :: Exercise Proof
+proofUnicodeExercise = proofExercise
+   { exerciseId    = describe "Prove two propositions equivalent (unicode support)" $
+                        newId "logic.propositional.proof.unicode"
+   , parser        = mapSecond makeProof . parseLogicProof True
+   , prettyPrinter = showProofUnicode
+   }
+
+type Proof = Logic (SLogic, SLogic)
+
+subProofs :: Proof -> [(SLogic, SLogic)]
+subProofs = toList
+
+makeProof :: (SLogic, SLogic) -> Proof
+makeProof = Var
+
+proofPair :: Proof -> (SLogic, SLogic)
+proofPair x = (catLogic (fmap fst x), catLogic (fmap snd x))
+
+showProof :: Proof -> String
+showProof = uncurry f . proofPair
+ where
+   f p q = ppLogicPars p ++ " == " ++ ppLogicPars q
+
+showProofUnicode :: Proof -> String
+showProofUnicode = uncurry f . proofPair
+ where
+   f p q = ppLogicUnicodePars p ++ " == " ++ ppLogicUnicodePars q
+
+equivalentProofs :: Proof -> Proof -> Bool
+equivalentProofs proof1 proof2 =
+   let (p1, q1) = proofPair proof1
+       (p2, q2) = proofPair proof2
+   in eqLogic p1 p2 && eqLogic q1 q2
+
+similarProofs :: Proof -> Proof -> Bool
+similarProofs proof1 proof2 =
+   let (p1, q1) = proofPair proof1
+       (p2, q2) = proofPair proof2
+   in equalLogicA p1 p2 && equalLogicA q1 q2
+
+proofStrategy :: LabeledStrategy (Context Proof)
+proofStrategy = label "proof equivalent" $
+   repeatS (
+         somewhere splitTop
+      -- somewhere (useC commonExprAtom)   -- (tijdelijk uitgezet)
+      |> useC dnfStrategyDWA
+      )
+      <*> use checkDNF <*> normStrategy
+ where
+   splitTop =  use topIsNot  <|> use topIsImpl
+               -- only use commutativity if not already in desired order
+           <|> (use topIsAnd |> use topIsAndCom)
+           <|> (use topIsOr |> use topIsOrCom)
+           <|> use topIsEquiv
+
+checkDNF :: Rule Proof
+checkDNF = minor $ makeRule "is-dnf" $ \proof -> do
+   guard $ and [ isDNF p && isDNF q | (p, q) <- subProofs proof ]
+   Just proof
+
+normStrategy :: Strategy (Context Proof)
+normStrategy = repeatS $
+      somewhere (use ruleFalseZeroAnd <|> use ruleTrueZeroOr)
+   |> somewhere (use ruleComplAnd)
+   |> somewhere (
+         use ruleIdempOr   <|>
+         use ruleIdempAnd  <|>
+         use ruleAndOverOr <|>
+         use ruleFalseZeroOr
+      )
+   |> oncetd (use sortRuleAnd)
+   |> oncetd (use sortRuleOr)
+   |> somewhereDisjunct introduceVar
+
+sortRuleBy :: (b -> b -> Ordering) -> View a [b] -> Transformation a
+sortRuleBy cmp v = makeTrans $ \p -> do
+   xs <- match v p
+   guard (not (sortedBy cmp xs))
+   let ys = sortBy cmp xs
+   return (build v ys)
+
+sortRuleOr :: Rule SLogic
+sortRuleOr = ruleTrans "CommOr.sort" $
+   sortRuleBy compareVar $ disjunctions <-> ors
+
+sortRuleAnd :: Rule SLogic
+sortRuleAnd = ruleTrans "CommAnd.sort" $
+   sortRuleBy compareVar $ conjunctions <-> ands
+
+compareVar :: Ord a => Logic a -> Logic a -> Ordering
+compareVar = compare `on` (\x -> (varsLogic x, x))
+
+sortedBy :: (a -> a -> Ordering) -> [a] -> Bool
+sortedBy cmp = rec
+ where
+   rec (x:y:zs) = cmp x y /= GT && rec (y:zs)
+   rec _        = True
+
+-----------------------------------------------------------------------------
+-- To DNF, with priorities (the "DWA" approach)
+
+dnfStrategyDWA :: Strategy (Context SLogic)
+dnfStrategyDWA =
+   toplevel <|> somewhereOr
+      (  label "Simplify"                            simpler
+      |> label "Sort and simplify"                   (sortAndSimplify |> deMorganAndSimplify)
+      |> label "Eliminate implications/equivalences" eliminateImplEquiv
+      |> label "Eliminate nots"                      eliminateNots
+      |> label "Move ors to top"                     orToTop
+      )
+ where
+    toplevel = useRules
+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
+       , ruleAbsorpOr, ruleComplOr
+       ]
+    simpler = somewhere $ useRules
+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
+       , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse
+       , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd
+       , ruleComplOr, ruleComplAnd
+       ]
+    sortAndSimplify = somewhere $
+           use ruleAbsorpOrNot
+       <|> (use sortForIdempOr  <*> try (use ruleIdempOr))
+       <|> (use sortForIdempAnd <*> try (use ruleIdempAnd))
+       <|> (use sortForComplOr  <*> try (use ruleComplOr))
+       <|> (use sortForComplAnd <*> try (use ruleComplAnd))
+    deMorganAndSimplify = somewhere $
+           (use ruleDeMorganOrNot  <*> try (oncetd (use ruleNotNot)))
+       <|> (use ruleDeMorganAndNot <*> try (oncetd (use ruleNotNot)))
+    eliminateImplEquiv =
+           oncetd (use ruleDefImpl)
+        |> oncebu (use ruleDefEquiv)
+
+    eliminateNots = somewhere $ useRules
+       [ generalRuleDeMorganAnd, generalRuleDeMorganOr
+       , ruleDeMorganAnd, ruleDeMorganOr
+       ]
+    orToTop = somewhere $ useRules
+       [ generalRuleAndOverOr, ruleAndOverOr ]
+
+useRules :: [Rule SLogic] -> Strategy (Context SLogic)
+useRules = alternatives . map liftToContext
+
+{-
+normLogicRule :: Rule (SLogic, SLogic)
+normLogicRule = ruleMaybe "Normalize" $ \tuple@(p, q) -> do
+   guard (p /= q)
+   let xs  = sort (varsLogic p `union` varsLogic q)
+       new = (normLogicWith xs p, normLogicWith xs q)
+   guard (tuple /= new)
+   return new -}
+
+-- disabled for now
+
+-- Find a common subexpression that can be treated as a box
+{-
+commonExprAtom :: Rule (Context (SLogic, SLogic))
+commonExprAtom = minor $ ruleTrans "commonExprAtom" $ makeTransLiftContext $ \(p, q) -> do
+   let xs = filter (same <&&> complement isAtomic) (largestCommonSubExpr p q)
+       same cse = eqLogic (sub cse p) (sub cse q)
+       new = head (logicVars \\ (varsLogic p `union` varsLogic q))
+       sub a this
+          | a == this = Var new
+          | otherwise = descend (sub a) this
+   case xs of
+      hd:_ -> do
+         xs <- substRef :? []
+         substRef := (show new, show hd):xs
+         return (sub hd p, sub hd q)
+      _ -> fail "not applicable"
+
+largestCommonSubExpr :: (Uniplate a, Ord a) => a -> a -> [a]
+largestCommonSubExpr x = rec
+ where
+   uniX  = S.fromList (universe x)
+   rec y | y `S.member` uniX = [y]
+         | otherwise         = concatMap rec (children y)
+
+substRef :: Ref [(String, String)]
+substRef = makeRef "subst"
+
+logicVars :: [ShowString]
+logicVars = [ ShowString [c] | c <- ['a'..] ]
+-}
+
+{-
+normLogic :: Ord a => Logic a -> Logic a
+normLogic p = normLogicWith (sort (varsLogic p)) p
+
+normLogicWith :: Eq a => [a] -> Logic a -> Logic a
+normLogicWith xs p = make (filter keep (subsets xs))
+ where
+   keep ys = evalLogic (`elem` ys) p
+   make = ors . map atoms
+   atoms ys = ands [ f (x `elem` ys) (Var x) | x <- xs ]
+   f b = if b then id else Not
+-}
+
+-- p \/ q \/ ~p  ~>  reorder p and ~p
+sortForComplOr :: Rule SLogic
+sortForComplOr = ruleMaybe "ComplOr.sort" $ \p -> do
+   let xs = disjunctions p
+       ys = sortBy compareVar xs
+   guard (xs /= ys && any (\x -> Not x `elem` xs) xs)
+   return (ors ys)
+
+-- p /\ q /\ ~p  ~>  reorder p and ~p
+sortForComplAnd :: Rule SLogic
+sortForComplAnd = ruleMaybe "ComplAnd.sort" $ \p -> do
+   let xs = conjunctions p
+       ys = sortBy compareVar xs
+   guard (xs /= ys && any (\x -> Not x `elem` xs) xs)
+   return (ands ys)
+
+-- p \/ q \/ p      ~> reorder p's
+sortForIdempOr :: Rule SLogic
+sortForIdempOr = ruleMaybe "IdempOr.sort" $ \p -> do
+   let xs = disjunctions p
+       ys = sortBy compareVar xs
+   guard (xs /= ys && not (distinct xs))
+   return (ors ys)
+
+-- p /\ q /\ p      ~> reorder p's
+sortForIdempAnd :: Rule SLogic
+sortForIdempAnd = ruleMaybe "IdempAnd.sort" $ \p -> do
+   let xs = conjunctions p
+       ys = sortBy compareVar xs
+   guard (xs /= ys && not (distinct xs))
+   return (ands ys)
+
+{-
+-- (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
+--    (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
+absorptionSubset :: Rule SLogic
+absorptionSubset = ruleList "absorptionSubset" $ \p -> do
+   let xss = map conjunctions (disjunctions p)
+       yss = nub $ filter (\xs -> all (ok xs) xss) xss
+       ok xs ys = not (ys `isSubsetOf` xs) || xs == ys
+   guard (length yss < length xss)
+   return $ ors (map ands yss)
+
+-- p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
+--    (p is hier een losse variabele)
+fakeAbsorption :: Rule SLogic
+fakeAbsorption = makeRule "fakeAbsorption" $ \p -> do
+   let xs = disjunctions p
+   v <- [ a | a@(Var _) <- xs ]
+   let ys  = map (ands . filter (/= Not v) . conjunctions) xs
+       new = ors ys
+   guard (p /= new)
+   return new
+
+-- ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
+--   (p is hier een losse variabele)
+fakeAbsorptionNot :: Rule SLogic
+fakeAbsorptionNot = makeRule "fakeAbsorptionNot" $ \p -> do
+   let xs = disjunctions p
+   v <- [ a | Not a@(Var _) <- xs ]
+   let ys  = map (ands . filter (/= v) . conjunctions) xs
+       new = ors ys
+   guard (p /= new)
+   return new -}
+
+acTopRuleFor :: Bool -> (forall a . Isomorphism (Logic a) [Logic a])
+             -> Transformation Proof
+acTopRuleFor com ep = makeTrans $ \proof -> do
+   pair <- maybeToList (getSingleton proof)
+   let pairings = if com then pairingsAC else pairingsA
+       ep2 = ep *** ep
+       (xs, ys) = from ep2 pair
+   guard (length xs > 1 && length ys > 1)
+   xs <- liftM (map (to ep2)) (pairings False xs ys)
+   guard (all (uncurry eqLogic) xs)
+   return (to ep (map Var xs))
+
+collect :: View a (a, a) -> Isomorphism a [a]
+collect v = f <-> g
+ where
+   f x = maybe [x] (\(y, z) -> f y ++ f z) (match v x)
+   g   = foldr1 (curry (build v))
+
+andView, orView, eqView :: View (Logic a) (Logic a, Logic a)
+andView = makeView isAnd (uncurry (<&&>))
+orView  = makeView isOr  (uncurry (<||>))
+eqView  = makeView isEq  (uncurry equivalent)
+ where
+   isEq (p :<->: q) = Just (p, q)
+   isEq _           = Nothing
+
+topIsAnd :: Rule Proof
+topIsAnd = minor $ ruleTrans "top-is-and" $ acTopRuleFor False (collect andView)
+
+topIsOr :: Rule Proof
+topIsOr = minor $ ruleTrans "top-is-or" $ acTopRuleFor False (collect orView)
+
+topIsEquiv :: Rule Proof
+topIsEquiv = minor $ ruleTrans "top-is-equiv"  $ acTopRuleFor False (collect eqView)
+
+topIsAndCom :: Rule Proof
+topIsAndCom = ruleTrans "top-is-and.com" $ acTopRuleFor True (collect andView)
+
+topIsOrCom :: Rule Proof
+topIsOrCom = ruleTrans "top-is-or.com" $ acTopRuleFor True (collect orView)
+
+--topIsEquivCom :: Rule Proof
+--topIsEquivCom = ruleTrans "top-is-equiv.com"  $ acTopRuleFor True (collect eqView)
+
+topIsImpl :: Rule Proof
+topIsImpl = minorRule "top-is-impl" f
+ where
+   f (Var (p :->: q, r :->: s)) = do
+      guard (eqLogic p r && eqLogic q s)
+      return (Var (p, r) :->: Var (q, s))
+   f _ = Nothing
+
+topIsNot :: Rule Proof
+topIsNot = minorRule "top-is-not" f
+ where
+   f (Var (Not p, Not q)) = Just (Not (Var (p, q)))
+   f _ = Nothing
+
+{- Strategie voor sterke(?) normalisatie
+
+(prioritering)
+
+1. p \/ q \/ ~p     ~> T           (propageren)
+   p /\ q /\ p      ~> p /\ q
+   p /\ q /\ ~p     ~> F           (propageren)
+
+2. (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
+         (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
+   p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
+         (p is hier een losse variabele)
+   ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
+         (p is hier een losse variabele)
+
+3. a) elimineren wat aan een kant helemaal niet voorkomt (zie regel hieronder)
+   b) rijtjes sorteren
+   c) rijtjes aanvullen
+
+Twijfelachtige regel bij stap 3: samennemen in plaats van aanvullen:
+   (p /\ q /\ r) \/ ... \/ (~p /\ q /\ r)   ~> q /\ r
+          (p is hier een losse variable)
+-}
+
+-----------------------------------------------
+-- Introduction of var
+
+introduceVar :: Strategy (Context Proof)
+introduceVar =  check missing
+            <*> use introTrueLeft
+            <*> layer [] introCompl
+
+missing :: Context Proof -> Bool
+missing = isJust . missingVar
+
+localEqVars :: Context Proof -> [ShowString]
+localEqVars cp =
+   case currentTerm cp >>= fromTerm of
+      Just (p, q) -> varsLogic p `union` varsLogic q
+      Nothing     -> maybe [] localEqVars (up cp)
+
+missingVar :: Context Proof -> Maybe ShowString
+missingVar cp =
+   case currentTerm cp >>= fromTerm of
+      Just p  -> listToMaybe (localEqVars cp \\ varsLogic p)
+      Nothing -> Nothing
+
+introTrueLeft :: Rule SLogic
+introTrueLeft = rewriteRule "IntroTrueLeft" $
+   \x -> x  :~>  T :&&: x
+
+introCompl :: Rule (Context Proof)
+introCompl = makeRule "IntroCompl" $ \cp -> do
+   a <- missingVar (safe up cp)
+   let f = fromTerm >=> fmap toTerm . introTautology a
+   changeTerm f cp
+ where
+   introTautology :: a -> Logic a -> Maybe (Logic a)
+   introTautology a T = Just (Var a :||: Not (Var a))
+   introTautology _ _ = Nothing
+
+ {-
+go = applyAll (somewhereDisjunct introduceVar) $ inContext proofExercise $
+   makeProof (p :||: (Not p :&&: q), p :||: q)
+ where
+   p = Var (ShowString "p")
+   q = Var (ShowString "q")
+
+somewhereEq :: IsStrategy f => f (Context Proof) -> Strategy (Context Proof)
+somewhereEq s = traverse [once, topdown]
+   (check isEq <*> layer [] s)
+ where
+   isEq :: Context Proof -> Bool
+   isEq cp = fromMaybe False $ do
+      t <- currentTerm cp
+      case fromTerm t :: Maybe (SLogic, SLogic) of
+         Just (p, q) -> return True
+         _           -> return False -}
+
+somewhereDisjunct :: IsStrategy f => f (Context Proof) -> Strategy (Context Proof)
+somewhereDisjunct s = oncetd (check isEq <*> layer [] (somewhereOrG s))
+ where
+   isEq :: Context Proof -> Bool
+   isEq cp = (isJust :: Maybe (SLogic, SLogic) -> Bool)
+             (currentTerm cp >>= fromTerm :: Maybe (SLogic, SLogic))
+
+somewhereOrG :: IsStrategy g => g (Context a) -> Strategy (Context a)
+somewhereOrG s =
+   let isOr a = case currentTerm a >>= (fromTerm :: Term -> Maybe SLogic) of
+                   Just (_ :||: _) -> True
+                   _               -> False
+   in fix $ \this -> check (Prelude.not . isOr) <*> s
+                 <|> check isOr <*> layer [] this
+
+----------------------
+
+ruleAbsorpOrNot :: Rule SLogic
+ruleAbsorpOrNot = rewriteRules "DistrOrNot"
+   [ -- not inside
+     \x y -> x :||: (Not x :&&: y)  :~>  (x :||: Not x) :&&: (x :||: y)
+   , \x y -> x :||: (y :&&: Not x)  :~>  (x :||: y) :&&: (x :||: Not x)
+   , \x y -> (Not x :&&: y) :||: x  :~>  (Not x :||: x) :&&: (y :||: x)
+   , \x y -> (y :&&: Not x) :||: x  :~>  (y :||: x) :&&: (Not x :||: x)
+     -- not outside
+   , \x y -> Not x :||: (x :&&: y)  :~>  (Not x :||: x) :&&: (Not x :||: y)
+   , \x y -> Not x :||: (y :&&: x)  :~>  (Not x :||: y) :&&: (Not x :||: x)
+   , \x y -> (x :&&: y) :||: Not x  :~>  (x :||: Not x) :&&: (y :||: Not x)
+   , \x y -> (y :&&: x) :||: Not x  :~>  (y :||: Not x) :&&: (x :||: Not x)
+   ]
+
+-- specialization of De Morgan rules with a not inside (gives higher priority)
+ruleDeMorganOrNot :: Rule SLogic
+ruleDeMorganOrNot = rewriteRules "DeMorganOrNot"
+   [ \x y -> Not (Not x :||: y)  :~>  Not (Not x) :&&: Not y
+   , \x y -> Not (x :||: Not y)  :~>  Not x :&&: Not (Not y)
+   ]
+
+ruleDeMorganAndNot :: Rule SLogic
+ruleDeMorganAndNot = rewriteRules "DeMorganAndNot"
+   [ \x y -> Not (Not x :&&: y)  :~>  Not (Not x) :||: Not y
+   , \x y -> Not (x :&&: Not y)  :~>  Not x :||: Not (Not y)
+   ]
+
+{-
+ruleAbsorpAndNot :: Rule SLogic
+ruleAbsorpAndNot = rewriteRules "AbsorpAndNot.distr"
+   [ -- not inside
+     \x y -> x :&&: (Not x :||: y)  :~>  (x :&&: Not x) :||: (x :&&: y)
+   , \x y -> x :&&: (y :||: Not x)  :~>  (x :&&: y) :||: (x :&&: Not x)
+   , \x y -> (Not x :||: y) :&&: x  :~>  (Not x :&&: x) :||: (y :&&: x)
+   , \x y -> (y :||: Not x) :&&: x  :~>  (y :&&: x) :||: (Not x :&&: x)
+     -- not outside
+   , \x y -> Not x :&&: (x :||: y)  :~>  (Not x :||: x) :&&: (Not x :||: y)
+   , \x y -> Not x :&&: (y :||: x)  :~>  (Not x :||: y) :&&: (Not x :||: x)
+   , \x y -> (x :||: y) :&&: Not x  :~>  (x :||: Not x) :&&: (y :||: Not x)
+   , \x y -> (y :||: x) :&&: Not x  :~>  (y :||: Not x) :&&: (x :||: Not x)
+   ] -}
+
+-----------------------------------------------------------------------------
+-- Inverse rules
+
+inverseRules :: [Rule (Context Proof)]
+inverseRules = map use [invDefImpl, invDefEquiv, invNotNot, invIdempOr, invIdempAnd,
+   invTrueZeroAnd, invNotTrue, invFalseZeroOr, invNotFalse] ++
+   [invAbsorpOr, invAbsorpAnd, invTrueZeroOr, invComplOr, invFalseZeroAnd, invComplAnd]
+
+invDefImpl :: Rule SLogic
+invDefImpl = rewriteRule "DefImpl.inv" $
+   \x y -> Not x :||: y  :~>  x :->: y
+
+invDefEquiv :: Rule SLogic
+invDefEquiv = rewriteRule "DefEquiv.inv" $
+   \x y -> (x :&&: y) :||: (Not x :&&: Not y)  :~>  x :<->: y
+
+invNotNot :: Rule SLogic
+invNotNot = rewriteRule "NotNot.inv" $
+   \x -> x  :~>  Not (Not x)
+
+invIdempOr :: Rule SLogic
+invIdempOr = rewriteRule "IdempOr.inv" $
+   \x -> x  :~>  x :||: x
+
+invIdempAnd :: Rule SLogic
+invIdempAnd = rewriteRule "IdempAnd.inv" $
+   \x -> x :&&: x  :~>  x
+
+invTrueZeroAnd :: Rule SLogic
+invTrueZeroAnd = rewriteRules "TrueZeroAnd.inv"
+   [ \x -> x  :~>  T :&&: x
+   , \x -> x  :~>  x :&&: T
+   ]
+
+invNotTrue :: Rule SLogic
+invNotTrue = rewriteRule "NotTrue.inv" $
+   F  :~>  Not T
+
+invFalseZeroOr :: Rule SLogic
+invFalseZeroOr = rewriteRules "FalseZeroOr.inv"
+   [ \x -> x  :~>  F :||: x
+   , \x -> x  :~>  x :||: F
+   ]
+
+invNotFalse :: Rule SLogic
+invNotFalse = rewriteRule "NotFalse.inv" $
+   T  :~> Not F
+
+makeInvRule :: String -> Rule SLogic -> Rule (Context Proof)
+makeInvRule name r = addRecognizerBool eq $ makeRule name (const Nothing)
+ where
+   eq :: Context Proof -> Context Proof -> Bool
+   eq a b = or [ True
+               | c <- applyAll (somewhere (use r)) b
+               , similarity ex a c
+               ]
+   ex = proofExercise
+
+invAbsorpOr, invAbsorpAnd, invTrueZeroOr, invComplOr, invFalseZeroAnd, invComplAnd :: Rule (Context Proof)
+invAbsorpOr     = makeInvRule "AbsorpOr.inv" ruleAbsorpOr
+invAbsorpAnd    = makeInvRule "AbsorpAnd.inv" ruleAbsorpAnd
+invTrueZeroOr   = makeInvRule "TrueZeroOr.inv" ruleTrueZeroOr
+invComplOr      = makeInvRule "ComplOr.inv" ruleComplOr
+invFalseZeroAnd = makeInvRule "FalseZeroAnd.inv" ruleFalseZeroAnd
+invComplAnd     = makeInvRule "ComplAnd.inv" ruleComplAnd
+ src/Domain/Logic/Rules.hs view
@@ -0,0 +1,236 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( extraLogicRules, ruleAbsorpAnd, ruleAbsorpOr, ruleAndOverOr
+   , ruleComplAnd, ruleComplOr, ruleDeMorganAnd, ruleDeMorganOr
+   , ruleDefEquiv, ruleDefImpl, ruleFalseInEquiv, ruleFalseInImpl
+   , ruleFalseZeroAnd, ruleFalseZeroOr, ruleIdempAnd, ruleIdempOr
+   , ruleNotFalse, ruleNotNot, ruleNotTrue, ruleTrueInEquiv
+   , ruleTrueInImpl, ruleTrueZeroAnd, ruleTrueZeroOr
+   ) where
+
+import Domain.Logic.Formula
+import Domain.Logic.GeneralizedRules
+import Domain.Logic.Generator()
+import Ideas.Common.Library hiding (ruleList)
+import qualified Ideas.Common.Library as C
+
+extraLogicRules :: [Rule SLogic]
+extraLogicRules =
+   [ ruleCommOr, ruleCommAnd, ruleAssocOr, ruleAssocAnd
+   , ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
+   , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame
+   , generalRuleOrOverAnd, ruleOrOverAnd
+   , inverseDeMorganOr, inverseDeMorganAnd
+   , inverseAndOverOr, inverseOrOverAnd
+   ]
+
+logic :: IsId a => a -> Id
+logic = ( # ) "logic.propositional"
+
+rule :: RuleBuilder f a => String -> f -> Rule a
+rule = C.rewriteRule . logic
+
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
+ruleList = C.rewriteRules . logic
+
+-----------------------------------------------------------------------------
+-- 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 = minor $ rule "AssocOr" $
+   \x y z -> (x :||: y) :||: z  :~>  x :||: (y :||: z)
+
+ruleAssocAnd :: Rule SLogic
+ruleAssocAnd = minor $ 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
+
+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::SLogic)  :~>  T
+ src/Domain/Logic/Strategies.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, somewhereOr
+   ) where
+
+import Domain.Logic.Formula
+import Domain.Logic.GeneralizedRules
+import Domain.Logic.Rules
+import Ideas.Common.Library
+
+-----------------------------------------------------------------------------
+-- To DNF, with priorities (the "DWA" approach)
+
+dnfStrategyDWA :: LabeledStrategy (Context SLogic)
+dnfStrategyDWA =  label "Bring to dnf (DWA)" $
+   repeatS $ toplevel <|> somewhereOr
+      (  label "Simplify"                            simpl
+      |> label "Eliminate implications/equivalences" eliminateImplEquiv
+      |> label "Eliminate nots"                      eliminateNots
+      |> label "Move ors to top"                     orToTop
+      )
+ where
+    toplevel = useRules
+       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
+       , ruleAbsorpOr, ruleComplOr
+       ]
+    simpl = 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 a = case currentInContext a of
+                   Just (_ :||: _) -> True
+                   _               -> False
+   in fix $ \this -> check (Prelude.not . isOr) <*> s
+                 <|> check isOr <*> layer [] this
+
+--check1, check2 :: (a -> Bool) -> Rule a
+--check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing
+--check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing
+
+-----------------------------------------------------------------------------
+-- 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 = repeatS $ oncetd $ useRules
+      [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
+      , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv
+      , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
+      ]
+   eliminateImplEquiv = repeatS $ oncebu $ useRules
+      [ ruleDefImpl, ruleDefEquiv
+      ]
+   eliminateNots = repeatS $ oncetd $
+      useRules
+         [ generalRuleDeMorganAnd, generalRuleDeMorganOr ]
+      |> useRules
+         [ ruleDeMorganAnd, ruleDeMorganOr
+         , ruleNotNot
+         ]
+   orToTop = repeatS $ somewhere $
+      liftToContext generalRuleAndOverOr |>
+      liftToContext ruleAndOverOr
+
+-- local helper function
+useRules :: [Rule SLogic] -> Strategy (Context SLogic)
+useRules = alternatives . map liftToContext
+ src/Domain/Logic/Views.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Views
+   ( (.<->.), (.->.), (.&&.), (.||.)
+   , simplify, pushNot, pushNotWith
+   , orView, andView
+   ) where
+
+import Domain.Logic.Formula
+import Ideas.Common.Algebra.SmartGroup
+import Ideas.Common.Id
+import Ideas.Common.View hiding (simplify)
+
+------------------------------------------------------------
+-- Smart constructors
+
+infixr 2 .<->.
+infixr 3 .->.
+
+(.<->.) :: Logic a -> Logic a -> Logic a
+T .<->. q = q
+F .<->. q = nott q
+p .<->. T = p
+p .<->. F = nott p
+p .<->. q = p :<->: q
+
+(.->.) :: Logic a -> Logic a -> Logic a
+T .->. q = q
+F .->. _ = T
+_ .->. T = T
+p .->. F = nott p
+p .->. q = p :->: q
+
+{- (.||.) :: Logic a -> Logic a -> Logic a
+T .||. _ = T
+F .||. q = q
+_ .||. T = T
+p .||. F = p
+p .||. q = p :||: q
+
+(.&&.) :: Logic a -> Logic a -> Logic a
+T .&&. q = q
+F .&&. _ = F
+p .&&. T = p
+_ .&&. F = F
+p .&&. q = p :&&: q -}
+
+nott :: Logic a -> Logic a
+nott (Not p) = p
+nott p       = Not p
+
+-------------------------------------------------
+-- Views and transformations
+
+simplify :: Logic a -> Logic a
+simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F)
+
+pushNotWith :: (a -> Logic a) -> Logic a -> Logic a
+pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F)
+ where
+   rec logic =
+      case logic of
+         Not p :<->: q -> p     .<->. q
+         p :<->: Not q -> p     .<->. q
+         p :<->: q     -> rec p .<->. q
+         p :->:  q     -> p     .&&.  rec q
+         p :||:  q     -> rec p .&&.  rec q
+         p :&&:  q     -> rec p .||.  rec q
+         Not p         -> p
+         T             -> F
+         F             -> T
+         Var a         -> f a
+
+pushNot :: Logic a -> Logic a
+pushNot = pushNotWith (nott . Var)
+
+orView :: View (Logic a) [a]
+orView = "logic.orView" @> makeView (($ []) . f) (foldr ((.||.) . Var) F)
+ where
+   f (p :||: q) = (>>= f p) .  f q
+   f (Var a)    = return . (a:)
+   f F          = return
+   f _          = const Nothing
+
+andView :: View (Logic a) [a]
+andView = "logic.andView" @> makeView (($ []) . f) (foldr ((.&&.) . Var) T)
+ where
+   f (p :&&: q) = (>>= f p) .  f q
+   f (Var a)    = return . (a:)
+   f T          = return
+   f _          = const Nothing
+ src/Domain/Math/Approximation.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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]
+
+------------------------------------------------------------
+-- Precision of a floating-point number
+
+precision :: Int -> Double -> Double
+precision n = (/a) . fromInteger . round . (*a)
+ where a = 10 Prelude.^ max 0 n
+
+------------------------------------------------------------
+-- 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 = iterate next
+ 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/CleanUp.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.CleanUp
+   ( cleanUpRelations, cleanUpRelation, cleanUpExpr
+   , cleanUpSimple, cleanUpView, cleanUpACView
+   , assocExpr, acExpr, smart, assocPlus, assocTimes
+   ) where
+
+import Control.Monad
+import Data.Foldable (foldMap)
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Data.Ratio
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Data.SquareRoot (fromSquareRoot)
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views (rationalView, integerView)
+import Domain.Math.Power.OldViews (powerFactorViewWith)
+import Domain.Math.SquareRoot.Views (squareRootViewWith)
+import Ideas.Common.Classes
+import Ideas.Common.Utils (fixpoint)
+import Ideas.Common.Utils.Uniplate
+import Ideas.Common.View
+import Prelude hiding ((^), recip)
+import qualified Prelude
+
+----------------------------------------------------------------------
+-- Root simplification
+
+simplerRoot :: Rational -> Integer -> Expr
+simplerRoot a b
+   | b < 0          = 1 ./. simplerRoot a (abs b)
+   | a < 0 && odd b = neg (simplerRoot (abs a) b)
+   | otherwise      = f (numerator a) b ./. f (denominator a) b
+ where
+   f x y
+      | x == 0              = 0
+      | y == 0 || x <= 0    = root (fromIntegral x) (fromIntegral y)
+      | e Prelude.^ y == x  = fromIntegral e
+      | otherwise           = root (fromIntegral x) (fromIntegral y)
+    where
+      e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y))
+
+------------------------------------------------------------
+-- Cleaning up
+
+cleanUpSimple :: Expr -> Expr
+cleanUpSimple = fixpoint (transform (smart . f))
+ where
+   f = simplifyWith (assocPlus rationalView) sumView
+
+cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr)
+cleanUpRelations = noDuplicates . foldMap cleanUpRelation
+
+cleanUpRelation :: Relation Expr -> OrList (Relation Expr)
+cleanUpRelation = f . fmap cleanUpBU
+ where
+   f rel
+      | any falsity (universe a ++ universe b) = false
+      | a == b    = fromBool (relationType rel `elem` equals)
+      | otherwise =
+           case (match rationalView a, match rationalView b) of
+              (Just r, Just s) -> fromBool (eval (relationType rel) r s)
+              _                -> singleton rel
+    where
+      (a, b) = (leftHandSide rel, rightHandSide rel)
+
+   equals =
+      [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately]
+
+   falsity :: Expr -> Bool
+   falsity (Sqrt e)  = maybe False (<0)  (match rationalView e)
+   falsity (_ :/: e) = maybe False (==0) (match rationalView e)
+   falsity _         = False
+
+-- also simplify square roots
+cleanUpExpr :: Expr -> Expr
+cleanUpExpr = fixpoint $
+   cleanUpBU . transform (simplify (squareRootViewWith rationalView))
+
+cleanUpView, cleanUpACView :: View Expr Expr
+cleanUpView   = makeView (return . cleanUpExpr) id
+cleanUpACView = makeView (return . acExpr . cleanUpExpr) id
+
+-- normalize expr with associativity and commutative rules for + and *
+assocExpr, acExpr :: Expr -> Expr
+assocExpr = normExpr id
+acExpr    = normExpr sort
+
+normExpr :: ([Expr] -> [Expr]) -> Expr -> Expr
+normExpr f = rec
+ where
+   rec expr =
+      case (from sumView expr, from productView expr) of
+         (xs, _) | length xs > 1 ->
+            to sumView $ f $ map rec xs
+         (_, (b, xs)) | length xs > 1 ->
+            to productView (b, f $ map rec xs)
+         _ ->
+            descend rec expr
+
+------------------------------------------------------------
+-- Associativity
+
+assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr]
+assocPlus  = assocOp (+)
+assocTimes = assocOp (*)
+
+assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr]
+assocOp op v = rec . map (simplify v)
+ where
+   rec (x:y:zs) =
+      case canonical v (op x y) of
+         Just a  -> rec (a:zs)
+         Nothing -> x:rec (y:zs)
+   rec xs = xs
+
+------------------------------------------------------------
+-- Fixpoint of a bottom-up traversal
+
+cleanUpBU :: Expr -> Expr
+cleanUpBU = {- fixpoint $ -} transform $ \e ->
+   simplify myView $
+   fromMaybe (smart e) $
+      canonical rationalView e
+    `mplus`
+      liftM (transform smart) (canonical specialSqrtOrder e)
+      -- Just simplify order of terms with square roots for now
+    `mplus` do
+      let f xs | length xs > 1 = return (assocPlus rationalView xs)
+          f _ = Nothing
+      canonicalWithM f sumView e
+    `mplus`
+      canonical myView e
+    `mplus` do
+      let f (b, xs) | length xs > 1 = return (b, assocTimes rationalView xs)
+          f _ = Nothing
+      canonicalWithM f simpleProductView e
+ where
+   myView = powerFactorViewWith rationalView
+
+specialSqrtOrder :: View Expr [Expr]
+specialSqrtOrder = toView sumView >>> makeView f id
+ where
+   make = match (squareRootViewWith rationalView)
+   g    = isNothing . fromSquareRoot . snd
+   f xs = do
+      ys <- mapM make xs
+      return $ map fst $ sortBy (comparing g) $ zip xs ys
+
+smart :: Expr -> Expr
+smart (a :*: b) = a .*. b
+smart (a :/: b) = a ./. b
+smart expr@(Sym s [x, y])
+   | isPowerSymbol s = x .^. y
+   | isRootSymbol  s = fromMaybe expr $
+        liftM2 simplerRoot (match rationalView x) (match integerView y)
+smart (Negate a) = neg a
+smart (a :+: b) = a .+. b
+smart (a :-: b) = a .-. b
+smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2
+smart e = e
+ src/Domain/Math/Data/DecimalFraction.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Decimal fractions: the denominator of such a fraction must a power of 10.
+-- Division in the Fractional type class is not safe.
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.DecimalFraction
+   ( DecimalFraction(..), fromDouble, validDivisor, digits
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Ratio
+import Domain.Math.Safe
+
+import Test.QuickCheck
+
+-- |Data type for decimal fractions
+newtype DecimalFraction = DF Rational -- Invariant: denominator is valid
+   deriving (Eq, Ord, Num, Real, Arbitrary)
+
+instance Show DecimalFraction where
+   show d@(DF r) = show x ++ "." ++ replicate extra '0' ++ show y
+    where
+      digs   = digits d
+      base   = 10^digs
+      n      = numerator (r * fromInteger base)
+      (x, y) = n `divMod` base
+      extra  = digs - length (show y)
+
+instance Fractional DecimalFraction where
+   a/b = fromMaybe (error "invalid divisor") (safeDiv a b)
+   fromRational r = fromInteger (numerator r) / fromInteger (denominator r)
+
+instance SafeDiv DecimalFraction where
+   safeDiv (DF a) (DF b) = do
+      guard (validDivisor (DF b))
+      liftM DF (a `safeDiv` b)
+
+instance SafePower DecimalFraction where
+   safePower x (DF r)
+      | denominator r /= 1 = Nothing
+      | y >= 0             = Just a
+      | otherwise          = safeDiv 1 a
+    where
+      y = numerator r
+      a = x Prelude.^ abs y
+   safeRoot x y = safeRecip y >>= safePower x
+
+-- | Approximation of a double, with a precision of 8 digits
+fromDouble :: Double -> DecimalFraction
+fromDouble d = DF (fromInteger base / 10^digs)
+ where
+   digs = 8 :: Int -- maximum number of digits
+   base = round (d * 10^digs) :: Integer
+
+-- |Tests whether it is safe to divide by this fraction: it is safe to divide
+-- if its numerator(!) is a product of two's and five's.
+validDivisor :: DecimalFraction -> Bool
+validDivisor (DF a) = validDenominator (abs (numerator a))
+
+-- |number of decimal digits
+digits :: DecimalFraction -> Int
+digits (DF r) = head $ filter p [0..]
+ where
+   p i = 10^i `mod` denominator r == 0
+
+-- local helper
+validDenominator :: Integer -> Bool
+validDenominator n
+   | n == 0         = False
+   | even n         = validDenominator (n `div` 2)
+   | n `mod` 5 == 0 = validDenominator (n `div` 5)
+   | otherwise      = n == 1
+ src/Domain/Math/Data/Interval.hs view
@@ -0,0 +1,310 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 mathematical intervals (open, closed, unbounded). @Interval@
+-- is a normalized (and sorted) list of intervals that supports testing for
+-- equality (provided that there is a valid ordering on the elements).
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.Interval
+   ( -- * Data types
+     Interval, Endpoint(..)
+     -- * Interval constructors
+   , empty, point, unbounded, open, closed
+   , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo
+   , lessThan, lessThanOrEqualTo, true, false
+     -- * Interval combinators
+   , except, union, intersect, complement
+     -- * Inspecing an interval
+   , segments, isIn
+     -- * QuickChecks
+   , testMe
+   ) where
+
+import Control.Monad
+import Data.List (intercalate)
+import Data.Maybe
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Algebra.BooleanLaws
+import Ideas.Common.Algebra.Law
+import Ideas.Common.Utils.TestSuite
+import Test.QuickCheck
+
+--------------------------------------------------------------------
+-- Data declarations
+
+newtype Interval a = I [Segment a]
+   deriving Eq
+
+data Segment a = S (Endpoint a) (Endpoint a)
+   deriving Eq
+
+data Endpoint a = Excluding a | Including a | Unbounded
+   deriving (Eq,Show)
+
+instance Ord a => BoolValue (Interval a) where
+   fromBool b = if b then unbounded else empty
+   isTrue   = (==true)
+   isFalse  = (==false)
+
+instance Ord a => Boolean (Interval a) where
+   (<&&>)     = intersect
+   (<||>)     = union
+   complement = complementIntervals
+
+instance Show a => Show (Interval a) where
+   show (I xs) = "{ " ++ intercalate ", " (map show xs) ++ " }"
+
+instance Show a => Show (Segment a) where
+   show (S a b) = showLeft a ++ "," ++ showRight b
+
+instance Functor Endpoint where
+   fmap f (Excluding a) = Excluding (f a)
+   fmap f (Including a) = Including (f a)
+   fmap _ Unbounded     = Unbounded
+
+showLeft, showRight :: Show a => Endpoint a -> String
+showLeft  (Excluding a) = '(' : show a
+showLeft  (Including a) = '[' : show a
+showLeft  Unbounded     = "(-inf"
+showRight (Excluding a) = show a ++ ")"
+showRight (Including a) = show a ++ "]"
+showRight Unbounded     = "inf)"
+
+--------------------------------------------------------------------
+-- Interval constructors
+
+empty :: Interval a
+empty = I []
+
+point :: a -> Interval a
+point a = I [S (Including a) (Including a)]
+
+unbounded :: Ord a => Interval a
+unbounded = makeInterval Unbounded Unbounded
+
+open :: Ord a => a -> a -> Interval a
+open a b = makeInterval (Excluding a) (Excluding b)
+
+closed :: Ord a => a -> a -> Interval a
+closed a b = makeInterval (Including a) (Including b)
+
+leftOpen :: Ord a => a -> a -> Interval a
+leftOpen a b = makeInterval (Excluding a) (Including b)
+
+rightOpen :: Ord a => a -> a -> Interval a
+rightOpen a b = makeInterval (Including a) (Excluding b)
+
+greaterThan :: Ord a => a -> Interval a
+greaterThan a = makeInterval (Excluding a) Unbounded
+
+greaterThanOrEqualTo :: Ord a => a -> Interval a
+greaterThanOrEqualTo a = makeInterval (Including a) Unbounded
+
+lessThan :: Ord a => a -> Interval a
+lessThan a = makeInterval Unbounded (Excluding a)
+
+lessThanOrEqualTo :: Ord a => a -> Interval a
+lessThanOrEqualTo a = makeInterval Unbounded (Including a)
+
+-- local constructor
+makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a
+makeInterval pl pr = maybe empty (I . return) (makeSegment pl pr)
+
+makeSegment :: Ord a => Endpoint a -> Endpoint a -> Maybe (Segment a)
+makeSegment pl pr =
+   case liftM2 compare (getPoint pl) (getPoint pr) of
+      Just EQ
+         | isExcluding pl -> Nothing
+         | isExcluding pr -> Nothing
+      Just GT             -> Nothing
+      _ -> Just (S pl pr)
+
+isIncluding :: Endpoint a -> Bool
+isIncluding (Including _) = True
+isIncluding _             = False
+
+isExcluding :: Endpoint a -> Bool
+isExcluding (Excluding _) = True
+isExcluding _             = False
+
+--------------------------------------------------------------------
+-- Inspecting an interval
+
+segments :: Interval a -> [(Endpoint a, Endpoint a)]
+segments (I xs) = [ (a, b) | S a b <- xs ]
+
+--------------------------------------------------------------------
+-- Combining multiple intervals
+
+except :: Ord a => a -> Interval a
+except a = lessThan a <||> greaterThan a
+
+insert :: Ord a => Segment a -> Interval a -> Interval a
+insert ia (I xs) = I (rec ia xs)
+ where
+   rec iv [] = [iv]
+   rec iv@(S a _) (hd@(S b _):rest) =
+      case merge iv hd of
+         Just new -> rec new rest
+         Nothing
+            | minPointLeft b a == b -> hd:rec iv rest
+            | otherwise             -> iv:hd:rest
+
+union :: Ord a => Interval a -> Interval a -> Interval a
+union xs (I ys) = foldr insert xs ys
+
+intersect :: Ord a => Interval a -> Interval a -> Interval a
+intersect (I xs) (I ys) = I (f xs ys)
+ where
+   f (a@(S _ ar):as) (b@(S _ br):bs) =
+      let cond = maxPointRight ar br == ar
+          rest | cond      = f (a:as) bs
+               | otherwise = f as (b:bs)
+      in maybe id (:) (inBoth a b) rest
+   f _ _ = []
+
+complementIntervals :: Ord a => Interval a -> Interval a
+complementIntervals (I xs)
+   | null xs   = unbounded
+   | otherwise = I $ catMaybes $
+        left (head xs) : zipWith f xs (drop 1 xs) ++ [right (last xs)]
+ where
+   f (S _ a) (S b _) = liftM2 S (g a) (g b)
+
+   g (Including a) = Just (Excluding a)
+   g (Excluding a) = Just (Including a)
+   g Unbounded     = Nothing
+
+   left  (S al _) = fmap (S Unbounded) (g al)
+   right (S _ ar) = fmap (flip S Unbounded) (g ar)
+
+isIn :: Ord a => a -> Interval a -> Bool
+isIn a (I xs) = any p xs
+ where
+   p (S x y) = f GT x && f LT y
+   f value b =
+      let g c = (c==EQ && isIncluding b) || c==value
+      in maybe True (g . compare a) (getPoint b)
+
+---------------------------------------------------------------------
+-- Local helper functions
+
+getPoint :: Endpoint a -> Maybe a
+getPoint (Including a) = Just a
+getPoint (Excluding a) = Just a
+getPoint Unbounded     = Nothing
+
+merge :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
+merge ia@(S al ar) ib@(S bl br)
+   | minPointLeft al bl /= al = merge ib ia
+   | otherwise =
+        case liftM2 compare (getPoint ar) (getPoint bl) of
+           Just LT -> Nothing
+           Just EQ | isExcluding ar && isExcluding bl -> Nothing
+           _ -> Just (S al (maxPointRight ar br))
+
+inBoth :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
+inBoth (S al ar) (S bl br) =
+   makeSegment (maxPointLeft al bl) (minPointRight ar br)
+
+minPointLeft, minPointRight, maxPointLeft, maxPointRight
+   :: Ord a => Endpoint a -> Endpoint a -> Endpoint a
+minPointLeft  = compareEndpoint True  True
+minPointRight = compareEndpoint True  False
+maxPointLeft  = compareEndpoint False False
+maxPointRight = compareEndpoint False True
+
+compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a
+compareEndpoint b1 b2 a b =
+   case liftM2 compare (getPoint a) (getPoint b) of
+      Just LT                -> x
+      Just EQ | p a          -> x
+              | otherwise    -> y
+      Just GT                -> y
+      Nothing | b2           -> Unbounded
+              | x==Unbounded -> y
+              | otherwise    -> x
+ where
+   p = if b1==b2 then isIncluding else isExcluding
+   (x, y) = if b1 then (a, b) else (b, a)
+
+---------------------------------------------------------------------
+-- QuickCheck
+
+instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where
+   arbitrary = frequency
+      [ (2, liftM Excluding arbitrary)
+      , (2, liftM Including arbitrary)
+      , (1, return Unbounded)
+      ]
+instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where
+   coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a
+   coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a
+   coarbitrary Unbounded     = variant (2 :: Int)
+
+instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where
+   arbitrary = do
+      n  <- choose (0, 100)
+      xs <- replicateM n (liftM2 makeInterval arbitrary arbitrary)
+      return (ors xs)
+
+instance (CoArbitrary a, Ord a) => CoArbitrary (Segment a) where
+   coarbitrary (S a b) = coarbitrary a . coarbitrary b
+
+instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where
+   coarbitrary (I xs) = coarbitrary xs
+
+testMe :: TestSuite
+testMe = suite "Intervals" $ do
+
+   suite "Constructor functions" $ do
+     addProperty "empty"     $ op0 empty     (const False)
+     addProperty "unbounded" $ op0 unbounded (const True)
+
+     addProperty "greater than"             $ op1 greaterThan (>)
+     addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)
+     addProperty "less than"                $ op1 lessThan (<)
+     addProperty "less than or equal to"    $ op1 lessThanOrEqualTo (<=)
+     addProperty "point    "                $ op1 point (==)
+
+     addProperty "open"       $ op2 open      (<)  (<)
+     addProperty "closed"     $ op2 closed    (<=) (<=)
+     addProperty "left open"  $ op2 leftOpen  (<)  (<=)
+     addProperty "right open" $ op2 rightOpen (<=) (<)
+
+   suite "Combinators" $ do
+      addProperty "except"     defExcept
+      addProperty "union"      defUnion
+      addProperty "intersect"  defIntersect
+      addProperty "complement" defComplement
+
+   suite "Boolean algebra" $
+      forM_ (booleanLaws :: [Law (Interval Int)]) $ \p ->
+         addProperty (show p) p
+
+defExcept :: Int -> Int -> Bool
+defExcept a b = isIn a (except b) == (a/=b)
+
+defUnion, defIntersect :: Int -> Interval Int -> Interval Int -> Bool
+defUnion     a b c = isIn a (b `union` c) == (isIn a b || isIn a c)
+defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c)
+
+defComplement :: Int -> Interval Int -> Bool
+defComplement a b = isIn a (complement b) == not (isIn a b)
+
+op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool
+op0 g p a = isIn a g == p a
+
+op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool
+op1 g op a b = isIn a (g b) == (a `op` b)
+
+op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool
+op2 g opl opr a b c = isIn a (g b c) == (b `opl` a && a `opr` c)
+ src/Domain/Math/Data/MixedFraction.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Signed mixed fractions (also known as mixed numbers):
+-- for example, 5[1/4] or -3[2/5]
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.MixedFraction
+   ( MixedFraction, wholeNumber, fractionPart, numerator, denominator
+   ) where
+
+import qualified Data.Ratio as R
+
+newtype MixedFraction = MF { unMF :: Rational }
+   deriving (Eq, Ord, Num, Fractional, Real, RealFrac)
+
+instance Show MixedFraction where
+   show mf
+      | b == 0    = sign ++ show a
+      | a == 0    = sign ++ show b ++ "/" ++ show c
+      | otherwise = sign ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]"
+    where
+      (a, b, c) = (wholeNumber mf, numerator mf, denominator mf)
+      sign = if mf < 0 then "-" else ""
+
+-- | Always positive
+wholeNumber :: MixedFraction -> Integer
+wholeNumber = fst . properMF
+
+-- | Always positive
+fractionPart :: MixedFraction -> Rational
+fractionPart = snd . properMF
+
+-- | Always positive
+numerator :: MixedFraction -> Integer
+numerator = R.numerator . fractionPart
+
+-- | Always positive
+denominator :: MixedFraction -> Integer
+denominator = R.denominator . fractionPart
+
+-- local helper
+properMF :: MixedFraction -> (Integer, Rational)
+properMF = properFraction . abs . unMF
+ src/Domain/Math/Data/OrList.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, OrSet, true, false, (<>)
+   , isTrue, isFalse, fromBool, toOrList
+   , noDuplicates, catOrList
+   , oneDisjunct, orListView, orSetView
+   ) where
+
+import Control.Applicative
+import Control.Monad (liftM2)
+import Data.Foldable (Foldable, foldMap, toList)
+import Data.List
+import Data.Traversable (Traversable, traverse)
+import Domain.Logic.Formula (Logic((:||:)))
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Algebra.Group
+import Ideas.Common.Classes
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+import Test.QuickCheck
+import qualified Data.Set as S
+import qualified Domain.Logic.Formula as Logic
+
+instance Functor OrList where
+   fmap f (OrList a) = OrList (fmap (map f) a)
+
+instance Foldable OrList where
+   foldMap f (OrList a) = maybe mempty (foldMap f) (fromWithZero a)
+
+instance Traversable OrList where
+   traverse f (OrList a) =
+      maybe (pure mzero) (liftA toOrList . traverse f) (fromWithZero a)
+
+------------------------------------------------------------
+-- OrList data type
+
+newtype OrList a = OrList (WithZero [a]) deriving
+   (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero)
+
+instance BoolValue (OrList a) where
+   fromBool b = if b then mzero else mempty
+   isTrue  = isMonoidZero
+   isFalse = isEmpty
+
+instance Container OrList where
+   singleton = OrList . pure . singleton
+   getSingleton (OrList a) = fromWithZero a >>= getSingleton
+
+instance IsTerm a => IsTerm (OrList a) where
+   toTerm = toTerm . build orListView
+   fromTerm expr = fromTerm expr >>= matchM orListView
+
+instance Arbitrary a => Arbitrary (OrList a) where
+   arbitrary = do
+      n  <- choose (1, 3)
+      xs <- vector n
+      return (toOrList xs)
+
+instance Show a => Show (OrList a) where
+   show xs | isTrue  xs = "true"
+           | isFalse xs = "false"
+           | otherwise  = f xs
+    where
+      f = unwords . intersperse "or" . map show . toList
+
+------------------------------------------------------------
+-- Functions
+
+-- | Remove duplicates
+noDuplicates :: Eq a => OrList a -> OrList a
+noDuplicates (OrList a) = OrList (fmap nub a)
+
+oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a)
+oneDisjunct f (OrList a) =
+   case fromWithZero a of
+      Just [x] -> f x
+      _ -> fail "oneDisjunct"
+
+------------------------------------------------------------
+-- OrSet data type
+
+newtype OrSet a = OrSet (WithZero (S.Set a)) deriving
+   (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero)
+
+instance (Show a, Ord a) => Show (OrSet a) where
+   show = show . build orSetView
+
+instance Ord a => BoolValue (OrSet a) where
+   fromBool b = if b then mzero else mempty
+   isTrue  = isMonoidZero
+   isFalse = isEmpty
+
+instance Container OrSet where
+   singleton = OrSet . pure . singleton
+   getSingleton (OrSet a) = fromWithZero a >>= getSingleton
+
+------------------------------------------------------------
+-- View to the logic data type
+
+toOrList :: [a] -> OrList a
+toOrList = mconcat . map singleton
+
+orListView :: View (Logic a) (OrList a)
+orListView = makeView f g
+ where
+   f p  = case p of
+             Logic.Var a -> return (singleton a)
+             Logic.T     -> return true
+             Logic.F     -> return false
+             a :||: b    -> liftM2 mappend (f a) (f b)
+             _           -> Nothing
+   g = fromOr . foldOrListWith (Or . Logic.Var)
+
+orSetView :: Ord a => View (OrList a) (OrSet a)
+orSetView = makeView (Just . f) g
+ where
+   f (OrList xs) = OrSet  (fmap S.fromList xs)
+   g (OrSet  xs) = OrList (fmap S.toList xs)
+
+foldOrList :: MonoidZero a => OrList a -> a
+foldOrList xs
+   | isTrue xs  = mzero
+   | isFalse xs = mempty
+   | otherwise  = foldr1 (<>) (toList xs)
+
+foldOrListWith :: MonoidZero b => (a -> b) -> OrList a -> b
+foldOrListWith f = foldOrList . fmap f
+
+{-
+foldOrListF :: (MonoidZero (f a), Container f) => OrList a -> f a
+foldOrListF = foldOrListWith to -}
+
+catOrList :: OrList (OrList a) -> OrList a
+catOrList = foldOrList
+ src/Domain/Math/Data/Polynomial.hs view
@@ -0,0 +1,295 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, toPolynomial, fromPolynomial, var, con, raise
+   , degree, lowestDegree, coefficient
+   , isRoot, positiveRoots, negativeRoots
+   , derivative, eval, polynomialGCD, factorize
+   , testPolynomials
+   ) where
+
+import Control.Applicative (Applicative, (<$>), liftA)
+import Control.Monad
+import Data.Char
+import Data.Foldable (Foldable, foldMap)
+import Data.Ratio
+import Data.Traversable (Traversable, sequenceA)
+import Domain.Math.Data.Primes
+import Domain.Math.Safe
+import Ideas.Common.Classes
+import Ideas.Common.Utils.TestSuite
+import Test.QuickCheck
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+
+------------------------------------------------------------------
+-- Data type:
+--   Invariant: all keys are non-negative, all values are non-zero
+--   (note that the second part of the invariant (zero values)
+--    can be violated using the functor instance)
+
+newtype Polynomial a = P { unsafeP :: IM.IntMap a }
+
+invariant :: (Eq a,Num a) => IM.IntMap a -> IM.IntMap a
+invariant = IM.filterWithKey (\n a -> n >= 0 && a /= 0)
+
+makeP :: (Eq a,Num a) => IM.IntMap a -> Polynomial a
+makeP = P . invariant
+
+unP :: (Eq a,Num a) => Polynomial a -> IM.IntMap a
+unP = invariant . unsafeP
+
+toPolynomial :: (Eq a,Num a) => [a] -> Polynomial a
+toPolynomial = makeP . IM.fromAscList . zip [0..] . reverse
+
+fromPolynomial :: (Eq a,Num a) => Polynomial a -> [a]
+fromPolynomial p = map (`coefficient` p) [d, d-1 .. 0]
+ where d = degree p
+
+-------------------------------------------------------------------
+-- Instances
+
+instance (Eq a,Num a) => Eq (Polynomial a) where
+   p1 == p2 = unP p1 == unP p2
+
+instance (Eq a,Show a,Num a) => Show (Polynomial a) where
+   show p
+      | p ==0     = "f(x) = 0"
+      | otherwise = "f(x) = " ++ fix (concatMap f (reverse (IM.toList (unP p))))
+    where
+      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
+
+instance (Eq a,Fractional a) => SafeDiv (Polynomial a) where
+   -- polynomial division, no remainder
+   safeDiv p1 p2
+      | p2==0     = Nothing
+      | degree p1 < degree p2 = Nothing
+      | b==0      = return a
+      | otherwise = Nothing
+    where
+      (a, b) = divModPoly p1 p2
+
+-- the Functor instance does not maintain the invariant
+instance Functor Polynomial where
+   fmap f = P . IM.map f . unsafeP
+
+instance Foldable Polynomial where
+   foldMap f = foldMap f . unsafeP
+
+instance Traversable Polynomial where
+   sequenceA = liftA P . sequenceIntMap . unsafeP
+
+instance (Eq a,Num a) => Num (Polynomial a) where
+   p1 + p2 = makeP $ IM.unionWith (+) (unP p1) (unP p2)
+   p1 * p2 = sum [ raise i (fmap (*a) p1) | (i, a) <- IM.toList (unP p2) ]
+
+   {- makeP $ foldr (uncurry op) IM.empty list
+    where
+      op   = IM.insertWith (+)
+      list = [ (i+j, a*b) | (a, i) <- terms p1, (b, j) <- terms p2 ] -}
+   negate      = fmap negate
+   fromInteger = makeP . IM.singleton 0 . fromInteger
+   -- not defined for polynomials
+   abs    = error "abs not defined for polynomials"
+   signum = error "signum not defined for polynomials"
+
+instance (Eq a,Arbitrary a, Num a) => Arbitrary (Polynomial a) where
+   arbitrary = do
+      d <- choose (0, 5)
+      let f n x = con x * var ^ n
+      liftM (sum . zipWith f [0::Int ..]) (vector (d+1))
+
+-------------------------------------------------------------------
+-- Functions on polynomials
+
+-- a single variable (such as "x")
+var :: (Eq a,Num a) => Polynomial a
+var = makeP (IM.singleton 1 1)
+
+con :: (Eq a,Num a) => a -> Polynomial a
+con = makeP . IM.singleton 0
+
+-- | Raise all powers by a constant (discarding negative exponents)
+raise :: (Eq a,Num a) => Int -> Polynomial a -> Polynomial a
+raise i = makeP . IM.fromAscList . map (mapFirst (+i)) . IM.toList . unP
+
+------------------------------------------------
+
+degree :: (Eq a,Num a) => Polynomial a -> Int
+degree p
+   | IS.null is = 0
+   | otherwise  = IS.findMax is
+ where is = IM.keysSet (unP p)
+
+lowestDegree :: (Eq a,Num a) => Polynomial a -> Int
+lowestDegree p
+   | IS.null is = 0
+   | otherwise  = IS.findMin is
+ where is = IM.keysSet (unP p)
+
+coefficient :: (Eq a,Num a) => Int -> Polynomial a -> a
+coefficient n = IM.findWithDefault 0 n . unP
+
+isRoot :: (Eq a,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 :: (Eq a,Num a) => Polynomial a -> Int
+positiveRoots = signChanges . IM.elems . unP
+
+-- Returns the maximal number of negative roots (Descartes theorem)
+-- Multiple roots are counted separately
+negativeRoots :: (Eq a,Num a) => Polynomial a -> Int
+negativeRoots = signChanges . flipOdd . IM.elems . unP
+ where
+   flipOdd (x:y:zs) = x:negate y:flipOdd zs
+   flipOdd xs = xs
+
+signChanges :: (Eq a,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 :: (Eq a,Num a) => Polynomial a -> Polynomial a
+derivative p = makeP $ IM.fromAscList
+   [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList (unP p) ]
+
+eval :: (Eq a,Num a) => Polynomial a -> a -> a
+eval p x = sum [ a * x^n | (n, a) <- IM.toList (unP p) ]
+
+-- polynomial long division
+divModPoly :: (Eq a,Fractional a) => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a)
+divModPoly p1 p2 = mapBoth toPolynomial $
+   longDivision (fromPolynomial p2) (fromPolynomial p1)
+
+-- use polynomial long division to compute the greatest common factor
+-- of the polynomials
+polynomialGCD :: (Eq a,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 (divModPoly a b))
+
+------------------------
+
+factorize :: Polynomial Rational -> [Polynomial Rational]
+factorize = map toPolynomial . make . fromPolynomial
+ where
+   make ps
+      | null ps      = [[]]
+      | head ps == 0 = make (tail ps)
+      | last ps == 0 = [1, 0] : make (init ps)
+      | otherwise    = rec ps $ possibleRoots (last is) (head is)
+    where
+      is = toInts ps
+
+   rec ps [] = [ ps | ps /= [1] ]
+   rec ps list@(r:rs)
+      | b == 0     = [1, -r] : rec qs list
+      | otherwise  = rec ps rs
+    where
+      (qs, b) = syntheticDivision r ps
+
+toInts :: [Rational] -> [Int]
+toInts ps = map (`div` a) is
+ where
+   is  = map f ps
+   d   = foldr1 lcm (map denominator ps)
+   f x = fromIntegral $ (numerator x * d) `div` denominator x
+   a   = foldr1 gcd is
+
+possibleRoots :: Int -> Int -> [Rational]
+possibleRoots a b = reverse (map negate xs) ++ xs
+ where
+   xs  = map f (factors (abs a)) -- or: factors (abs (a*b))
+   f x = toRational x / toRational b
+
+-- TODO: replace me by sequenceA
+-- This definition is for backwards compatibility. In older versions of IntMap,
+-- the instance for Traversable is lacking.
+sequenceIntMap :: Applicative m => IM.IntMap (m a) -> m (IM.IntMap a)
+sequenceIntMap m = IM.fromDistinctAscList <$> zip ks <$> sequenceA as
+ where
+   (ks, as) = unzip (IM.toList m)
+
+---------------------------------------------------------------
+-- Algorithms for synthetic and long division
+
+{- syntheticDivision a p: divide polynomial p by (x-a)
+   Example:
+
+      -3|  1   7    11  -3
+              -3   -12   3
+      -------------------- +
+           1   4    -1   0   (last number is remainder)
+   -}
+syntheticDivision :: Num a => a -> [a] -> ([a], a)
+syntheticDivision a xs = (init zs, last zs)
+ where
+   ys = 0 : map (*a) zs
+   zs = zipWith (+) xs ys
+
+{- longDivision p q: divide polynomial q by p
+   Example:
+
+      x+3|   1   10   24
+             1    3          (1x)
+             ----------- -
+                  7   24     (7x)
+                  7   21
+                  ------ -
+                       3    (remainder)
+   -}
+longDivision :: (Eq a,Fractional a) => [a] -> [a] -> ([a], [a])
+longDivision []     = error "longDivision by zero"
+longDivision (0:xs) = longDivision xs
+longDivision (x:xs) = recN
+ where
+   recN ys = rec (length ys - length xs) ys
+
+   rec n (y:ys) | n > 0 =
+      let d  = y/x
+          zs = zipWith (-) ys (map (*d) xs ++ repeat 0)
+      in mapFirst (d:) (rec (n-1) zs)
+   rec _ ys = ([], ys)
+
+---------------------------------------------------------------
+-- Properties
+
+testPolynomials :: TestSuite
+testPolynomials = suite "polynomial" $
+   addProperty "factorization" $ do
+      i  <- choose (0, 5)
+      as <- replicateM i $ choose (-20, 20)
+      b  <- choose (1, 30)
+      c  <- choose (-10*b, 10*b)
+      let qs = [ var - con (fromInteger a) | a <- as ]
+          p  = con (fromInteger c/fromInteger b) * product qs
+          ps = factorize p
+      return (all ((<= 1) . degree) ps && product ps == p)
+ src/Domain/Math/Data/PrimeFactors.hs view
@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   , splitPower, greatestPower, allPowers
+   ) where
+
+import Data.Maybe
+import Domain.Math.Data.Primes
+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 a
+   | a == 0    = IM.singleton 0 1
+   | otherwise = rec $ primeFactors $ abs $ fromInteger a
+ where
+   rec []     = IM.empty
+   rec (x:xs) = IM.insert x (length ys + 1) (rec zs)
+    where
+      (ys, zs) = break (/= x) xs
+
+fromFactors :: Factors -> Integer
+fromFactors = product . map f . IM.toList
+ where f (a, i) = toInteger a ^ toInteger i
+
+-------------------------------------------------------------
+-- 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)
+   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
+
+-- brute force, ugly
+greatestPower :: Integer -> Maybe (Integer, Integer)
+greatestPower n = f 2 1
+  where
+    f b e | n == b ^ e = Just (b, e)
+          | b > n      = Nothing
+          | b ^ e > n  = f (b + 1) 1
+          | otherwise  = f b (e + 1)
+
+-- -- n == a^x with (a,x) == greatestPower n
+-- prop_greatestPower n = traceShow n $
+--    maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n
+
+allPowers :: Integer -> [(Integer, Integer)]
+allPowers n = do
+  (b, e) <- maybeToList $ greatestPower n
+  let f i = let (a, r) = e `divMod` i
+            in if a > 1 && r == 0 then Just (b^i, a) else Nothing
+  mapMaybe f [1..e]
+
+-- prop_allPowers n = traceShow n $
+--   and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n))
+
+-- 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 "PrimeFactors: 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/Primes.hs view
@@ -0,0 +1,175 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Calculating prime numbers and prime factors
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.Primes
+   ( primes, isPrime, coprime, primeFactors, factors
+   , testPrimes
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Ideas.Common.Utils.TestSuite
+import Test.QuickCheck
+import qualified Data.Sequence as S
+
+------------------------------------------------------------
+-- | All prime numbers smaller than 1000
+
+-- | An infinite list of prime numbers
+primes :: [Int]
+primes = 1 : 2 : 3 : 5 : sieve (candidates 7)
+
+-- | All prime factors of a number
+primeFactors :: Int -> [Int]
+primeFactors n
+   | n > 0     = rec (tail primes1000) n
+   | otherwise = error "primeFactors: non-positive argument"
+ where
+   rec [] a
+      | a < 1000000 = [a] -- primes up to 1000 have been checked
+      | otherwise   = sort (rhos a)
+   rec list@(p:ps) a
+      | a == 1    = []
+      | m == 0    = p : rec list d
+      | otherwise = rec ps a
+    where
+      (d, m) = a `divMod` p
+
+   rhos a =
+      case pollardsRho a of
+         Just d  -> rhos d ++ rhos (a `div` d)
+         Nothing -> [a] -- probably a prime
+
+primes1000 :: [Int]
+primes1000 =
+   [1,2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97
+   ,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193
+   ,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307
+   ,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421
+   ,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,547
+   ,557,563,569,571,577,587,593,599,601,607,613,617,619,631,641,643,647,653,659
+   ,661,673,677,683,691,701,709,719,727,733,739,743,751,757,761,769,773,787,797
+   ,809,811,821,823,827,829,839,853,857,859,863,877,881,883,887,907,911,919,929
+   ,937,941,947,953,967,971,977,983,991,997]
+
+-- Pollard's rho algorithm
+--    see http://en.wikipedia.org/wiki/Pollard_rho
+pollardsRho :: Int -> Maybe Int
+pollardsRho n = msum (map try [1..10]) -- ten attempts
+ where
+   try :: Int -> Maybe Int
+   try c = rec 2 2 1
+    where
+      rec :: Int -> Int -> Int -> Maybe Int
+      rec x y d
+         | d == 1    = rec nx ny (abs (nx-ny) `gcd` n)
+         | d == n    = Nothing
+         | otherwise = Just d -- a non-trivial factor of n
+       where
+         nx = f x
+         ny = f (f y)
+
+      f :: Int -> Int
+      f x = (x*x+c) `mod` n
+
+-- | Testing for primality
+isPrime :: Int -> Bool
+isPrime a =
+   case primeFactors a of
+      b:_ -> a == b
+      _   -> True
+
+-- | Two numbers are coprime if they do not share a prime factor
+coprime :: Int -> Int -> Bool
+coprime = rec `on` primeFactors
+ where
+   rec xs@(x:xr) ys@(y:yr) =
+      case compare x y of
+         LT -> rec xr ys
+         EQ -> False
+         GT -> rec xs yr
+   rec _ _ = True
+
+-- | All factors of a (positive) number
+factors :: Int -> [Int]
+factors = sort . rec . primeFactors . abs
+ where
+   rec []     = [1]
+   rec (x:xs) = [ a*b | b <- take n (powers x), a <- rec zs ]
+    where
+      (ys, zs) = break (/= x) xs
+      n = 2 + length ys
+
+-- helper functions
+sieveSlow :: [Int] -> [Int]
+sieveSlow []     = []
+sieveSlow (x:xs) = x : sieveSlow (filter (noDivisorOf x) xs)
+
+sieve :: [Int] -> [Int]
+sieve = rec S.empty
+ where
+   rec _ [] = []
+   rec q (x:xs) =
+      case S.viewl q of
+         (y:ys) S.:< qr | x == y ->
+            rec qr (ys `removeFrom` xs)
+         _ -> x : rec (q S.|> map (*x) (candidates x)) xs
+
+   -- remove a sorted list from another list
+   removeFrom xs@(x:xr) ys@(y:yr) =
+      case compare x y of
+         LT -> removeFrom xr ys
+         EQ -> removeFrom xr yr
+         GT -> y:removeFrom xs yr
+   removeFrom _ _ = []
+
+-- infinite list starting from n, without factors of 2, 3, or 5
+candidates :: Int -> [Int]
+candidates n = dropWhile (< n)
+   [ 30*k+i | k <- [n `div` 30..], i <- [1,7,11,13,17,19,23,29] ]
+
+divisorOf :: Int -> Int -> Bool
+divisorOf x y = y `mod` x == 0
+
+noDivisorOf :: Int -> Int -> Bool
+noDivisorOf x y = y `mod` x /= 0
+
+powers :: Int -> [Int]
+powers a = iterate (*a) 1
+
+-- a trusted implementation
+primesSlow :: [Int]
+primesSlow = 1 : 2 : sieveSlow [3, 5 ..]
+
+testPrimes :: TestSuite
+testPrimes = suite "primes" $ do
+   assertTrue "first 1000 primes" (take 1000 primesSlow == take 1000 primes)
+   assertTrue "isPrime" (all isPrime primes1000)
+   addProperty "product of prime factors" $
+      forAll (choose (1, 1000000)) $ \n ->
+      product (primeFactors n) == n
+   addProperty "primality of prime factors" $
+      forAll (choose (1, 1000000)) $ \n ->
+      all isPrime (primeFactors n)
+   addProperty "factoring product of two primes" $
+      forAll (elements $ tail primes1000) $ \a ->
+      forAll (elements $ tail primes1000) $ \b ->
+      primeFactors (a*b) == sort [a, b]
+   addProperty "factors" $
+      forAll (choose (1, 10000)) $ \n ->
+      all (`divisorOf` n) (factors n)
+   addProperty "factors of product" $
+      forAll (choose (1, 1000)) $ \a ->
+      forAll (choose (1, 1000)) $ \b ->
+      all (`elem` factors (a*b)) [a, b]
+ src/Domain/Math/Data/Relation.hs view
@@ -0,0 +1,282 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 relations
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.Relation
+   ( -- * Type class
+     Relational(..)
+     -- * Relation data type
+   , Relation, relationType, RelationType(..), relationSymbols
+   , notRelation, eval
+     -- * Constructor functions
+   , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.)
+     -- * Equation (or equality)
+   , Equations, Equation(..), equationView
+     -- * Inequality
+   , Inequality(..), inequalityView
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Foldable (Foldable, foldMap, toList)
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable (Traversable, sequenceA)
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+import Ideas.Text.OpenMath.Dictionary.Relation1
+import Test.QuickCheck
+
+-----------------------------------------------------------------------------
+-- Type class for relations
+
+class Functor f => Relational f where
+   leftHandSide  :: f a -> a
+   rightHandSide :: f a -> a
+   flipSides     :: f a -> f a -- possibly also flips operator
+   constructor   :: f a -> b -> b -> f b
+   isSymmetric   :: f a -> Bool
+   -- default definitions
+   isSymmetric _ = False
+
+-----------------------------------------------------------------------------
+-- Relation data type
+
+data Relation a = R { lhs :: a, relationType :: RelationType, rhs :: a }
+   deriving (Eq, Ord)
+
+-- Corresponds exactly to the symbols in the relation1 OpenMath dictionary
+data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan
+                  | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately
+   deriving (Show, Eq, Ord, Enum)
+
+instance Show a => Show (Relation a) where
+   show r = unwords [show (lhs r), showRelType (relationType r), show (rhs r)]
+
+instance Functor Relation where
+   fmap f (R x rt y) = R (f x) rt (f y)
+
+instance Foldable Relation where
+   foldMap = foldMapRelation
+
+instance Traversable Relation where
+   sequenceA = sequenceRelation
+
+instance Relational Relation where
+   leftHandSide  = lhs
+   rightHandSide = rhs
+   flipSides (R x rt y) = R y (flipRelType rt) x
+   constructor (R _ rt _) = flip R rt
+   isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType
+
+instance IsTerm a => IsTerm (Relation a) where
+   toTerm p =
+      let op  = relationType p
+          sym = maybe (newSymbol (show op)) snd (lookup op relationSymbols)
+      in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p))
+   fromTerm term =
+      case getFunction term of
+         Just (s, [a, b]) ->
+            case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of
+               [rt] -> liftM2 (makeType rt) (fromTerm a) (fromTerm b)
+               _    -> fail "fromTerm: relation"
+         _ -> fail "fromTerm: relation"
+
+relationSymbols :: [(RelationType, (String, Symbol))]
+relationSymbols =
+   [ (EqualTo,              ("==", newSymbol eqSymbol))
+   , (NotEqualTo,           ("/=", newSymbol neqSymbol))
+   , (LessThan,             ("<",  newSymbol ltSymbol))
+   , (GreaterThan,          (">",  newSymbol gtSymbol))
+   , (LessThanOrEqualTo,    ("<=", newSymbol leqSymbol))
+   , (GreaterThanOrEqualTo, (">=", newSymbol geqSymbol))
+   , (Approximately,        ("~=", newSymbol approxSymbol))
+   ]
+
+notRelation :: Relation a -> Relation a
+notRelation r = r { relationType = relationType r ? table }
+ where
+   table = xs ++ map swap xs ++ [(Approximately, Approximately)]
+   swap (x, y) = (y, x)
+   xs = [ (EqualTo, NotEqualTo)
+        , (LessThan, GreaterThanOrEqualTo)
+        , (LessThanOrEqualTo, GreaterThan)
+        ]
+
+eval :: (Ord a, Num a) => RelationType -> a -> a -> Bool
+eval relType =
+   case relType of
+      EqualTo              -> (==)
+      NotEqualTo           -> (/=)
+      LessThan             -> (<)
+      GreaterThan          -> (>)
+      LessThanOrEqualTo    -> (<=)
+      GreaterThanOrEqualTo -> (>=)
+      Approximately        -> \a b -> 1000 * abs (a-b) < 1
+
+-- helpers
+showRelType :: RelationType -> String
+showRelType = fst . (? relationSymbols)
+
+flipRelType :: RelationType -> RelationType
+flipRelType relType = fromMaybe relType (lookup relType table)
+ where
+   table = pairs ++ map (\(a,b) -> (b,a)) pairs
+   pairs = [(LessThan, GreaterThan), (LessThanOrEqualTo, GreaterThanOrEqualTo)]
+
+(?) :: Eq a => a -> [(a, b)] -> b
+a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs)
+
+foldMapRelation :: (Relational f, Monoid m) => (a -> m) -> f a -> m
+foldMapRelation f p = f (leftHandSide p) `mappend` f (rightHandSide p)
+
+sequenceRelation :: (Relational g, Applicative f) => g (f a) -> f (g a)
+sequenceRelation p = constructor p <$> leftHandSide p <*> rightHandSide p
+
+-----------------------------------------------------------------------------
+-- QuickCheck generators
+
+instance Arbitrary a => Arbitrary (Relation a) where
+   arbitrary = liftM3 R arbitrary arbitrary arbitrary
+
+instance CoArbitrary a => CoArbitrary (Relation a) where
+   coarbitrary p = coarbitrary (relationType p) . coarbitrary (toList p)
+
+instance Arbitrary RelationType where
+   arbitrary = elements [EqualTo .. Approximately]
+
+instance CoArbitrary RelationType where
+   coarbitrary op = variant (fromEnum op)
+
+-----------------------------------------------------------------------------
+-- Constructor functions
+
+infix 1 .==., ./=., .<., .>., .<=., .>=., .~=.
+
+(.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a
+(.==.) = makeType EqualTo
+(./=.) = makeType NotEqualTo
+(.<.)  = makeType LessThan
+(.>.)  = makeType GreaterThan
+(.<=.) = makeType LessThanOrEqualTo
+(.>=.) = makeType GreaterThanOrEqualTo
+(.~=.) = makeType Approximately
+
+makeType :: RelationType -> a -> a -> Relation a
+makeType = flip R
+
+-----------------------------------------------------------------------------
+-- Equation data type (view on Relation)
+
+infix 1 :==:
+
+type Equations a = [Equation a]
+
+data Equation  a = a :==: a
+   deriving (Eq, Ord)
+
+instance Show a => Show (Equation a) where
+   show = show . build equationView
+
+instance Functor Equation where
+   fmap f (x :==: y) = f x :==: f y
+
+instance Foldable Equation where
+   foldMap = foldMapRelation
+
+instance Traversable Equation where
+   sequenceA = sequenceRelation
+
+instance Relational Equation where
+   leftHandSide  = leftHandSide  . build equationView
+   rightHandSide = rightHandSide . build equationView
+   flipSides (x :==: y) = y :==: x
+   constructor   = const (:==:)
+   isSymmetric   = const True
+
+instance Arbitrary a => Arbitrary (Equation a) where
+   arbitrary   = liftM2 (:==:) arbitrary arbitrary
+
+instance CoArbitrary a => CoArbitrary (Equation a) where
+   coarbitrary = coarbitrary . build equationView
+
+instance IsTerm a => IsTerm (Equation a) where
+   toTerm = toTerm . build equationView
+   fromTerm a = fromTerm a >>= matchM equationView
+
+equationView :: View (Relation a) (Equation a)
+equationView = makeView f g
+ where
+   f (R x op y)
+      | op == EqualTo = return (x :==: y)
+      | otherwise     = Nothing
+   g (x :==: y) = x .==. y
+
+-----------------------------------------------------------------------------
+-- Inequality (view on Relation)
+
+infix 1 :<:, :>:, :<=:, :>=:
+
+data Inequality a = a :<: a | a :>: a | a :<=: a | a :>=: a
+
+instance Show a => Show (Inequality a) where
+   show = show . build inequalityView
+
+instance Functor Inequality where
+   fmap f ineq =
+      let a = leftHandSide ineq
+          b = rightHandSide ineq
+      in constructor ineq (f a) (f b)
+
+instance Foldable Inequality where
+   foldMap = foldMapRelation
+
+instance Traversable Inequality where
+   sequenceA = sequenceRelation
+
+instance Relational Inequality where
+   leftHandSide  = leftHandSide  . build inequalityView
+   rightHandSide = rightHandSide . build inequalityView
+   flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView
+             . flipSides . build inequalityView
+   constructor ineq =
+      let relType = relationType (build inequalityView ineq)
+      in fst (relType ? inequalityTable)
+
+instance Arbitrary a => Arbitrary (Inequality a) where
+   arbitrary = do
+      op <- elements $ map (fst . snd) inequalityTable
+      liftM2 op arbitrary arbitrary
+
+instance CoArbitrary a => CoArbitrary (Inequality a) where
+   coarbitrary = coarbitrary . build inequalityView
+
+instance IsTerm a => IsTerm (Inequality a) where
+   toTerm = toTerm . build inequalityView
+   fromTerm a = fromTerm a >>= matchM inequalityView
+
+inequalityView :: View (Relation a) (Inequality a)
+inequalityView = makeView f g
+ where
+   f (R x op y) = fmap (\pair -> fst pair x y) (lookup op inequalityTable)
+   g ineq =
+      case ineq of
+         x :<:  y -> x .<.  y
+         x :>:  y -> x .>.  y
+         x :<=: y -> x .<=. y
+         x :>=: y -> x .>=. y
+
+inequalityTable :: [(RelationType, (a -> a -> Inequality a, a -> a -> Relation a))]
+inequalityTable =
+   [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.)))
+   , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.)))
+   ]
+ src/Domain/Math/Data/SquareRoot.hs view
@@ -0,0 +1,199 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Data.Ratio
+import Domain.Math.Safe
+import Prelude hiding (sqrt)
+import Test.QuickCheck
+import qualified Data.Map as M
+import qualified Domain.Math.Data.PrimeFactors as P
+import qualified Prelude
+
+-------------------------------------------------------------
+-- 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 :: (Eq a,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 :: (Eq a,Num a) => SqMap a -> SqMap a -> SqMap a
+plusSqMap m1 m2 = M.filter (/=0) (M.unionWith (+) m1 m2)
+
+minusSqMap :: (Eq a,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 :: (Eq a,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 :: (Eq a,Fractional a) => SqMap a -> SqMap a
+recipSqMap m =
+   case M.toList m of
+      []       -> error "SquareRoot: division by zero"
+      [(n, x)] -> M.singleton n (recip (x * 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 (Show a,Eq a,Num a) => Show (SquareRoot a) where
+   show (S isNeg 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 isNeg 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 (Eq a,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 (Eq a,Fractional a) => SafeDiv (SquareRoot a) where
+   safeDiv x y
+      | y == 0    = Nothing
+      | otherwise = Just (x/y)
+
+instance (Eq a,Fractional a) => Fractional (SquareRoot a) where
+   recip (S b m) = S b (recipSqMap m)
+   fromRational  = con . fromRational
+
+instance (Eq a,Fractional a) => Arbitrary (SquareRoot a) where
+   arbitrary = sized $ \n -> do
+      let make r1 r2 = fromRational r1 * sqrtRational r2
+      i <- choose (0, 10)
+      xs <- vectorOf i (liftM2 make (rationalGen n) (rationalGen n))
+      return (sum xs)
+
+rationalGen :: Int -> Gen Rational
+rationalGen n = do -- a+(b/c)
+   c <- choose (0, n)
+   b <- choose (0, c)
+   a <- choose (0, n)
+   return $ fromIntegral a + if c==0 then 0
+                                     else fromIntegral b / fromIntegral c
+
+-------------------------------------------------------------
+-- 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
+      [(b, n)] | n==1 -> Just b
+      []              -> Just 0
+      _ -> Nothing
+
+con :: (Eq a,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 :: (Eq a,Num a) => a -> SquareRoot a -> SquareRoot a
+scale a sr = if a==0 then 0 else fmap (*a) sr
+
+isqrt :: Integer -> Integer
+isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger
+
+sqrtRational :: (Eq a,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/Data/TestingClassLaws.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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  :  johan.jeuring@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.TestingClassLaws where
+
+import Domain.Math.Data.DecimalFraction
+import Domain.Math.Data.Interval(Endpoint(..))
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Data.SquareRoot
+import Domain.Math.Data.WithBool
+
+import Control.Monad.Laws
+import Test.ClassLaws
+import Text.Show.Laws
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws Polynomial
+
+type instance Param (Polynomial a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (Polynomial a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorPolynomial
+  = do quickLawCheck   (undefined::FunctorLaw1 Int Polynomial)
+       quickFLawCheck  (undefined::FunctorLaw2 Int Int Int Polynomial)
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws Endpoint
+
+type instance Param (Endpoint a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (Endpoint a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorEndpoint
+  = do quickLawCheck   (undefined::FunctorLaw1 Float Endpoint)
+       quickFLawCheck  (undefined::FunctorLaw2 Float Float Float Endpoint)
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws OrList
+
+type instance Param (OrList a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (OrList a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorOrList
+  = do quickLawCheck   (undefined::FunctorLaw1 Float OrList)
+       quickFLawCheck  (undefined::FunctorLaw2 Float Float Float OrList)
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws Relation
+
+type instance Param (Relation a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (Relation a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorRelation
+  = do quickLawCheck   (undefined::FunctorLaw1 Float Relation)
+       quickFLawCheck  (undefined::FunctorLaw2 Float Float Float Relation)
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws SquareRoot
+
+type instance Param (SquareRoot a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (SquareRoot a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorSquareRoot
+  = do quickLawCheck   (undefined::FunctorLaw1 Float SquareRoot)
+       quickFLawCheck  (undefined::FunctorLaw2 Float Float Float SquareRoot)
+
+------------------------------------------------------------------------------
+
+instance FunctorLaws WithBool
+
+type instance Param (WithBool a) = ()
+
+instance (Eq a, Show a, Num a) => TestEqual (WithBool a) where
+  testEqual p _ = testEq (==) p
+
+testFunctorWithBool
+  = do quickLawCheck   (undefined::FunctorLaw1 Int WithBool)
+       quickFLawCheck  (undefined::FunctorLaw2 Int Int Int WithBool)
+
+------------------------------------------------------------------------------
+
+testFunctorAll = do testFunctorPolynomial
+                    testFunctorEndpoint
+                    testFunctorOrList
+                    testFunctorRelation
+                    testFunctorSquareRoot
+                    testFunctorWithBool
+
+------------------------------------------------------------------------------
+
+instance ShowLaws DecimalFraction
+
+type instance Param DecimalFraction = ()
+
+instance TestEqual DecimalFraction where
+  testEqual p _ = testEq (==) p
+
+-- Problem in digits
+testShowDecimalFraction
+  = quickLawCheck (undefined::ShowLaw DecimalFraction)
+
+------------------------------------------------------------------------------
+
+instance ShowLaws (Interval a)
+
+type instance Param (Interval a) = ()
+
+instance TestEqual (Interval a) where
+  testEqual p _ = testEq (==) p
+
+-- Problem in digits
+testShowInterval
+  = quickLawCheck (undefined::ShowLaw (Interval Int))
+
+{------------------------------------------------------------------------------
+
+instance ShowLaws DecimalFraction
+
+type instance Param DecimalFraction = ()
+
+instance TestEqual DecimalFraction where
+  testEqual p _ = testEq (==) p
+
+-- Problem in digits
+testShowDecimalFraction
+  = do quickLawCheck (undefined::ShowLaw DecimalFraction)
+
+-}
+ src/Domain/Math/Data/WithBool.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Values extended with boolean constants
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.WithBool
+   ( WithBool, fromWithBool, join
+   ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Char (toLower)
+import Data.Foldable
+import Data.Traversable
+import Domain.Logic.Formula
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Classes
+import Ideas.Common.Rewriting
+import Test.QuickCheck
+
+-------------------------------------------------------------------
+-- Abstract data type and instances
+
+newtype WithBool a = WB { fromWithBool :: Either Bool a }
+   deriving (Eq, Ord, Functor, Arbitrary)
+
+instance Show a => Show (WithBool a) where
+   show = either (map toLower . show) show . fromWithBool
+
+instance BoolValue (WithBool a) where
+   fromBool = WB . Left
+   isTrue   = either id  (const False) . fromWithBool
+   isFalse  = either not (const False) . fromWithBool
+
+instance Container WithBool where
+   singleton    = WB . Right
+   getSingleton = either (const Nothing) Just . fromWithBool
+
+instance Monad WithBool where
+   return  = singleton
+   m >>= f = either fromBool f (fromWithBool m)
+
+instance Foldable WithBool where
+   foldMap = foldMapDefault
+
+instance Traversable WithBool where
+   traverse _ (WB (Left b))  = pure (WB (Left b))
+   traverse f (WB (Right a)) = (WB . Right) <$> f a
+
+instance IsTerm a => IsTerm (WithBool a) where
+   toTerm = either f toTerm . fromWithBool
+    where
+      f True  = symbol trueSymbol
+      f False = symbol falseSymbol
+   fromTerm term
+      | isSymbol trueSymbol  term = return true
+      | isSymbol falseSymbol term = return false
+      | otherwise                 = liftM singleton (fromTerm term)
+ src/Domain/Math/Derivative/Examples.hs view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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),
+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Derivative.Examples
+   ( diffSet1, diffSet2, diffSet3, diffSet4
+   , diffSet5, diffSet6, diffSet7, diffSet8
+   ) where
+
+import Data.Maybe
+import Domain.Math.Expr
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+differentiateLists :: [[Expr]] -> [[Expr]]
+differentiateLists = map (map differentiate)
+
+differentiate :: Expr -> Expr
+differentiate a =
+   let x = fromMaybe "x" (selectVar a)
+   in unary diffSymbol $ binary lambdaSymbol (Var x) a
+
+----------------------------------------------------------
+-- HAVO B applets
+
+-- Hoofdstuk 6, differentieer
+-- Bereken de afgeleide
+diffSet1 :: [[Expr]]
+diffSet1 = differentiateLists $
+   let x = Var "x" in
+   let p = Var "p" in
+   let q = Var "q" in
+   let r = Var "r" in
+   [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(3/2)*x^2-x+1]
+   , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7]
+   , -- werk eerst de haakjes weg
+     [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)]
+     -- differentieer
+   , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)]
+   ]
+
+----------------------------------------------------------
+-- VWO A/C applets
+
+-- Hoofdstuk 7, differentieer
+diffSet2 :: [[Expr]]
+diffSet2 = differentiateLists $
+   let x = Var "x" in
+   [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7]
+   , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1]
+   , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x
+     , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ]
+   ]
+
+-- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet
+
+----------------------------------------------------------
+-- VWO B applets
+
+-- Hoofdstuk 3, differentieren: zelfde als Havo B applet
+
+-- Hoofdstuk 7
+-- Gebruik de productregel
+diffSet3 :: [[Expr]]
+diffSet3 = differentiateLists $
+   let x = Var "x" in
+   [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2)
+     , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1)
+     , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x)
+     ]
+   , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2
+     , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2
+     ]
+   ]
+
+-- Gebruik de quotientregel
+diffSet4 :: [[Expr]]
+diffSet4 = differentiateLists $
+   let x = Var "x" in
+   [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1)
+     , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3)
+     ]
+   , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1)
+     , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4)
+     ]
+   , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2)
+     , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2)
+     , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2)
+     ]
+   , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2
+     , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2
+     ]
+   ]
+
+-- differentieer x^n (n geheel), noteer zonder negatieve exponent
+diffSet5 :: [[Expr]]
+diffSet5 = differentiateLists $
+   let x = Var "x" in
+   [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ]
+   , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5)
+     , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4
+     ]
+   , -- herleid de afgeleide tot 1 breuk
+     [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3
+     , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3)
+     ]
+   ]
+
+-- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent
+diffSet6 :: [[Expr]]
+diffSet6 = differentiateLists $
+   let x = Var "x" in
+   [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3)
+     , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x)
+     ]
+   , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5
+     , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2)
+     , (3+x^3)*(sqrt x+1)
+     ]
+   , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2
+     , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x
+     ]
+   , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x)
+     , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x)
+     , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x)
+     ]
+   , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x)
+     , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2
+     , (1-sqrt x)/x, (3*sqrt x+2)/x
+     ]
+   ]
+
+-- differentieren met de kettingregel
+diffSet7 :: [[Expr]]
+diffSet7 = differentiateLists $
+   let x = Var "x" in
+   [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3]
+   , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3]
+   , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)]
+   , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)]
+   , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2)
+     , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7)
+     ]
+   ]
+
+-- differentieren met de kettingregel gecombineerd
+diffSet8 :: [[Expr]]
+diffSet8 = differentiateLists $
+   let x = Var "x" in
+   [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)]
+   , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4]
+   , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3)
+     , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4)
+     ]
+   , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7)
+     , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7)
+     ]
+   ]
+ src/Domain/Math/Derivative/Exercises.hs view
@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Derivative.Exercises
+   ( derivativeExercise, derivativePolyExercise
+   , derivativeProductExercise, derivativeQuotientExercise
+   , derivativePowerExercise
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Domain.Math.CleanUp
+import Domain.Math.Derivative.Examples
+import Domain.Math.Derivative.Rules
+import Domain.Math.Derivative.Strategies
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Generators
+import Domain.Math.Polynomial.RationalExercises
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate
+import Prelude hiding (repeat, (^))
+import Test.QuickCheck
+
+derivativePolyExercise :: Exercise Expr
+derivativePolyExercise = describe
+   "Find the derivative of a polynomial. First normalize the polynomial \
+   \(e.g., with distribution). Don't make use of the product-rule, or \
+   \other chain rules." $ makeExercise
+   { exerciseId    = diffId # "polynomial"
+   , status        = Provisional
+   , parser        = parseExpr
+   , ready         = predicateView (polyNormalForm rationalView)
+   , suitable      = predicate isPolyDiff
+   , equivalence   = withoutContext eqPolyDiff
+   , similarity    = withoutContext (viewEquivalent cleanUpACView)
+   , strategy      = derivativePolyStrategy
+   , navigation    = navigator
+   , examples      = level Medium $ concat (diffSet1 ++ diffSet2 ++ diffSet3)
+   , testGenerator = Just $ liftM (diff . lambda "x") $
+                        sized quadraticGen
+   }
+
+derivativeProductExercise :: Exercise Expr
+derivativeProductExercise = describe
+   "Use the product-rule to find the derivative of a polynomial. Keep \
+   \the parentheses in your answer." $
+   derivativePolyExercise
+   { exerciseId    = diffId # "product"
+   , ready         = predicate noDiff
+   , strategy      = derivativeProductStrategy
+   , examples      = level Medium $ concat diffSet3
+   }
+
+derivativeQuotientExercise :: Exercise Expr
+derivativeQuotientExercise = describe
+   "Use the quotient-rule to find the derivative of a polynomial. Only \
+   \remove parentheses in the numerator." $
+   derivativePolyExercise
+   { exerciseId    = diffId # "quotient"
+   , ready         = predicate readyQuotientDiff
+   , suitable      = predicate isQuotientDiff
+   , equivalence   = withoutContext eqQuotientDiff
+   , strategy      = derivativeQuotientStrategy
+   , ruleOrdering  = ruleOrderingWithId [ruleDerivQuotient]
+   , examples      = level Medium $ concat diffSet4
+   , testGenerator = Nothing
+   }
+
+derivativePowerExercise :: Exercise Expr
+derivativePowerExercise = describe
+   "First write as a power, then find the derivative. Rewrite negative or \
+   \rational exponents." $
+   derivativePolyExercise
+   { exerciseId    = diffId # "power"
+   , status        = Experimental
+   , ready         = predicate noDiff <&&> predicate onlyNatPower
+   -- , isSuitable    = const True
+   , equivalence   = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y)
+   , strategy      = derivativePowerStrategy
+   , examples      = level Medium $ concat (diffSet5 ++ diffSet6)
+   , testGenerator = Nothing
+   }
+
+derivativeExercise :: Exercise Expr
+derivativeExercise = makeExercise
+   { exerciseId   = describe "Derivative" diffId
+   , status       = Provisional
+   , parser       = parseExpr
+   , ready        = predicate noDiff
+   , strategy     = derivativeStrategy
+   , ruleOrdering = derivativeOrdering
+   , equivalence   = withoutContext eqQuotientDiff
+   , navigation   = navigator
+   , examples     = level Medium $ concat $ diffSet3++diffSet4++diffSet5++
+                                            diffSet6++diffSet7++diffSet8
+                            {- diffSet6 -- ++diffSet7++diffSet8 -}
+   }
+
+derivativeOrdering :: Rule a -> Rule a -> Ordering
+derivativeOrdering = comparing f
+ where
+   f a = (getId a /= j, getId a == i, showId a)
+   i = getId ruleDefRoot
+   j = getId ruleDerivPolynomial
+
+isPolyDiff :: Expr -> Bool
+isPolyDiff = maybe False (`belongsTo` polyViewWith rationalView) . getDiffExpr
+
+isQuotientDiff :: Expr -> Bool
+isQuotientDiff de = fromMaybe False $ do
+   expr <- getDiffExpr de
+   xs   <- match sumView expr
+   let f a = maybe [a] (\(x, y) -> [x, y]) (match divView a)
+       ys  = concatMap f xs
+       isp = (`belongsTo` polyViewWith rationalView)
+   return (all isp ys)
+
+eqPolyDiff :: Expr -> Expr -> Bool
+eqPolyDiff = viewEquivalent (polyViewWith rationalView) `on` evalDiff
+
+eqQuotientDiff :: Expr -> Expr -> Bool
+eqQuotientDiff = eqSimplifyRational `on` (cleanUpExpr . evalDiff)
+
+readyQuotientDiff :: Expr -> Bool
+readyQuotientDiff expr = fromMaybe False $ do
+   xs <- match sumView expr
+   let f a      = fromMaybe (a, 1) (match divView a)
+       (ys, zs) = unzip (map f xs)
+       isp = (`belongsTo` polyViewWith rationalView)
+       nfp = (`belongsTo` polyNormalForm rationalView)
+   return (all nfp ys && all isp zs)
+
+noDiff :: Expr -> Bool
+noDiff e = all (not . isDiffSymbol) [ s | Sym s _ <- universe e]
+
+onlyNatPower :: Expr -> Bool
+onlyNatPower e = all isNat [ a | Sym s [_, a] <- universe e, isPowerSymbol s ]
+ where
+   isNat (Nat _) = True
+   isNat _       = False
+
+evalDiff :: Expr -> Expr
+evalDiff da =
+   case da of
+      Sym d [Sym l [Var x, expr]] | isDiffSymbol d && isLambdaSymbol l ->
+         cleanUpExpr (rec x expr)
+      _ -> descend evalDiff da
+ where
+   rec x expr =
+      case expr of
+         _ | withoutVar x expr -> 0
+         Var y | x==y -> 1
+         a :+: b  -> rec x a + rec x b
+         a :-: b  -> rec x a - rec x b
+         Negate a -> -rec x a
+         a :*: b  -> rec x a*b + a*rec x b
+         a :/: b  -> (b*rec x a - a*rec x b) / b^2
+         Sqrt a   -> rec x (a^(1/2))
+         Sym s [a, b]
+            | isPowerSymbol s ->
+                 case match rationalView b of
+                    Just n  -> fromRational n * a^fromRational (n-1) * rec x a
+                    Nothing -> diffExpr
+            | isRootSymbol s ->
+                 rec x (a^(1/b))
+         _ -> diffExpr
+    where
+      diffExpr = diff (lambda x expr)
+ src/Domain/Math/Derivative/Rules.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Derivative.Rules where
+
+import Control.Monad
+import Data.Maybe
+import Domain.Math.Data.Polynomial
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.Views
+import Ideas.Common.Library hiding (root)
+import Prelude hiding ((^))
+
+derivativeRules :: [Rule Expr]
+derivativeRules =
+   [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate
+   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar
+   , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain
+   , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain
+   ]
+
+diff :: Expr -> Expr
+diff = unary diffSymbol
+
+ln :: Expr -> Expr
+ln = unary lnSymbol
+
+lambda :: String -> Expr -> Expr
+lambda = binary lambdaSymbol . Var
+
+diffId :: Id
+diffId = newId "calculus.differentiation"
+
+isDiffSymbol, isLambdaSymbol :: Symbol -> Bool
+isDiffSymbol   = (== diffSymbol)
+isLambdaSymbol = (== lambdaSymbol)
+
+-----------------------------------------------------------------
+-- Rules for Diffs
+
+ruleSine :: Rule Expr
+ruleSine = rewriteRule (diffId, "sine") $
+   \x -> diff (lambda x (sin (Var x)))  :~>  cos (Var x)
+
+ruleLog :: Rule Expr
+ruleLog = rewriteRule (diffId, "logarithmic") $
+   \x -> diff (lambda x (ln (Var x)))  :~>  1 / Var x
+
+ruleDerivPlus :: Rule Expr
+ruleDerivPlus = rewriteRule (diffId, "plus") $
+   \x f g -> diff (lambda x (f + g))  :~>  diff (lambda x f) + diff (lambda x g)
+
+ruleDerivMin :: Rule Expr
+ruleDerivMin = rewriteRule (diffId, "min") $
+   \x f g -> diff (lambda x (f - g))  :~>  diff (lambda x f) - diff (lambda x g)
+
+ruleDerivNegate :: Rule Expr
+ruleDerivNegate = rewriteRule (diffId, "negate") $
+   \x f -> diff (lambda x (-f))  :~>  -diff (lambda x f)
+
+ruleDerivVar :: Rule Expr
+ruleDerivVar = rewriteRule (diffId, "var") $
+   \x -> diff (lambda x (Var x))  :~>  1
+
+ruleDerivProduct :: Rule Expr
+ruleDerivProduct = rewriteRule (diffId, "product") $
+   \x f g -> diff (lambda x (f * g))  :~>  diff (lambda x f)*g + f*diff (lambda x g)
+
+-- The second rewrite rule should not have been necessary, except that cleaning
+-- up an expression will typically put the negate in front of the division: this
+-- makes sure the rule is triggered anyway.
+ruleDerivQuotient :: Rule Expr
+ruleDerivQuotient = rewriteRules (diffId, "quotient")
+   [ \x f g -> diff (lambda x (f/g))  :~>  (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2)
+   , \x f g -> diff (lambda x (-f/g))  :~>  (g*diff (lambda x (-f)) - (-f)*diff (lambda x g)) / (g^2)
+   ]
+
+ruleDerivPolynomial :: Rule Expr
+ruleDerivPolynomial = describe "This rule returns the derivative for all \
+   \expressions that can be turned into a polynomial (of rational numbers). \
+   \The polynomial does not have to be in standard form." $
+   makeRule (diffId, "deriv-of-poly") f
+ where
+   f (Sym d [Sym l [Var v, expr]]) | isDiffSymbol d && isLambdaSymbol l = do
+      let myView = polyViewWith rationalView
+      (s, p) <- match myView expr
+      guard (s==v)
+      return (build myView (s, derivative p))
+   f _ = Nothing
+
+-----------------------------------
+-- Special rules (not defined with unification)
+
+ruleDerivCon :: Rule Expr
+ruleDerivCon = makeRule (diffId, "constant") f
+ where
+   f (Sym d [Sym l [Var x, e]])
+      | isDiffSymbol d && isLambdaSymbol l && withoutVar x e = return 0
+   f _ = Nothing
+
+ruleDerivMultiple :: Rule Expr
+ruleDerivMultiple = makeRule (diffId, "constant-multiple") f
+ where
+    f (Sym d [Sym l [Var x, n :*: e]])
+       | isDiffSymbol d && isLambdaSymbol l && withoutVar x n =
+       return $ n * diff (lambda x e)
+    f (Sym d [Sym l [Var x, e :*: n]])
+       | isDiffSymbol d && isLambdaSymbol l && withoutVar x n =
+       return $ n * diff (lambda x e)
+    f _ = Nothing
+
+ruleDerivPower :: Rule Expr
+ruleDerivPower = makeRule (diffId, "power") f
+ where
+   f (Sym d [Sym l [Var x, Sym p [x1, n]]])
+      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && Var x==x1 && withoutVar x n =
+      return $ n * (Var x ^ (n-1))
+   f _ = Nothing
+
+ruleDerivPowerChain :: Rule Expr
+ruleDerivPowerChain = makeRule (diffId, "chain-power") f
+ where
+   f (Sym d [Sym l [Var x, Sym p [a, n]]])
+      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar x n =
+      return $ n * (a ^ (n-1)) * diff (lambda x a)
+   f _ = Nothing
+
+ruleDerivSqrt :: Rule Expr
+ruleDerivSqrt = makeRule (diffId, "sqrt") f
+ where
+   f (Sym d [Sym l [Var x, Sqrt x1]])
+      | isDiffSymbol d && isLambdaSymbol l && Var x==x1 =
+      return $ 1 / (2 * sqrt (Var x))
+   f _ = Nothing
+
+ruleDerivSqrtChain :: Rule Expr
+ruleDerivSqrtChain = makeRule (diffId, "chain-sqrt") f
+ where
+   f (Sym d [Sym l [Var x, Sqrt a]])
+      | isDiffSymbol d && isLambdaSymbol l =
+      return $ (1 / (2 * sqrt a)) * diff (lambda x a)
+   f _ = Nothing
+
+ruleDefRoot :: Rule Expr
+ruleDefRoot = rewriteRule (diffId, "def-root") $
+   \a b -> root a b :~> a ^ (1/b)
+
+ruleDerivRoot :: Rule Expr
+ruleDerivRoot = rewriteRule (diffId, "def-root") $
+   \a b x -> diff (lambda x (root a b)) :~> diff (lambda x (a ^ (1/b)))
+
+ruleDerivPowerFactor :: Rule Expr
+ruleDerivPowerFactor = makeRule (diffId, "power-factor") $ \de -> do
+   expr <- getDiffExpr de
+   (a, x, r) <- match myPowerView expr
+   return $ build myPowerView (a*fromRational r, x, r-1)
+
+-- (a+b)/c  ~>  a/c + b/c
+ruleSplitRational :: Rule Expr
+ruleSplitRational = makeRule (diffId, "split-rational") $ \expr -> do
+   (upper, c) <- match divView expr
+   (a, b)     <- match plusView upper
+   return (a/c + b/c)
+
+myPowerView :: View Expr (Expr, String, Rational)
+myPowerView = makeView f g
+ where
+   f expr = case match timesView expr of
+               Just (a, b) -> do
+                  guard (hasNoVar a)
+                  (x, r) <- match powView b
+                  return (a, x, r)
+                `mplus` do
+                  guard (hasNoVar b)
+                  (x, r) <- match powView a
+                  return (b, x, r)
+               Nothing -> do
+                  (x, r) <- match powView expr
+                  return (1, x, r)
+   g (a, x, r) = a .*. (Var x .^. fromRational r)
+
+   powView = (matcher powerView <+> matcher noPowerView)
+             >>> matcher (variableView *** rationalView)
+   noPowerView = makeView (\expr -> Just (expr, 1)) (build powerView)
+
+isDiff :: Expr -> Bool
+isDiff = isJust . getDiffExpr
+
+getDiffExpr :: Expr -> Maybe Expr
+getDiffExpr (Sym d [Sym l [Var _, expr]]) |
+   isDiffSymbol d && isLambdaSymbol l = Just expr
+getDiffExpr _ = Nothing
+ src/Domain/Math/Derivative/Strategies.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Derivative.Strategies
+   ( derivativeStrategy, derivativePolyStrategy
+   , derivativeProductStrategy, derivativeQuotientStrategy
+   , derivativePowerStrategy, getDiffExpr
+   ) where
+
+import Data.Maybe
+import Domain.Math.CleanUp
+import Domain.Math.Derivative.Rules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.Rules
+import Domain.Math.Power.Strategies
+import Ideas.Common.Library
+
+import Prelude hiding ((^))
+
+derivativeStrategy :: LabeledStrategy (Context Expr)
+derivativeStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+   label "Derivative" $ repeatS $ somewhere $
+      alternatives (map liftToContext derivativeRules)
+      <|> derivativePolyStepStrategy
+      <|> check isDiffC <*> layer [] (layer [] (liftToContext ruleDefRoot))
+ where
+   isDiffC = maybe False isDiff . currentInContext
+
+derivativePolyStrategy :: LabeledStrategy (Context Expr)
+derivativePolyStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+   label "derivative-polynomial" $
+      repeatS (somewhere (alternatives rulesPolyNF))
+      <*> derivativePolyStepStrategy
+
+rulesPolyNF :: [Rule (Context Expr)]
+rulesPolyNF =
+   distributeDivisionMulti :
+   map liftToContext
+   [ distributionSquare, distributeTimes, merge
+   , noDivisionConstant
+   ]
+
+derivativeProductStrategy :: LabeledStrategy (Context Expr)
+derivativeProductStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+   label "derivative-product" $
+      repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
+ where
+   list = distributeDivisionMulti : map liftToContext
+      [ noDivisionConstant
+      , ruleDerivProduct, defPowerNat
+      , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
+      ]
+
+derivativeQuotientStrategy :: LabeledStrategy (Context Expr)
+derivativeQuotientStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+   label "derivative-quotient" $
+   repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
+   <*> repeatS (exceptLowerDiv (alternatives rulesPolyNF))
+ where
+   list = map liftToContext
+      [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ]
+
+derivativePowerStrategy :: LabeledStrategy (Context Expr)
+derivativePowerStrategy = label "derivative-power" $
+   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "split-rational"
+      (repeatS (somewhere (liftToContext ruleSplitRational)))) <*>
+   configure mycfg simplifyPowerStrategy <*>
+   repeatS (distr <*> configure mycfg simplifyPowerStrategy) <*>
+   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "use-derivative-rules"
+      (repeatS (somewhere (alternatives list)))) <*>
+   configure mycfg nonNegBrokenExpStrategy
+ where
+   list = map liftToContext
+      [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor
+      , ruleDerivCon ]
+   mycfg = makeStrategyConfiguration [(byName myFractionTimes, Remove)]
+   distr = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+      label "distr" (somewhere (alternatives rulesPolyNF))
+
+derivativePolyStepStrategy :: LabeledStrategy (Context Expr)
+derivativePolyStepStrategy = label "derivative-poly-step" $
+   check polyDiff <*> liftToContext ruleDerivPolynomial
+ where
+   polyDiff = maybe False nfPoly . (>>= getDiffExpr) . currentInContext
+   nfPoly   = (`belongsTo` polyNormalForm rationalView)
+
+exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
+exceptLowerDiv = traverse [parentFilter p]
+ where
+   p a = if isDivC a then [0] else [0 .. arity a-1]
+   isDivC = maybe False isDiv . currentInContext
+   isDiv (_ :/: _) = True
+   isDiv _         = False
+ src/Domain/Math/Equation/BalanceRules.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.BalanceRules
+   ( plusRule, minusRule, timesRule, divisionRule
+   ) where
+
+import Control.Monad
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+plusRule :: Functor f => ParamTrans Expr (f Expr)
+plusRule = parameter1 "term" $ \a ->
+   makeTrans $ Just . fmap (:+: a)
+
+minusRule :: Functor f => ParamTrans Expr (f Expr)
+minusRule = parameter1 "term" $ \a ->
+   makeTrans $ Just . fmap (:-: a)
+
+timesRule :: Functor f => ParamTrans Expr (f Expr)
+timesRule = parameter1 "factor" $ \a ->
+   makeTrans $ unlessZero a . fmap (a :*:)
+
+divisionRule :: ParamTrans Expr (Equation Expr)
+divisionRule = parameter1 "factor" $ \a ->
+   makeTrans $ unlessZero a . fmap (:/: a)
+
+unlessZero :: Expr -> a -> Maybe a
+unlessZero e a = do
+   r <- matchM rationalView e
+   guard (r /= 0)
+   return a
+ src/Domain/Math/Equation/CoverUpExercise.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, coverUpStrategy
+   ) where
+
+import Data.Maybe
+import Domain.Math.CleanUp (cleanUpExpr, cleanUpView)
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Equation.Examples
+import Domain.Math.Equation.Views
+import Domain.Math.Expr
+import Ideas.Common.Library
+
+------------------------------------------------------------
+-- Exercise
+
+coverUpExercise :: Exercise (OrList (Equation Expr))
+coverUpExercise = makeExercise
+   { exerciseId   = describe "solve an equation by covering up" $
+                       newId "algebra.equations.coverup"
+   , status       = Provisional
+   , parser       = parseOrsEqExpr
+   , equivalence  = withoutContext eqCoverUp
+   , similarity   = withoutContext myEq
+   , ready        = predicateView equationsSolvedForm
+   , extraRules   = coverUpRulesOr
+   , strategy     = coverUpStrategy
+   , navigation   = termNavigator
+   , examples     = level Medium $ map singleton (concat (fillInResult ++ coverUpEquations))
+   }
+
+------------------------------------------------------------
+-- Strategy and rules
+
+coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
+coverUpStrategy = cleanUpStrategyAfter (applyTop $ fmap $ fmap cleanUpExpr) $
+   label "Cover-up" $
+   repeatS $ somewhere $ alternatives coverUpRulesOr
+
+eqCoverUp :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool
+eqCoverUp a b = myEq (f a) (f b)
+ where
+   inc = inContext coverUpExercise
+   f x = fromMaybe x $ fromContext $ applyD coverUpStrategy $ inc x
+
+myEq :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool
+myEq = viewEquivalent (traverseView (traverseView cleanUpView))
+ src/Domain/Math/Equation/CoverUpRules.hs view
@@ -0,0 +1,203 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   , coverUp, coverUpOrs
+   , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight
+   , coverUpTimes, coverUpNegate
+   , coverUpNumerator, coverUpDenominator, coverUpSqrt
+     -- parameterized rules
+   , ConfigCoverUp, configName, predicateCovered, predicateCombined
+   , coverLHS, coverRHS, configCoverUp
+   , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith
+   , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith
+   , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
+     -- temporarily exported
+   , coverUpBinaryRule, commOp, flipOp
+   ) where
+
+import Control.Monad
+import Data.Foldable
+import Data.Maybe
+import Data.Traversable (Traversable, mapM)
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Library hiding (root)
+
+---------------------------------------------------------------------
+-- Constructors for cover-up rules
+
+coverUpFunction :: (Traversable f, Relational r)
+                   => (Expr -> [(Expr, Expr)])
+                   -> (Expr -> Expr -> [f Expr])
+                   -> ConfigCoverUp -> r Expr -> [f (r Expr)]
+coverUpFunction fm fb cfg eq0 =
+   (guard (coverLHS cfg) >> coverLeft eq0) ++
+   (guard (coverRHS cfg) >> coverRight eq0)
+ where
+   coverRight   = map (fmap flipSides) . coverLeft . flipSides
+   coverLeft eq = do
+      (e1, e2) <- fm (leftHandSide eq)
+      guard (predicateCovered  cfg e1)
+      new <- fb (rightHandSide eq) e2
+      _   <- Data.Traversable.mapM (guard . predicateCombined cfg) new
+      return (fmap (constructor eq e1) new)
+
+coverUpBinaryOrRule :: Relational r
+                   => String -> (Expr -> [(Expr, Expr)])
+                   -> (Expr -> Expr -> [OrList Expr])
+                   -> ConfigCoverUp -> Rule (OrList (r Expr))
+coverUpBinaryOrRule opName fm fb cfg =
+   let name = coverUpRuleName opName (configName cfg)
+   in makeRule name $ oneDisjunct $ coverUpFunction fm fb cfg
+
+coverUpBinaryRule :: Relational r => String
+                  -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr)
+                  -> ConfigCoverUp -> Rule (r Expr)
+coverUpBinaryRule opName fm fb cfg =
+   let name = coverUpRuleName opName (configName cfg)
+       fb2 a b = [[fb a b]]
+   in makeRule name $ map head . coverUpFunction fm fb2 cfg
+
+coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr)
+               -> ConfigCoverUp -> Rule (r Expr)
+coverUpUnaryRule opName fm fb =
+   coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb)
+
+coverUpRuleName :: String -> String -> Id
+coverUpRuleName opName cfg =
+   let f = if null cfg then newId else ( cfg # )
+   in "algebra.equations.coverup" # f opName
+
+---------------------------------------------------------------------
+-- Configuration for cover-up rules
+
+data ConfigCoverUp = Config
+   { configName        :: String
+   , predicateCovered  :: Expr -> Bool
+   , predicateCombined :: Expr -> Bool
+   , coverLHS          :: Bool
+   , coverRHS          :: Bool
+   }
+
+-- Default configuration: cover-up part with variables
+configCoverUp :: ConfigCoverUp
+configCoverUp = Config
+   { configName        = ""
+   , predicateCovered  = hasSomeVar
+   , predicateCombined = hasNoVar
+   , coverLHS          = True
+   , coverRHS          = True
+   }
+
+---------------------------------------------------------------------
+-- Parameterized cover-up rules
+
+coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr))
+coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb
+ where
+   fb rhs e2 = do
+      n <- isNat e2
+      guard (n > 0)
+      let new1 = root rhs (fromIntegral n)
+          new2 = neg new1
+      return $ singleton new1 <>
+         if even n && new1 /= new2 then singleton new2 else false
+
+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 "sqrt" isSqrt (\x -> x*x)
+ where
+   isSqrt (Sqrt a) = return a
+   isSqrt _        = []
+
+---------------------------------------------------------------------
+-- Cover-up rules for variables
+
+coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr)
+coverUpOrs = foldMap  (f . coverUp)
+ where
+   f :: Equation Expr -> OrList (Equation Expr)
+   f eq = case apply coverUpPower (singleton eq) of
+             Just xs -> coverUpOrs xs
+             Nothing -> singleton eq
+
+coverUp :: Equation Expr -> Equation Expr
+coverUp eq =
+   case mapMaybe (`apply` eq) coverUpRules of
+      hd:_ -> coverUp hd
+      _    -> eq
+
+coverUpRulesOr :: IsTerm a => [Rule (Context a)]
+coverUpRulesOr = use coverUpPower : map use 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       configCoverUp
+coverUpPlus        = coverUpPlusWith        configCoverUp
+coverUpMinusLeft   = coverUpMinusLeftWith   configCoverUp
+coverUpMinusRight  = coverUpMinusRightWith  configCoverUp
+coverUpTimes       = coverUpTimesWith       configCoverUp
+coverUpNegate      = coverUpNegateWith      configCoverUp
+coverUpNumerator   = coverUpNumeratorWith   configCoverUp
+coverUpDenominator = coverUpDenominatorWith configCoverUp
+coverUpSqrt        = coverUpSqrtWith        configCoverUp
+
+---------------------------------------------------------------------
+-- 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
+ src/Domain/Math/Equation/Examples.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Equation.Examples
+   ( fillInResult, coverUpEquations
+   ) where
+
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+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
+      ]
+ src/Domain/Math/Equation/Views.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( relationSolvedForm, relationsSolvedForm
+   , equationSolvedForm, equationsSolvedForm, equationSolvedWith
+   ) where
+
+import Data.Traversable
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Library
+
+relationsSolvedForm :: (Traversable f, Relational g) =>
+   View (f (g Expr)) (f (Expr -> Expr -> g Expr, String, Expr))
+relationsSolvedForm = "relations.solved" @> traverseView relationSolvedForm
+
+-- The variable may appear on one of the sides of the relation (right-hand side
+-- is thus allowed), but must be isolated
+relationSolvedForm :: Relational f =>
+   View (f Expr) (Expr -> Expr -> f Expr, String, Expr)
+relationSolvedForm = "relation.solved" @> makeView f g
+ where
+   f r = case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of
+            (Just x, Nothing) | withoutVar x (rightHandSide r) ->
+               return (constructor r, x, rightHandSide r)
+            (Nothing, Just x) | withoutVar x (leftHandSide r) ->
+               return (flip (constructor r), x, leftHandSide r)
+            _ -> Nothing
+   g (make, s, e) = make (Var s) e
+
+-------------------------------------------------------------
+-- Views on equations
+
+equationsSolvedForm :: View (OrList (Equation Expr)) (OrList (String, Expr))
+equationsSolvedForm = "equations.solved" @> traverseView equationSolvedForm
+
+equationSolvedForm :: View (Equation Expr) (String, Expr)
+equationSolvedForm = "equation.solved" @> makeView f g
+ where
+   f (Var x :==: e) | withoutVar x e =
+      return (x, e)
+   f _ = Nothing
+   g (s, e) = Var s :==: e
+
+equationSolvedWith :: View Expr a -> View (Equation Expr) (String, a)
+equationSolvedWith v = "equation.solved-with" @> makeView f g
+ where
+   f (lhs :==: rhs) = do
+      x <- getVariable lhs
+      a <- match v rhs
+      return (x, a)
+   g (s, a) = Var s :==: build v a
+ src/Domain/Math/ExerciseList.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- All exported exercises in the mathematical domain
+--
+-----------------------------------------------------------------------------
+module Domain.Math.ExerciseList
+   ( exerciseList, viewList, scriptList, testSuiteList
+   ) where
+
+import Domain.Math.Data.Interval
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Primes
+import Domain.Math.Derivative.Exercises
+import Domain.Math.Equation.CoverUpExercise
+import Domain.Math.Expr
+import Domain.Math.Fraction.Exercises
+import Domain.Math.Numeric.Exercises
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Balance
+import Domain.Math.Polynomial.Exercises
+import Domain.Math.Polynomial.IneqExercises
+import Domain.Math.Polynomial.LeastCommonMultiple
+import Domain.Math.Polynomial.RationalExercises
+import Domain.Math.Power.Equation.Exercises
+import Domain.Math.Power.Exercises
+import Ideas.Common.Library
+import Ideas.Common.Utils (Some(..))
+import Ideas.Common.Utils.TestSuite
+import qualified Domain.Math.Numeric.Tests as MathNum
+import qualified Domain.Math.Polynomial.Tests as MathPoly
+import qualified Domain.Math.SquareRoot.Tests as MathSqrt
+
+exerciseList :: [Some Exercise]
+exerciseList =
+   [ -- basic math
+   -- , Some naturalExercise
+   -- , Some integerExercise
+   -- , Some rationalExercise
+     Some fractionExercise
+   , Some fractionLiberalExercise
+   , Some simpleFractionAddition
+   , Some coverUpExercise
+   , Some linearExercise
+   , Some linearMixedExercise
+   , Some balanceExercise
+   , Some quadraticExercise
+   , Some higherDegreeExercise
+   , Some findFactorsExercise
+   , Some expandExercise
+   , Some ineqLinearExercise
+   , Some ineqQuadraticExercise
+   , Some ineqHigherDegreeExercise
+   , Some rationalEquationExercise
+   , Some simplifyRationalExercise
+   -- , Some divisionBrokenExercise
+   , Some quadraticNoABCExercise
+   , Some quadraticWithApproximationExercise
+   , Some derivativeExercise
+   , Some derivativePolyExercise
+   , Some derivativeProductExercise
+   , Some derivativeQuotientExercise
+   -- , Some derivativePowerExercise
+   , Some simplifyPowerExercise
+   , Some powerOfExercise
+   , Some nonNegBrokenExpExercise
+   , Some calcPowerExercise
+   , Some powerEqExercise
+   , Some expEqExercise
+   , Some logEqExercise
+--   , Some higherPowerEqExercise
+   ]
+
+viewList :: [ViewPackage]
+viewList =
+   [ exprVP sumView
+   , exprVP naturalView, exprVP naturalNF
+   , exprVP integerView, exprVP integerNF
+   , exprVP decimalFractionView
+   , exprVP rationalView, exprVP rationalNF
+   , exprVP mixedFractionView, exprVP mixedFractionNF
+   , exprVP doubleView, exprVP doubleNF
+   ]
+ where
+   exprVP :: (IsView f, Show a) => f Expr a -> ViewPackage
+   exprVP a = ViewPackage parseExprM (toView a)
+
+scriptList :: [(Id, FilePath)]
+scriptList =
+   [ (getId linearExercise,       "math.lineq-en.txt")
+   , (getId quadraticExercise,    "math.quadreq-en.txt")
+   , (getId higherDegreeExercise, "math.polyeq-en.txt")
+   ]
+
+testSuiteList :: [TestSuite]
+testSuiteList =
+   [ MathNum.main, MathPoly.tests, MathSqrt.tests, testMe, testLCM
+   , testPrimes, testPolynomials
+   ]
+ src/Domain/Math/Expr.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Export) where
+
+import Domain.Math.Expr.Clipboard as Export
+import Domain.Math.Expr.Data as Export
+import Domain.Math.Expr.Parser as Export
+import Domain.Math.Expr.Symbols as Export
+import Domain.Math.Expr.Views as Export
+ src/Domain/Math/Expr/Clipboard.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 a clipboard, on which expressions can be placed. The clipboard
+-- is part of the environment (terms that are placed in a context)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Expr.Clipboard
+   ( -- * Data type
+     Clipboard
+     -- * Interface
+   , addToClipboard, removeClipboard, lookupClipboard
+     -- * Generalized interface
+   , addToClipboardG, lookupClipboardG
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Typeable
+import Domain.Math.Data.Relation
+import Domain.Math.Expr.Data
+import Domain.Math.Expr.Parser
+import Ideas.Common.Library
+import qualified Data.Map as M
+
+---------------------------------------------------------------------
+-- Clipboard variable
+
+newtype Clipboard = C {unC :: M.Map String Expr}
+   deriving Typeable
+
+instance Show Clipboard where
+   show = show . toExpr
+
+instance Read Clipboard where
+   readsPrec _ txt = do
+      expr <- parseExprM txt
+      clip <- fromExpr expr
+      return (clip, "")
+
+instance IsTerm Clipboard where
+   toTerm =
+      let f (s, a) = Var s :==: a
+      in toTerm . map f . M.toList . unC
+   fromTerm =
+      let f (x :==: a) = liftM (\k -> (k, a)) (getVariable x)
+      in liftM (C . M.fromList) . mapM f . fromTerm
+
+instance Reference Clipboard
+
+clipboard :: Ref Clipboard
+clipboard = makeRef "clipboard"
+
+getClipboard :: Context a -> Clipboard
+getClipboard = fromMaybe (C M.empty) . (clipboard ?)
+
+changeClipboard :: (Clipboard -> Clipboard) -> Context a -> Context a
+changeClipboard f c = insertRef clipboard (f (getClipboard c)) c
+
+---------------------------------------------------------------------
+-- Interface to work with clipboard
+
+addToClipboard :: String -> Expr -> Context a -> Context a
+addToClipboard = addToClipboardG
+
+lookupClipboard :: String -> Context b -> Maybe Expr
+lookupClipboard = lookupClipboardG
+
+removeClipboard :: String -> Context a -> Context a
+removeClipboard s = changeClipboard (C . M.delete s . unC)
+
+---------------------------------------------------------------------
+-- Generalized interface to work with clipboard
+
+addToClipboardG :: IsTerm a => String -> a -> Context b -> Context b
+addToClipboardG s a = changeClipboard (C . M.insert s (toExpr a) . unC)
+
+lookupClipboardG :: IsTerm a => String -> Context b -> Maybe a
+lookupClipboardG s c = clipboard ? c >>= M.lookup s . unC >>= fromExpr
+ src/Domain/Math/Expr/Data.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( Expr(..), toExpr, fromExpr, fromDouble
+   ) where
+
+import Control.Monad
+import Data.Char (isAlphaNum)
+import Data.List
+import Data.Maybe
+import Data.Ratio
+import Data.Typeable
+import Domain.Math.Data.Relation (relationSymbols)
+import Domain.Math.Expr.Symbols
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils.Uniplate
+import Test.QuickCheck
+import qualified Ideas.Common.Algebra.Field as F
+
+-----------------------------------------------------------------------
+-- Expression data type
+
+data Expr = -- Num
+            Expr :+: Expr
+          | Expr :*: Expr
+          | Expr :-: Expr
+          | Negate Expr
+          | Nat Integer
+            -- Fractional
+          | Expr :/: Expr
+            -- Floating-point
+          | Sqrt Expr
+          | Number Double -- positive only
+            -- Symbolic
+          | Var String
+          | Sym Symbol [Expr]
+   deriving (Eq, Ord, Typeable)
+
+-----------------------------------------------------------------------
+-- 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 WithFunctions Expr where
+   function s (a:as) -- make binary
+      | s == plusSymbol   = foldl (:+:) a as
+      | s == timesSymbol  = foldl (:*:) a as
+   function s [a, b]
+      | s == minusSymbol    = a :-: b
+      | s == divideSymbol   = a :/: b
+      | s == rationalSymbol = a :/: b
+      | s == mixedFractionBinarySymbol = a :+: b
+      | isRootSymbol s && 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)
+         _ -> fail "Expr.getFunction"
+
+-- Special symbol in Math-Bridge/ActiveMath
+mixedFractionBinarySymbol :: Symbol
+mixedFractionBinarySymbol = newSymbol "elementary.mixed_fraction"
+
+instance WithVars Expr where
+   variable = Var
+   getVariable (Var s) = return s
+   getVariable _       = fail "Expr.getVariable"
+
+fromDouble :: Double -> Expr
+fromDouble d
+   | d < 0     = negate (Number (abs d))
+   | otherwise = Number d
+
+-----------------------------------------------------------------------
+-- Uniplate instance
+
+instance Uniplate Expr where
+   uniplate expr =
+      case getFunction expr of
+         Just (s, as) -> plate function |- s ||* as
+         _            -> plate expr
+
+-----------------------------------------------------------------------
+-- Arbitrary instance
+
+instance Arbitrary Expr where
+   arbitrary = liftM fromInteger arbitrary
+      -- 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) -}
+
+-----------------------------------------------------------------------
+-- Pretty printer
+
+instance Show Expr where
+   show = showExpr operatorTable
+
+showExpr :: OperatorTable -> Expr -> String
+showExpr table = rec 0
+ where
+   rec :: Int -> Expr -> String
+   rec _ (Nat n)    = if n>=0 then show n else "(ERROR)" ++ show n
+   rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d
+   rec _ (Var s)
+      | all isAlphaNum s = s
+      | otherwise        = "\"" ++ s ++ "\""
+   rec i expr =
+      case getFunction expr of
+         Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol ->
+            parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a
+         Just (s, [Nat a, Nat b, Nat c]) | s == mixedFractionSymbol ->
+            let ok  = all (>= 0) [a, b, c]
+                err = if ok then "" else "(ERROR)"
+            in err ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]"
+         -- To do: remove special case for sqrt
+         Just (s, [a, b]) | isRootSymbol s && b == Nat 2 ->
+            parIf (i>10000) $ unwords ["sqrt", rec 10001 a]
+         Just (s, xs) | s == listSymbol ->
+            "[" ++ intercalate ", " (map (rec 0) xs) ++ "]"
+         Just (s, as) ->
+            case (lookup s symbolTable, as) of
+               (Just (InfixLeft, n, op), [x, y]) ->
+                  parIf (i>n) $ rec n x ++ op ++ rec (n+1) y
+               (Just (InfixRight, n, op), [x, y]) ->
+                  parIf (i>n) $ rec (n+1) x ++ op ++ rec n y
+               (Just (InfixNon, n, op), [x, y]) ->
+                  parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y
+               (Just (PrefixNon, n, op), [x]) ->
+                  parIf (i>=n) $ op ++ rec (n+1) x
+               _ ->
+                  parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as)
+         Nothing ->
+            error "showExpr"
+
+   showSymbol s
+      | isRootSymbol s = "root"
+      | isLogSymbol s  = "log"
+      | otherwise = show s
+
+   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 ++ ")"
+
+type OperatorTable = [(Associativity, [(Symbol, String)])]
+
+data Associativity = InfixLeft | InfixRight | PrefixNon
+                   | InfixNon
+   deriving (Show, Eq)
+
+operatorTable :: OperatorTable
+operatorTable =
+     (InfixNon, [ (s, space op) | (_, (op, s)) <- relationSymbols]) :
+   [ (InfixLeft,  [(plusSymbol, "+"), (minusSymbol, "-")])    -- 6
+   , (PrefixNon,  [(negateSymbol, "-")])                      -- 6+
+   , (InfixLeft,  [(timesSymbol, "*"), (divideSymbol, "/")])  -- 7
+   , (InfixRight, [(powerSymbol, "^")])                       -- 8
+   ]
+ where
+   space a = " " ++ a ++ " " -- for consistency with Show Equation
+
+instance F.SemiRing Expr where
+   (<+>) = (+)
+   zero  = 0
+   (<*>) = (*)
+   one   = 1
+
+instance F.Ring Expr where
+   plusInverse = negate
+   (<->)       = (-)
+
+instance F.Field Expr where
+   timesInverse = recip
+   (</>)        = (/)
+
+instance F.CoSemiRing Expr where
+   isPlus  = isPlus
+   isZero  = (==0)
+   isTimes = isTimes
+   isOne   = (==1)
+
+instance F.CoRing Expr where
+   isNegate = isNegate
+   isMinus  = isMinus
+
+instance F.CoField Expr where
+   isRecip _  = Nothing
+   isDivision = isDivide
+
+instance Different Expr where
+   different = (Nat 0, Nat 1)
+
+instance IsTerm Expr where
+   toTerm (Nat n)    = TNum n
+   toTerm (Number d) = TFloat d
+   toTerm (Var v)    = TVar v
+   toTerm expr =
+      case getFunction expr of
+         Just (s, xs)
+            | s == listSymbol -> TList (map toTerm xs)
+            | otherwise       -> function s (map toTerm xs)
+         Nothing      -> error "IsTerm Expr"
+
+   fromTerm (TNum n)   = return (fromInteger n)
+   fromTerm (TFloat d) = return (fromDouble d)
+   fromTerm (TVar v)   = return (Var v)
+   fromTerm (TList xs) = liftM (function listSymbol) (mapM fromTerm xs)
+   fromTerm t =
+      case getFunction t of
+         Just (s, xs) -> do
+            ys <- mapM fromTerm xs
+            return (function s ys)
+         _ -> fail "fromTerm"
+
+toExpr :: IsTerm a => a -> Expr
+toExpr = fromJust . fromTerm . toTerm
+
+fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a
+fromExpr = fromTerm . toTerm
+ src/Domain/Math/Expr/Parser.hs view
@@ -0,0 +1,204 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( parseExpr, parseExprM
+   , parseEqExpr, parseBoolEqExpr, parseRelExpr
+   , parseOrsEqExpr, parseOrsRelExpr
+   , parseLogicRelExpr
+   , parseExprTuple
+   ) where
+
+import Control.Monad
+import Data.Monoid
+import Domain.Logic.Formula (Logic, catLogic)
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Data.WithBool
+import Domain.Math.Expr.Data
+import Domain.Math.Expr.Symbols
+import Ideas.Common.Library hiding ((<*>), (<|>), many, many1, try, ors)
+import Ideas.Text.Parsing
+import Prelude hiding ((^))
+import qualified Text.ParserCombinators.Parsec.Token as P
+
+parseExpr :: String -> Either String Expr
+parseExpr = parseSimple expr
+
+parseExprM :: Monad m => String -> m Expr
+parseExprM = either fail return . parseExpr
+
+parseEqExpr :: String -> Either String (Equation Expr)
+parseEqExpr = parseSimple (equation expr)
+
+parseBoolEqExpr :: String -> Either String (WithBool (Equation Expr))
+parseBoolEqExpr = parseSimple (boolAtom (equation expr))
+
+parseRelExpr :: String -> Either String (Relation Expr)
+parseRelExpr = parseSimple (relation expr)
+
+parseOrsEqExpr :: String -> Either String (OrList (Equation Expr))
+parseOrsEqExpr = parseSimple (ors (equation expr))
+
+parseOrsRelExpr :: String -> Either String (OrList (Relation Expr))
+parseOrsRelExpr = parseSimple (ors (relation expr))
+
+parseLogicRelExpr :: String -> Either String (Logic (Relation Expr))
+parseLogicRelExpr = parseSimple (catLogic <$> logic (relationChain expr))
+
+parseExprTuple :: String -> Either String [Expr]
+parseExprTuple = parseSimple (tuple expr)
+
+ors :: Parser a -> Parser (OrList a)
+ors p = mconcat <$> sepBy1 (boolAtom p) (reserved "or")
+
+logic :: Parser a -> Parser (Logic a)
+logic p = buildExpressionParser table (boolAtom p)
+ where
+   table =
+      [ [Infix ((<&&>) <$ reservedOp "and") AssocRight]
+      , [Infix ((<||>) <$ reservedOp "or" ) AssocRight]
+      ]
+
+boolAtom :: (Container f, BoolValue (f a)) => Parser a -> Parser (f a)
+boolAtom p = choice
+   [ true      <$  reserved "true"
+   , false     <$  reserved "false"
+   , singleton <$> p
+   ]
+
+equation :: Parser a -> Parser (Equation a)
+equation p = (:==:) <$> p <* reservedOp "==" <*> p
+
+relation :: Parser a -> Parser (Relation a)
+relation p = p <**> relType <*> p
+
+relationChain :: Parser a -> Parser (Logic (Relation a))
+relationChain p = (\x -> ands . make x) <$> p <*> many1 ((,) <$> relType <*> p)
+ where
+   make _ []             = []
+   make a ((f, b): rest) = singleton (f a b) : make b rest
+
+relType :: Parser (a -> a -> Relation a)
+relType = choice (map make table)
+ where
+   make (s, f) = f <$ reservedOp s
+   table =
+      [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.))
+      , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.))
+      ]
+
+tuple :: Parser a -> Parser [a]
+tuple p = parens (sepBy p comma)
+
+expr :: Parser Expr
+expr = buildExpressionParser exprTable term
+
+term :: Parser Expr
+term = choice
+   [ sqrt <$ reserved "sqrt" <*> atom
+   , binary rootSymbol <$ reserved "root" <*> atom <*> atom
+   , binary logSymbol  <$ reserved "log"  <*> atom <*> atom
+   , do reserved "D"
+        x <- identifier <|> parens identifier
+        a <- atom
+        return $ unary diffSymbol (binary lambdaSymbol (Var x) a)
+   , do a  <- qualId
+        as <- many atom
+        return (function (newSymbol a) as)
+   , atom
+   ]
+
+pmixed :: Parser Expr
+pmixed = do
+   a      <- natural
+   P.brackets lexer $ do
+      b <- natural
+      reservedOp "/"
+      c <- natural
+      return $ mixed a b c
+
+atom :: Parser Expr
+atom = choice
+   [ try pmixed
+   , do notFollowedBy (char '-')
+        either fromInteger fromDouble <$> naturalOrFloat
+   , variable <$> identifier
+   , parens expr
+   ]
+
+exprTable :: [[Operator Char () Expr]]
+exprTable =
+   [ -- precedence level 7
+     [ Infix ((^) <$ reservedOp "^") AssocRight
+     ]
+     -- precedence level 7
+   , [ Infix ((*) <$ reservedOp "*") AssocLeft
+     , Infix ((/) <$ reservedOp "/") AssocLeft
+     ]
+     -- precedence level 6+
+   , [ Prefix (negate <$ reservedOp "-")
+     ]
+     -- precedence level 6
+   , [ Infix ((+) <$ reservedOp "+") AssocLeft
+     , Infix ((-) <$ reservedOp "-") AssocLeft
+     ]
+   ]
+
+--------------------------------------------------------------------------
+-- Lexing
+
+lexer :: P.TokenParser a
+lexer = P.makeTokenParser $ emptyDef
+   { reservedNames   = ["sqrt", "root", "log", "and", "or", "true", "false", "D"]
+   , reservedOpNames = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]
+   , opStart         =  oneOf ":!#$%&*+./<=>?@\\^|-~"
+   , opLetter        =  oneOf ":!#$%&*+./<=>?@\\^|-~"
+   }
+
+identifier :: Parser String
+identifier = P.identifier lexer
+
+qualId :: CharParser st Id
+qualId = try (P.lexeme lexer (do
+   xs <- idPart `sepBy1` char '.'
+   guard (length xs > 1)
+   return (mconcat (map newId xs)))
+ <?> "qualified identifier")
+ where
+   idPart   = (:) <$> letter <*> many idLetter
+   idLetter = alphaNum <|> oneOf "-_"
+
+natural :: Parser Integer
+natural = P.natural lexer
+
+reserved :: String -> Parser ()
+reserved = P.reserved lexer
+
+reservedOp :: String -> Parser ()
+reservedOp = P.reservedOp lexer
+
+comma :: Parser String
+comma = P.comma lexer
+
+parens :: Parser a -> Parser a
+parens = P.parens lexer
+
+-----------------------------------------------------------------------
+-- Argument descriptor (for parameterized rules)
+
+instance Read Expr where
+   readsPrec _ input =
+      case parseExpr input of
+         Left _  -> []
+         Right a -> [(a, "")]
+
+instance Reference Expr
+ src/Domain/Math/Expr/Symbols.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Exports relevant OpenMath symbols
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Expr.Symbols
+   ( -- OpenMath dictionary symbols
+     plusSymbol, timesSymbol, minusSymbol, divideSymbol, rationalSymbol
+   , rootSymbol, gcdSymbol, lcmSymbol
+   , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol
+   , diffSymbol, piSymbol, lambdaSymbol, listSymbol
+   , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol
+   , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol
+   , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol
+     -- Matching
+   , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot
+   , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol
+   , isMixedFractionSymbol
+   , (^), root, mixed
+   ) where
+
+import Control.Monad
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+import qualified Ideas.Text.OpenMath.Dictionary.Arith1 as OM
+import qualified Ideas.Text.OpenMath.Dictionary.Calculus1 as OM
+import qualified Ideas.Text.OpenMath.Dictionary.Fns1 as OM
+import qualified Ideas.Text.OpenMath.Dictionary.List1 as OM
+import qualified Ideas.Text.OpenMath.Dictionary.Nums1 as OM
+import qualified Ideas.Text.OpenMath.Dictionary.Transc1 as OM
+
+-------------------------------------------------------------
+-- Arith1 dictionary
+
+plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol,
+   powerSymbol, negateSymbol, absSymbol, gcdSymbol, lcmSymbol :: Symbol
+
+plusSymbol     = newSymbol OM.plusSymbol
+timesSymbol    = newSymbol OM.timesSymbol
+minusSymbol    = newSymbol OM.minusSymbol
+divideSymbol   = newSymbol OM.divideSymbol
+rootSymbol     = newSymbol OM.rootSymbol
+powerSymbol    = newSymbol OM.powerSymbol
+negateSymbol   = newSymbol OM.unaryMinusSymbol
+absSymbol      = newSymbol OM.absSymbol
+gcdSymbol      = newSymbol OM.gcdSymbol
+lcmSymbol      = newSymbol OM.lcmSymbol
+
+-------------------------------------------------------------
+-- Transc1 dictionary
+
+logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol,
+   sinhSymbol, tanhSymbol, coshSymbol :: Symbol
+
+logSymbol  = newSymbol OM.logSymbol
+sinSymbol  = newSymbol OM.sinSymbol
+cosSymbol  = newSymbol OM.cosSymbol
+lnSymbol   = newSymbol OM.lnSymbol
+expSymbol  = newSymbol OM.expSymbol
+tanSymbol  = newSymbol OM.tanSymbol
+sinhSymbol = newSymbol OM.sinhSymbol
+tanhSymbol = newSymbol OM.tanhSymbol
+coshSymbol = newSymbol OM.coshSymbol
+
+-------------------------------------------------------------
+-- Other dictionaries
+
+diffSymbol, lambdaSymbol, listSymbol, piSymbol, rationalSymbol :: Symbol
+
+diffSymbol     = newSymbol OM.diffSymbol
+lambdaSymbol   = newSymbol OM.lambdaSymbol
+listSymbol     = newSymbol OM.listSymbol
+piSymbol       = newSymbol OM.piSymbol
+rationalSymbol = newSymbol OM.rationalSymbol
+
+-------------------------------------------------------------
+-- Extra math symbols
+
+signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol,
+   acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol :: Symbol
+
+signumSymbol = newSymbol "signum"
+asinSymbol   = newSymbol "asin"
+atanSymbol   = newSymbol "atan"
+acosSymbol   = newSymbol "acos"
+asinhSymbol  = newSymbol "asinh"
+atanhSymbol  = newSymbol "atanh"
+acoshSymbol  = newSymbol "acosh"
+bottomSymbol = newSymbol "error"
+fcompSymbol  = newSymbol "compose"
+
+-- support for mixed fractions
+mixedFractionSymbol = newSymbol ("extra", "mixedfraction")
+
+-------------------------------------------------------------
+-- Some match functions
+
+isPlus, isTimes, isMinus, isDivide, isPower, isRoot ::
+   (WithFunctions a, MonadPlus m) => a -> m (a, a)
+isNegate :: (WithFunctions a, MonadPlus m) => a -> m a
+
+isPlus   = isAssoBinary plusSymbol
+isTimes  = isAssoBinary timesSymbol
+isMinus  = isBinary     minusSymbol
+isDivide = isBinary     divideSymbol
+isNegate = isUnary      negateSymbol
+isPower  = isBinary     powerSymbol
+isRoot   = isBinary     rootSymbol
+
+isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol,
+   isMixedFractionSymbol :: Symbol -> Bool
+
+isPowerSymbol  = (== powerSymbol)
+isRootSymbol   = (== rootSymbol)
+isLogSymbol    = (== logSymbol)
+isDivideSymbol = (== divideSymbol)
+
+isMixedFractionSymbol = (== mixedFractionSymbol)
+
+infixr 8 ^
+
+(^) :: WithFunctions a => a -> a -> a
+(^) = binary powerSymbol
+
+root :: WithFunctions a => a -> a -> a
+root = binary rootSymbol
+
+mixed :: (Num a, WithFunctions a) => Integer -> Integer -> Integer -> a
+mixed a b c = function mixedFractionSymbol $ map fromInteger [a, b, c]
+
+-------------------------------------------------------------
+-- Helper
+
+-- left-associative
+isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)
+isAssoBinary s a =
+   case isFunction s a of
+      Just [x, y] -> return (x, y)
+      Just (x:xs) | length xs > 1 -> return (x, function s xs)
+      _ -> fail "isAssoBinary"
+ src/Domain/Math/Expr/Views.hs view
@@ -0,0 +1,152 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( module Domain.Math.Expr.Views
+   , (.+.), (.-.), neg, (.*.), (./.)
+   ) where
+
+import Domain.Math.Expr.Data
+import Domain.Math.Expr.Symbols
+import Ideas.Common.Algebra.Group
+import Ideas.Common.Algebra.SmartGroup
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate
+import Prelude hiding ((^))
+import qualified Data.Set as S
+
+------------------------------------------------------------
+-- Smart constructors
+
+infixr 8 .^.
+
+(.^.) :: 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 (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 (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 (a :/: b)  = Just (a, b)
+   matchDiv (Negate a) = do (x, y) <- matchDiv a
+                            Just (neg x, y)
+   matchDiv _          = Nothing
+
+-------------------------------------------------------------
+-- Sums and products
+
+sumView :: Isomorphism Expr [Expr]
+sumView = describe "View an expression as the sum of a list of elements, \
+   \taking into account associativity of plus, its unit element zero, and \
+   \inverse (both unary negation, and binary subtraction)." $
+   "math.sum" @> sumEP
+ where
+   sumEP = (($ []) . f False) <-> foldl (.+.) 0
+
+   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 _ (Nat 0)    = id
+   f n e          = if n then (neg e:) else (e:)
+
+-- no distribution
+simpleSumView :: Isomorphism Expr [Expr]
+simpleSumView = sumEP
+ where
+   sumEP = f <-> foldl (.+) 0
+
+   f (a :+: b)           = f a <> f b
+   f (a :-: b)           = f a <> f (-b)
+   f (Nat 0)             = mempty
+   f (Negate (Nat 0))    = mempty
+   f (Negate (Negate a)) = f a
+   f a                   = return a
+
+   Nat 0 .+ b = b
+   a .+ Nat 0 = a
+   a .+ Negate b  = a :-: b
+   a .+ b = a :+: b
+
+productView :: Isomorphism Expr (Bool, [Expr])
+productView = "math.product" @> productEP
+ where
+   productEP = (second ($ []) . f False) <-> g
+
+   f r (a :*: b)  = f r a .&. f r b
+   f r (a :/: b)  = case a of -- two special cases (for efficiency)
+                       Nat 1          -> f (not r) b
+                       Negate (Nat 1) -> first not (f (not r) 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)
+
+simpleProductView :: Isomorphism Expr (Bool, [Expr])
+simpleProductView = "math.product.simple" @> simpleProductEP
+ where
+   simpleProductEP = (second ($ []) . f) <-> g
+
+   f (a :*: b)  = f a .&. f b
+   f (Nat 1)    = (False, id)
+   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 myNeg else id) (foldl (.*) 1 xs)
+
+   Nat 1 .* a = a
+   a .* Nat 1 = a
+   Nat 0 .* a | ok a = 0
+   a .* Nat 0 | ok a = 0
+   Negate a .* b = myNeg (a .* b)
+   a .* Negate b = myNeg (a .* b)
+   a .* b = a :*: b
+
+   myNeg (Negate a) = a
+   myNeg a = Negate a
+
+   ok (a :/: b) = b /= 0 && ok a && ok b -- to do: evaluate b before b/=0
+   ok a = all ok (children a)
+
+-- helper to determine the name of the variable (move to a different module?)
+selectVar :: Expr -> Maybe String
+selectVar = f  . S.toList . varSet
+ where
+   f []  = Just "x" -- exceptional case (e.g., for constants)
+   f [a] = Just a
+   f _   = Nothing
+ src/Domain/Math/Fraction/Exercises.hs view
@@ -0,0 +1,37 @@+module Domain.Math.Fraction.Exercises
+   ( simpleFractionAddition
+   ) where
+
+import Domain.Math.Expr
+import Domain.Math.Fraction.Rules
+import Domain.Math.Fraction.Strategies
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate
+
+simpleFractionAddition :: Exercise Expr
+simpleFractionAddition = makeExercise
+ { status      = Alpha
+ , exerciseId  = describe "Fraction exercise for STEPS" $
+                 newId "arithmetic.fractions.steps"
+ , parser      = parseExpr
+ , strategy    = expandAndAdd
+ , navigation  = termNavigator
+ , equivalence = withoutContext areEqual
+ , extraRules  = map use [gcdRule, lcmRule, expandRule, reduceRule]
+ }
+
+areEqual :: Expr -> Expr -> Bool
+areEqual = viewEquivalent (extraSymbols >>> rationalView)
+
+-- This view handles the reduce and expand symbols for the euquivalence test.
+-- Semantically, reduce(a,b) = a.
+extraSymbols :: View Expr Expr
+extraSymbols = makeView (Just . f) id
+ where
+   f expr =
+      case getFunction expr of
+         Just (s, [x, _])
+            | s == reduceFractionSymbol -> f x
+            | s == expandFractionSymbol -> f x
+         _ -> descend f expr
+ src/Domain/Math/Fraction/Rules.hs view
@@ -0,0 +1,89 @@+module Domain.Math.Fraction.Rules where
+
+import Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Expr.Clipboard
+import Domain.Math.Numeric.Rules (calcPlusWith, calcMinusWith, calcTimesWith, calcDivisionWith)
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+expandFractionSymbol :: Symbol
+expandFractionSymbol = newSymbol "elementary.expand_fraction"
+
+reduceFractionSymbol :: Symbol
+reduceFractionSymbol = newSymbol "elementary.reduce_fraction"
+
+-- Matching, borrowing from "Canonical forms..." MKM
+additionView :: View Expr (Expr, Expr)
+additionView = makeView f g
+ where
+   f (a :+: b) = Just (a,b)
+   f _         = Nothing
+
+   g (a, b) = a :+: b
+
+fractionView :: View Expr (Expr, Expr)
+fractionView = makeView f g
+ where
+   f (a :/: b) = Just (a,b)
+   f _         = Nothing
+
+   g (a, b) = a :/: b
+
+-- Find LCM, store it in the context
+findLCM :: Rule (Context Expr)
+findLCM = makeRule "findLCM" $ \ctx -> do
+            expr <- currentInContext ctx
+            (e1,e2) <- match additionView expr
+            (Nat _,Nat b)   <- match fractionView e1
+            (Nat _,Nat d)   <- match fractionView e2
+            guard (b/=d)
+            return $ addToClipboard "lcm" (Nat (lcm b d)) ctx
+
+-- expand unlike fractions to lcm if necessary
+expandToLCM :: Rule (Context Expr)
+expandToLCM = makeRule "expandToLCM" $ \ctx -> do
+                 expr <- currentInContext ctx
+                 (Nat a,Nat b) <- match fractionView expr
+                 lcm <- lookupClipboardG "lcm" ctx
+                 guard (b /= lcm && lcm `mod` b == 0)
+                 return $ replaceInContext (Nat(a * lcm `div` b) :/: Nat lcm) ctx
+
+addLikeFractions :: Rule (Context Expr)
+addLikeFractions = makeRule "addLikeFractions" $ \ctx -> do
+                     expr <- currentInContext ctx
+                     (e1,e2) <- match additionView expr
+                     (Nat a,Nat b)   <- match fractionView e1
+                     (Nat c,Nat d)   <- match fractionView e2
+                     guard (b == d)
+                     return $ replaceInContext (Nat(a + c) :/: Nat b) ctx
+
+-- Extra rules for diagnostics
+
+gcdRule :: Rule Expr
+gcdRule = makeRule "gcd" f
+  where
+    f (Sym gs [Nat a , Nat b]) | gs == gcdSymbol =
+      Just (Nat (gcd a b))
+    f _ = Nothing
+
+lcmRule :: Rule Expr
+lcmRule = makeRule  "lcm" f
+  where
+    f (Sym ls [Nat a, Nat b]) | ls == lcmSymbol =
+      Just (Nat (lcm a b))
+    f _ = Nothing
+
+expandRule :: Rule Expr
+expandRule = makeRule "expand" f
+ where
+   f (Sym efs [Nat a :/: Nat b, Nat c]) | efs == expandFractionSymbol =
+      Just (Nat (a*c) :/:Nat (b*c))
+   f _ = Nothing
+
+reduceRule :: Rule Expr
+reduceRule = makeRule "reduce" f
+  where
+    f (Sym cfs [Nat a :/: Nat b, Nat c]) | a `mod` c == 0 && b `mod`c == 0 && cfs == reduceFractionSymbol =
+      Just (Nat (a `div` c) :/: Nat (b `div` c))
+    f _ = Nothing
+ src/Domain/Math/Fraction/Strategies.hs view
@@ -0,0 +1,12 @@+module Domain.Math.Fraction.Strategies
+    (expandAndAdd) where
+
+import Domain.Math.Expr
+import Domain.Math.Fraction.Rules
+import Ideas.Common.Library
+
+expandAndAdd :: LabeledStrategy (Context Expr)
+expandAndAdd = label "expandAndAdd" $
+               try findLCM
+               <*> repeatS ( somewhere (expandToLCM ))
+               <*>  addLikeFractions
+ src/Domain/Math/Numeric/Examples.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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  :  johan.jeuring@ou.nl
+-- Stability   :  alpha
+-- Portability :  portable (depends on ghc)
+--
+-- Example exercises from ActiveMath
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Numeric.Examples
+   ( fractionExamples
+   , fractionLiberalExamples
+   ) where
+
+import Domain.Math.Expr
+import Ideas.Common.Exercise
+import Prelude hiding ((^))
+
+fractionExamples :: Examples Expr
+fractionExamples =
+   level Easy
+      [ 3/5 + 1/3
+      , 1/2 + 2/4
+      , 3/2 + 2/3
+      , 7/11 + 3/11 ] ++
+   level Medium -- NKBW tests (bridging test between secondary and tertiary education)
+      [ (2/3+2/7)/(4/7-1/3) -- VWO B, Sep 2010
+      , 18/(4/5-1/2) -- VWO A, Sep 2010
+      ]
+
+fractionLiberalExamples :: Examples Expr
+fractionLiberalExamples =
+   level Easy
+      [ 3/5 + 1/3
+      , 1/2 + 2/4
+      , 3/2 + 2/3
+      , 7/11 + 3/11 ]
+ src/Domain/Math/Numeric/Exercises.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   , fractionLiberalExercise
+   ) where
+
+import Domain.Math.Expr
+import Domain.Math.Numeric.Examples
+import Domain.Math.Numeric.Generators
+import Domain.Math.Numeric.Strategies
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+------------------------------------------------------------
+-- Exercises
+
+numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr
+numericExercise s = makeExercise
+   { status       = Alpha
+   , parser       = parseExpr
+   , equivalence  = withoutContext (viewEquivalent rationalView)
+   , strategy     = s
+   , navigation   = termNavigator
+   }
+
+naturalExercise :: Exercise Expr
+naturalExercise = (numericExercise naturalStrategy)
+   { exerciseId   = describe "simplify expression (natural numbers)" $
+                       newId "numbers.natural"
+   , ready        = predicateView integerNF
+   , examples     = level Medium $ concat calculateResults
+   }
+
+integerExercise :: Exercise Expr
+integerExercise = (numericExercise integerStrategy)
+   { exerciseId   = describe "simplify expression (integers)" $
+                       newId "numbers.integers"
+   , ready        = predicateView integerNF
+   , examples     = level Medium $ concat calculateResults
+   }
+
+rationalExercise :: Exercise Expr
+rationalExercise = (numericExercise rationalStrategy)
+   { exerciseId     = describe "simplify expression (rational numbers)" $
+                         newId "numbers.rational"
+   , ready          = predicateView rationalNF
+   , randomExercise = simpleGenerator (rationalGenerator 5)
+   }
+
+fractionExercise :: Exercise Expr
+fractionExercise = (numericExercise fractionStrategy)
+   { exerciseId     = describe "simplify fractions" $
+                         newId "arithmetic.fractions"
+   , status         = Provisional
+   , ready          = predicateView rationalNF
+   , examples       = fractionExamples
+   , strategy       = fractionStrategy
+--   , randomExercise = simpleGenerator (rationalGenerator 5) -- JJ: This is not a very good random generator for fraction exercises.
+   }
+
+fractionLiberalExercise :: Exercise Expr
+fractionLiberalExercise = (numericExercise fractionLiberalStrategy)
+   { exerciseId     = describe "simplify fractions liberally" $
+                         newId "arithmetic.fractions.liberal"
+   , status         = Provisional
+   , ready          = predicateView rationalNF
+   , examples       = fractionLiberalExamples
+   , strategy       = fractionLiberalStrategy
+--   , randomExercise = simpleGenerator (rationalGenerator 5) -- JJ: This is not a very good random generator for fraction exercises.
+   }
+
+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
+      ]
+ src/Domain/Math/Numeric/Generators.hs view
@@ -0,0 +1,109 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Data.Ratio
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+import Test.QuickCheck
+
+-------------------------------------------------------------------
+-- 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 -> elements
+                 [ 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)
+                elements
+                   [ (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 :: (Eq a,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))
+
+-------------------------------------------------------------------
+-- Helpers
+
+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
+
+-- | 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/Domain/Math/Numeric/Rules.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+------------------------------------------------------------
+-- Rules
+
+alg :: String
+alg = "algebra.manipulation"
+
+calcRuleName :: String -> String -> String
+calcRuleName opName viewName =
+   "arithmetic.operation." ++ viewName ++ "." ++ opName
+
+calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e
+calcBinRule opName op m viewName v =
+   makeRule (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 =
+   makeRule (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 = makeRule (alg, "negate-zero") f
+ where
+   f (Negate (Nat n)) | n == 0 = Just 0
+   f _                         = Nothing
+
+doubleNegate :: Rule Expr
+doubleNegate = makeRule (alg, "double-negate") f
+ where
+   f (Negate (Negate a)) = Just a
+   f _                   = Nothing
+
+plusNegateLeft :: Rule Expr
+plusNegateLeft = makeRule (alg, "plus-negate-left") f
+ where
+   f (Negate a :+: b) = Just (b :-: a)
+   f _                = Nothing
+
+plusNegateRight :: Rule Expr
+plusNegateRight = makeRule (alg, "plus-negate-right") f
+ where
+   f (a :+: Negate b) = Just (a :-: b)
+   f _                = Nothing
+
+minusNegateLeft :: Rule Expr
+minusNegateLeft = makeRule (alg, "minus-negate-left") f
+ where
+   f (Negate a :-: b) = Just (Negate (a :+: b))
+   f _                = Nothing
+
+minusNegateRight :: Rule Expr
+minusNegateRight = makeRule (alg, "minus-negate-right") f
+ where
+   f (a :-: Negate b) = Just (a :+: b)
+   f _                = Nothing
+
+timesNegateLeft :: Rule Expr
+timesNegateLeft = makeRule (alg, "times-negate-left") f
+ where
+   f (Negate a :*: b) = Just (Negate (a :*: b))
+   f _                = Nothing
+
+timesNegateRight :: Rule Expr
+timesNegateRight = makeRule (alg, "times-negate-right") f
+ where
+   f (a :*: Negate b) = Just (Negate (a :*: b))
+   f _                = Nothing
+
+divisionNegateLeft :: Rule Expr
+divisionNegateLeft = makeRule (alg, "division-negate-left") f
+ where
+   f (Negate a :/: b) = Just (Negate (a :/: b))
+   f _                = Nothing
+
+divisionNegateRight :: Rule Expr
+divisionNegateRight = makeRule (alg, "division-negate-right") f
+ where
+   f (a :/: Negate b) = Just (Negate (a :/: b))
+   f _                = Nothing
+
+divisionNumerator :: Rule Expr
+divisionNumerator = makeRule (alg, "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 = makeRule (alg, "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 = makeRule (alg, "simpler-fraction") $ \expr -> do
+   new <- canonical rationalRelaxedForm expr
+   guard (expr /= new)
+   return new
+
+fractionPlus :: Rule Expr -- also minus
+fractionPlus = makeRule (alg, "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 = makeRule (alg, "fraction-plus-scale") $ \expr -> do
+   (e1, e2) <- matchM plusView expr
+   (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
+   (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
+   guard (b /= 0 && d /= 0 && b /= d)
+   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 = makeRule (alg, "fraction-times") f
+ where
+   f (e1 :*: e2) = do
+      (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
+      (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
+      return (build fractionForm (a*c, b*d))
+   f _ = Nothing
+
+fractionTimesCancelNomDen :: Rule Expr
+fractionTimesCancelNomDen = makeRule (alg, "fraction-times-cancel-denominator-nominator") f
+ where
+   f (e1 :*: e2) = do
+      (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
+      (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
+      guard (a==d)
+      return (build fractionForm (c, b))
+   f _ = Nothing
+
+fractionTimesCancelDenNom :: Rule Expr
+fractionTimesCancelDenNom = makeRule (alg, "fraction-times-cancel-nominator-denominator") f
+ where
+   f (e1 :*: e2) = do
+      (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
+      (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
+      guard (b==c)
+      return (build fractionForm (a, d))
+   f _ = Nothing
+ src/Domain/Math/Numeric/Strategies.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   , fractionLiberalStrategy
+   ) where
+
+import Domain.Math.Expr
+import Domain.Math.Numeric.Rules
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+
+------------------------------------------------------------
+-- Strategies
+
+naturalStrategy :: LabeledStrategy (Context Expr)
+naturalStrategy = label "simplify" $
+   repeatS $ somewhere $ alternatives $ map use
+      [ calcPlusWith     "natural" natView
+      , calcMinusWith    "natural" natView
+      , calcTimesWith    "natural" natView
+      , calcDivisionWith "natural" 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 (Context Expr)
+integerStrategy = label "simplify" $
+   repeatS $ somewhere $ alternatives $ map use
+      [ calcPlusWith     "integer" integerNF
+      , calcMinusWith    "integer" integerNF
+      , calcTimesWith    "integer" integerNF
+      , calcDivisionWith "integer" integerNF
+      , doubleNegate, negateZero
+      ]
+
+rationalStrategy :: LabeledStrategy (Context Expr)
+rationalStrategy = label "simplify" $
+   repeatS $ somewhere $ alternatives $ map use
+      [ calcPlusWith     "rational" rationalRelaxedForm
+      , calcMinusWith    "rational" rationalRelaxedForm
+      , calcTimesWith    "rational" rationalRelaxedForm
+      , calcDivisionWith "integer"  integerNF
+      , doubleNegate, negateZero, divisionDenominator
+      , divisionNumerator, simplerFraction
+      ]
+
+fractionStrategy :: LabeledStrategy (Context Expr)
+fractionStrategy = label "simplify" $
+   repeatS $
+      somewhere
+         (  use (calcPlusWith     "integer" integerNF)
+        <|> use (calcMinusWith    "integer" integerNF)
+        <|> use (calcTimesWith    "integer" integerNF) -- not needed?
+        -- <|> use (calcDivisionWith "integer" integerNF)  -- not needed?
+         ) |>
+      somewhere
+         (use fractionTimesCancelDenNom <|> use fractionTimesCancelNomDen) |>
+      somewhere
+         (  use doubleNegate <|> use negateZero <|> use divisionDenominator
+        <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator
+         ) |>
+      somewhere (use fractionPlusScale) |>
+      somewhere (use simplerFraction)
+
+fractionLiberalStrategy :: LabeledStrategy (Context Expr)
+fractionLiberalStrategy = label "simplify" $
+   repeatS $
+      somewhere
+         (  use (calcPlusWith     "integer" integerNF)
+        <|> use (calcMinusWith    "integer" integerNF)
+        <|> use (calcTimesWith    "integer" integerNF) -- not needed?
+        -- <|> use (calcDivisionWith "integer" integerNF) -- not needed?
+        <|> use fractionTimesCancelDenNom
+        <|> use fractionTimesCancelNomDen
+        <|> use doubleNegate
+        <|> use negateZero
+        <|> use divisionDenominator
+        <|> use fractionPlus
+        <|> use fractionTimes
+        <|> use divisionNumerator
+        <|> use fractionPlusScale
+        <|> use simplerFraction
+         )
+ src/Domain/Math/Numeric/Tests.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Tests (main) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Monoid
+import Domain.Math.Expr
+import Domain.Math.Numeric.Generators
+import Domain.Math.Numeric.Strategies
+import Domain.Math.Numeric.Views
+import Ideas.Common.Classes
+import Ideas.Common.Context
+import Ideas.Common.Utils.TestSuite
+import Ideas.Common.View
+import Test.QuickCheck
+
+main :: TestSuite
+main = suite "Numeric tests" $ do
+
+   suite "Correctness numeric views" $ do
+      let f s v = forM_ numGenerators $ \g -> do
+             addProperty ("idempotence " ++ s) $ propIdempotence g v
+             addProperty ("soundness " ++ s)   $ propSoundness semEqDouble g v
+      f "integer view"          integerView
+      f "rational view"         rationalView
+      f "integer normal form"   integerNF
+      f "rational normal form"  rationalNF
+      f "rational relaxed form" rationalRelaxedForm
+
+   suite "Normal forms" $ do
+      let f s v = forM_ numGenerators $ \g ->
+             addProperty s $ propNormalForm g v
+      f "integer normal form" integerNF
+    -- f rationalNF -- no longer a normal form
+
+   suite "Correctness generators" $ do
+      let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v)
+      f "integer" integerGenerator integerView
+      f "rational" rationalGenerator rationalView
+      f "ratio expr" ratioExprGen rationalNF
+      f "ratio expr nonzero" ratioExprGenNonZero rationalNF
+
+   suite "View relations" $ do
+      let va .>. vb = forM_ numGenerators $ \g ->
+             addProperty "" $ forAll g $ \a ->
+                not (a `belongsTo` va) || a `belongsTo` vb
+      integerNF .>. integerView
+      rationalNF .>. rationalRelaxedForm
+      rationalRelaxedForm .>. rationalView
+      integerNF .>. rationalNF
+      integerView .>. rationalView
+
+   suite "Pre/post conditions strategies" $ do
+      let f l s pre post = forM_ numGenerators $ \g ->
+             addProperty l $ forAll g $ \a ->
+                let run = fromMaybe a . fromContext . applyD s
+                        . newContext mempty . termNavigator
+                in not (a `belongsTo` pre) || run a `belongsTo` post
+      f "natural"  naturalStrategy  integerView  integerNF
+      f "integer"  integerStrategy  integerView  integerNF
+      f "rational" rationalStrategy rationalView rationalNF
+      f "fraction" fractionStrategy rationalView rationalNF
+
+numGenerators :: [Gen Expr]
+numGenerators = map sized
+   [ integerGenerator, rationalGenerator
+   , ratioExprGen, ratioExprGenNonZero, numGenerator
+   ]
+
+semEqDouble :: Expr -> Expr -> Bool
+semEqDouble a b =
+   case (match doubleView a, match doubleView b) of
+      (Just x, Just y)   -> x ~= y
+      (Nothing, Nothing) -> True
+      _                  -> False
+ where
+   delta = 0.0001
+
+   (~=) :: Double -> Double -> Bool
+   x ~= y = abs x < delta || abs y < delta || abs (1 - (x/y)) < delta
+ src/Domain/Math/Numeric/Views.hs view
@@ -0,0 +1,250 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( -- * Natural numbers
+     naturalView, naturalNF
+     -- * Integers
+   , integerView, integerNF
+     -- * Decimal fractions
+   , decimalFractionView
+     -- * Rational numbers
+   , rationalView, rationalNF
+   , rationalRelaxedForm, fractionForm, rationalApproxView
+     -- * Mixed fractions
+   , mixedFractionView, mixedFractionNF
+     -- * Double
+   , doubleView, doubleNF
+   ) where
+
+import Control.Monad
+import Data.Ratio
+import Domain.Math.Expr hiding ((^))
+import Domain.Math.Safe
+import Ideas.Common.Id
+import Ideas.Common.Rewriting (function)
+import Ideas.Common.Utils.Uniplate (descend)
+import Ideas.Common.View
+import qualified Domain.Math.Data.DecimalFraction as DF
+import qualified Domain.Math.Data.MixedFraction as MF
+
+-------------------------------------------------------------------
+-- Natural numbers
+
+-- |Non-negative numbers only, also for intermediate results
+naturalView :: View Expr Integer
+naturalView = "num.natural" @> makeView rec (fromInteger . abs)
+ where
+   rec :: Expr -> Maybe Integer
+   rec expr = do
+      x <- matchInteger rec expr
+      guard (x >= 0)
+      return x
+
+naturalNF :: View Expr Integer
+naturalNF = "num.natural.nf" @> makeView f (build naturalView)
+ where
+   f (Nat n) = Just n
+   f _       = Nothing
+
+-------------------------------------------------------------------
+-- Integers
+
+integerView :: View Expr Integer
+integerView = "num.integer" @> makeView (fix matchInteger) fromIntegral
+
+-- N or -N (where n is a natural number)
+integerNF :: View Expr Integer
+integerNF = "num.integer.nf" @> makeView (optionNegate f) fromInteger
+ where
+   f (Nat n) = Just n
+   f _       = Nothing
+
+matchInteger :: (Expr -> Maybe Integer) -> Expr -> Maybe Integer
+matchInteger f expr =
+   case expr of
+      a :/: b -> join (liftM2 safeDiv (f a) (f b))
+      Sqrt a  -> f a >>= safeSqrt
+      Sym s [a, b]
+         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
+         | isRootSymbol  s -> join (liftM2 safeRoot  (f a) (f b))
+      _ -> matchNum f expr
+
+matchNum :: Num a => (Expr -> Maybe a) -> Expr -> Maybe a
+matchNum f expr =
+   case expr of
+      Nat n    -> return (fromInteger n)
+      a :+: b  -> liftM2 (+) (f a) (f b)
+      a :-: b  -> liftM2 (-) (f a) (f b)
+      Negate a -> liftM negate (f a)
+      a :*: b  -> liftM2 (*) (f a) (f b)
+      _        -> Nothing
+
+-------------------------------------------------------------------
+-- Decimal fractions
+
+decimalFractionView :: View Expr DF.DecimalFraction
+decimalFractionView = "num.decimal" @> makeView (fix matchDecimal) f
+ where
+   f = fromDouble . fromRational . toRational
+
+matchDecimal :: (Expr -> Maybe DF.DecimalFraction) -> Expr -> Maybe DF.DecimalFraction
+matchDecimal f expr =
+   case expr of
+      Number d -> Just (DF.fromDouble d)
+      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
+      Sym s [a, b]
+         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
+      Sym s [a, b, c]
+         | isMixedFractionSymbol s -> f (a+b/c)
+      _ -> matchNum f expr
+
+-------------------------------------------------------------------
+-- Rational numbers
+
+-- |like  the original defintion, except that this view
+-- now also converts floating point numbers (using an exact approximation)
+rationalView :: View Expr Rational
+rationalView = describe "Interpret an expression as a (normalized) rational \
+   \number, performing computations such as addition and multiplication if \
+   \necessary." $
+   "number.rational" @> makeView f fromRational
+ where
+   f a = matchExact a >>= either (const Nothing) Just
+
+matchRational :: (Expr -> Maybe Rational) -> Expr -> Maybe Rational
+matchRational f expr =
+   case expr of
+      Number d -> return $ fromRational $ toRational $ DF.fromDouble d
+      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
+      Sqrt a   -> f a >>= safeSqrt
+      Sym s [a, b]
+         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
+         | isRootSymbol  s -> join (liftM2 safeRoot  (f a) (f b))
+      Sym s [a, b, c]
+         | isMixedFractionSymbol s -> f (a+b/c)
+      _ -> matchNum f expr
+
+matchExact :: Expr -> Maybe (Either Double Rational)
+matchExact expr =
+   fmap Left (match doubleNF expr) `mplus`
+   fmap Right (fix matchRational expr)
+
+-- first convert (approximate!) all numbers to their decimal representation
+rationalApproxView :: View Expr Rational
+rationalApproxView = makeView (match rationalView . f) fromRational
+ where
+   f (Number d) = fromRational $ toRational $ DF.fromDouble d
+   f expr       = descend f expr
+
+-- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5)
+rationalNF :: View Expr Rational
+rationalNF = "num.rational.nf" @> makeView f fromRational
+ where
+   f (Nat a :/: Nat b) = simpleRational a b
+   f (Negate (Nat a :/: Nat b)) = fmap negate (simpleRational a b)
+   f (Negate (Nat a) :/: Nat b) = fmap negate (simpleRational a b)
+   f a = fmap fromInteger (match integerNF a)
+
+simpleRational :: Integer -> Integer -> Maybe Rational
+simpleRational a b = do
+   guard (a > 0 && b > 1 && gcd a b == 1)
+   return (fromInteger a / fromInteger b)
+
+fractionForm :: View Expr (Integer, Integer)
+fractionForm = "num.fraction-form" @> makeView f g
+ where
+   f = match (divView >>> integerNF *** integerNF)
+   g (a, b) = fromInteger a ./. fromInteger b
+
+rationalRelaxedForm :: View Expr Rational
+rationalRelaxedForm = "num.rational-relaxed" @> makeView (optionNegate f) fromRational
+ where
+   f (e1 :/: e2) = do
+      a <- match integerNF e1
+      b <- match integerNF e2
+      safeDiv (fromInteger a) (fromInteger b)
+   f (Nat n) = Just (fromInteger n)
+   f _       = Nothing
+
+-------------------------------------------------------------------
+-- Mixed fractions
+
+mixedFractionView :: View Expr MF.MixedFraction
+mixedFractionView = "num.mixed-fraction" @> makeView f (sign g)
+ where
+   f = fmap fromRational . fix matchRational
+
+   sign k a | a < 0     = negate (k (abs a))
+            | otherwise = k a
+
+   g a
+      | frac  == 0 = fromInteger  whole
+      | whole == 0 = fromRational frac
+      | otherwise  = function mixedFractionSymbol $ map fromInteger parts
+    where
+      whole = MF.wholeNumber a
+      frac  = MF.fractionPart a
+      parts = [whole, numerator frac, denominator frac]
+
+mixedFractionNF :: View Expr MF.MixedFraction
+mixedFractionNF = describe "A normal form for mixed fractions. \
+   \Improper fractions (numerator greater or equal to denominator) are not \
+   \allowed." $
+   "number.mixed-fraction.nf" @> makeView f (build mixedFractionView)
+ where
+   f (Sym s [Nat a, Nat b, Nat c])
+      | isMixedFractionSymbol s = simple a b c
+   f (Negate (Sym s [Nat a, Nat b, Nat c]))
+      | isMixedFractionSymbol s = liftM negate (simple a b c)
+   f expr = do r <- match rationalNF expr
+               guard ((-1 < r && r < 1) || denominator r == 1)
+               return (fromRational r)
+
+   simple a b c = do
+      guard (a > 0 && b > 0 && b < c)
+      r <- simpleRational b c
+      return (fromInteger a + fromRational r)
+
+-------------------------------------------------------------------
+-- Double (imprecise floating-points)
+
+doubleView :: View Expr Double
+doubleView = "num.double" @> makeView (fix matchDouble) fromDouble
+
+doubleNF :: View Expr Double
+doubleNF = "num.double.nf" @> makeView (optionNegate f) fromDouble
+ where
+   f (Number d) = Just d
+   f _          = Nothing
+
+matchDouble :: (Expr -> Maybe Double) -> Expr -> Maybe Double
+matchDouble f expr =
+   case expr of
+      Number d -> Just d
+      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
+      Sqrt a   -> f a >>= safeSqrt
+      Sym s [a, b]
+         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
+         | isRootSymbol s  -> join (liftM2 safeRoot (f a) (f b))
+      Sym s [a, b, c]
+         | isMixedFractionSymbol s -> f (a+b/c)
+      _ -> matchNum f expr
+
+-------------------------------------------------------------------
+-- Helper functions
+
+optionNegate :: (Eq a,Num a) => (Expr -> Maybe a) -> Expr -> Maybe a
+optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b)
+optionNegate f a          = f a
+
+fix :: (a -> a) -> a
+fix f = f (fix f)
+ src/Domain/Math/Polynomial/Balance.hs view
@@ -0,0 +1,290 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Balance (balanceExercise) where
+
+import Control.Monad
+import Data.Function
+import Data.Maybe
+import Data.Ratio
+import Domain.Math.Data.Relation
+import Domain.Math.Data.WithBool
+import Domain.Math.Equation.BalanceRules
+import Domain.Math.Equation.Views
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.BalanceUtils
+import Domain.Math.Polynomial.BuggyBalance
+import Domain.Math.Polynomial.Examples
+import Domain.Math.Polynomial.Generators
+import Domain.Math.Polynomial.Rules (conditionVarsRHS, flipEquation)
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils (fixpoint)
+import Ideas.Common.Utils.Uniplate
+import Test.QuickCheck (sized)
+
+------------------------------------------------------------
+-- Exercise
+
+balanceExercise :: Exercise (WithBool (Equation Expr))
+balanceExercise = makeExercise
+   { exerciseId    = describe "Solve a linear equation using only balance rules." $
+                     newId "algebra.equations.linear.balance"
+   , status        = Provisional
+   , parser        = parseBoolEqExpr
+   , similarity    = withoutContext ((==) `on` cleaner)
+   , equivalence   = withoutContext (viewEquivalent eqView)
+   , suitable      = predicateView (traverseView linearEquationView)
+   , ready         = predicateView (traverseView (equationSolvedWith mixedFractionNF))
+                     <||> predicateView (traverseView (equationSolvedWith rationalNF))
+                     <||> predicateView (traverseView (equationSolvedWith doubleNF))
+   , strategy      = balanceStrategy
+   , extraRules    = map use buggyBalanceRules ++ map use buggyBalanceExprRules
+   , ruleOrdering  = ruleOrderingWithId (balanceOrder ++ buggyPriority)
+   , navigation    = termNavigator
+   , testGenerator = Just $ liftM2 (\a b -> singleton (a :==: b)) (sized linearGen) (sized linearGen)
+   , examples      = map (mapSecond singleton) linearExamples
+   }
+
+balanceOrder :: [Id]
+balanceOrder =
+   [ getId introTrue, getId introFalse
+   , getId removeDivision, getId collect
+   , getId varRightMinus, getId varRightPlus
+   , getId conLeftMinus, getId conLeftPlus
+   , getId varLeftMinus, getId varLeftPlus   -- prefer variable to left
+   , getId conRightMinus, getId conRightPlus -- or constant to right
+   , getId scaleToOne, getId flipEquation
+   , getId divideCommonFactor, getId distribute
+   , getId collect, getId divisionToFraction
+   , getId negateBothSides
+   ]
+
+------------------------------------------------------------
+-- Strategy
+
+balanceStrategy :: LabeledStrategy (Context (WithBool (Equation Expr)))
+balanceStrategy = cleanUpStrategyAfter (applyTop cleaner) $
+   label "Balance equation" $
+       label "Phase 1" (repeatS
+           (  use collect
+          <|> use distribute
+          <|> use removeDivision
+          <|> somewhere (use divisionToFraction)
+          <|> use negateBothSides
+           ))
+   <*> label "Phase 2" (repeatS
+           (  use varLeftMinus <|> use varLeftPlus
+          <|> use conRightMinus <|> use conRightPlus
+          <|> (check p2 <*> (use varRightMinus <|> use varRightPlus))
+          <|> (check p1 <*> (use conLeftMinus <|> use conLeftPlus)
+           ))
+       <*> try (use scaleToOne)
+       <*> try (use calculate))
+       -- flip sides of an equation (at most once)
+   <%> try (atomic (use (check conditionVarsRHS) <*> use flipEquation))
+       -- divide by a common factor (but not as final "scale-to-one" step)
+   <%> many (notS (use scaleToOne) <*> use divideCommonFactor)
+   <%> many (use introTrue <|> use introFalse)
+ where
+   -- move constants to left only if there are no variables on the left
+   p1 = maybe False (either (const False) (hasNoVar . leftHandSide) . fromWithBool) . fromContext
+   p2 ceq = fromMaybe False $ do
+      wb           <- fromContext ceq
+      lhs :==: rhs <- either (const Nothing) Just (fromWithBool wb)
+      (x1, a, c)   <- matchLin lhs
+      (x2, b, _)   <- matchLin rhs
+      return (x1 == x2 && b > a && a /= 0 && c /= 0)
+
+------------------------------------------------------------
+-- Rules
+
+calculate :: Rule (WithBool (Equation Expr))
+calculate = makeRule (linbal, "calculate") $ checkForChange $
+   Just . cleaner
+
+-- factor is always positive due to lcm function
+removeDivision :: Rule (Equation Expr)
+removeDivision = doAfter (fmap distributeTimes) $
+   describe "remove division" $
+   ruleTrans (linbal, "remove-div") $
+   supplyParameters timesRule removeDivisionArg
+ where
+   removeDivisionArg (lhs :==: rhs) = do
+      xs <- match simpleSumView lhs
+      ys <- match simpleSumView rhs
+      -- also consider parts without variables
+      -- (but at least one participant should have a variable)
+      zs <- mapM getFactor (xs++ys)
+      let (b, result) = foldr op (False, 1) zs
+          op (b1, a1) (b2, a2) = (b1 || b2, a1 `lcm` a2)
+      guard (b && result > 1)
+      return (fromInteger result)
+
+   getFactor (Negate a) = getFactor a
+   getFactor expr = do
+      (b, c) <- match (divView >>> second integerView) expr
+      return (hasSomeVar b, c)
+    `mplus` do
+      r <- match rationalView expr
+      return (False, denominator r)
+    `mplus` do
+      (r, c) <- match (timesView >>> first rationalView) expr
+      return (hasSomeVar c, denominator r)
+    `mplus` do
+      (b, r) <- match (timesView >>> second rationalView) expr
+      return (hasSomeVar b, denominator r)
+    `mplus` do
+      (_, ps) <- match simpleProductView expr
+      guard (any (`belongsTo` rationalView) ps)
+      return (False, 1)
+    `mplus` do
+      guard (isVariable expr)
+      return (False, 1)
+
+divisionToFraction :: Rule Expr
+divisionToFraction =
+   describe "turn a division into a multiplication with a fraction" $
+   makeRule (linbal, "div-to-fraction") $ \expr -> do
+      (a, r) <- match (divView >>> second rationalView) expr
+      guard (hasSomeVar a && r /= 0)
+      return (fromRational (1/r)*a)
+
+divideCommonFactor :: Rule (Equation Expr)
+divideCommonFactor = doAfter (fmap distributeDiv) $
+   describe "divide by common factor" $
+   ruleTrans (linbal, "smart-div") $
+   supplyParameters divisionRule getArg
+ where
+   getArg (lhs :==: rhs)
+      | null xs                 = fail "no factor"
+      | 0 `notElem` ns && n > 1 = return (fromInteger n)
+      | otherwise               = fail "no factor"
+    where
+       xs = from simpleSumView lhs ++ from simpleSumView rhs
+       ns = map getFactor xs
+       n  = foldr1 gcd ns
+
+   getFactor expr
+      | hasNoVar expr = fromMaybe 1 $ match integerView expr
+      | otherwise = fromMaybe 1 $ do
+           (a, b) <- match timesView expr
+           case (match integerView a, match integerView b) of
+              (Just n, _) | hasSomeVar b -> return n
+              (_, Just n) | hasSomeVar a -> return n
+              _ -> Nothing
+
+negateBothSides :: Rule (Equation Expr)
+negateBothSides = describe "Remove negation on both sides of an equation" $
+   rewriteRule (linbal, "negate") $ \a b ->
+      (-a :==: -b) :~> (a :==: b)
+
+varLeftMinus, varLeftPlus :: Rule (Equation Expr)
+varLeftMinus = varLeft True  (linbal, "var-left-minus")
+varLeftPlus  = varLeft False (linbal, "var-left-plus")
+
+varLeft :: IsId a => Bool -> a -> Rule (Equation Expr)
+varLeft useMinus rid = doAfter (fmap collectLocal) $
+   ruleTrans rid $
+   supplyParameters (if useMinus then minusRule else plusRule) varLeftArg
+ where
+    varLeftArg :: Equation Expr -> Maybe Expr
+    varLeftArg (lhs :==: rhs) = do
+       guard (hasSomeVar lhs)
+       (x, a, _) <- matchLin rhs
+       guard (if useMinus then a > 0 else a < 0)
+       return (fromRational (abs a) .*. x)
+
+conRightMinus, conRightPlus :: Rule (Equation Expr)
+conRightMinus = conRight True  (linbal, "con-right-minus")
+conRightPlus  = conRight False (linbal, "con-right-plus")
+
+conRight :: IsId a => Bool -> a -> Rule (Equation Expr)
+conRight useMinus rid = doAfter (fmap collectLocal) $
+   ruleTrans rid $
+   supplyParameters (if useMinus then minusRule else plusRule) conRightArg
+ where
+    conRightArg :: Equation Expr -> Maybe Expr
+    conRightArg (lhs :==: _) = do
+       guard (hasSomeVar lhs)
+       (_, _, b) <- matchLin lhs
+       guard (if useMinus then b > 0 else b < 0)
+       return (fromRational (abs b))
+
+varRightMinus, varRightPlus :: Rule (Equation Expr)
+varRightMinus = flipped (linbal, "var-right-minus") varLeftMinus
+varRightPlus  = flipped (linbal, "var-right-plus")  varLeftPlus
+
+conLeftMinus, conLeftPlus :: Rule (Equation Expr)
+conLeftMinus = flipped (linbal, "con-left-minus") conRightMinus
+conLeftPlus  = flipped (linbal, "con-left-plus")  conRightPlus
+
+flipped :: IsId a => a -> Rule (Equation b) -> Rule (Equation b)
+flipped rid = liftView flipView . changeId (const (newId rid))
+ where
+   flipView = makeView (Just . flipSides) flipSides
+
+scaleToOne :: Rule (Equation Expr)
+scaleToOne = doAfter (fmap distributeDiv) $
+   ruleTrans (linbal, "scale-to-one") $
+   supplyParameters divisionRule scaleToOneArg
+ where
+   scaleToOneArg :: Equation Expr -> Maybe Expr
+   scaleToOneArg (lhs :==: rhs) = f lhs rhs `mplus` f rhs lhs
+
+   f :: Expr -> Expr -> Maybe Expr
+   f expr c = do
+      (_, a1, b1) <- matchLin expr
+      guard (a1 /= 0 && a1 /= 1 && b1 == 0 && hasNoVar c)
+      return (fromRational a1)
+
+collect :: Rule (Equation Expr)
+collect = makeRule (linbal, "collect") $
+   -- don't use this rule just for cleaning up
+   checkForChange (Just . fmap collectGlobal) . fmap cleanerExpr
+
+distribute :: Rule (Equation Expr)
+distribute = makeRule (linbal, "distribute") $ checkForChange $
+   Just . fmap (fixpoint f)
+ where
+   f (a :*: (b :+: c))  = f (a*b + a*c)
+   f (a :*: (b :-: c))  = f (a*b - a*c)
+   f ((a :+: b) :*: c)  = f (a*c + b*c)
+   f ((a :-: b) :*: c)  = f (a*c - b*c)
+   f (Negate (a :+: b)) = f (-a-b)
+   f (Negate (a :-: b)) = f (-a+b)
+   f (Negate (Negate a)) = f a
+   f (a :-: (b :+: c)) = f (a-b-c)
+   f (a :-: (b :-: c)) = f (a-b+c)
+   f (a :-: Negate b)  = f (a+b)
+   f a = descend f a
+
+introTrue :: Rule (WithBool (Equation Expr))
+introTrue = makeRule (linbal, "intro-true") $ f . fromWithBool . cleaner
+ where
+   f (Right (lhs :==: rhs)) | lhs == rhs = Just true
+   f _ = Nothing
+
+introFalse :: Rule (WithBool (Equation Expr))
+introFalse = makeRule (linbal, "intro-false") $ f . fromWithBool . cleaner
+ where
+   f (Right (lhs :==: rhs)) = do
+      x <- match rationalView lhs
+      y <- match rationalView rhs
+      guard (x /= y)
+      return false
+   f _ = Nothing
+
+-- for debugging
+{-
+go = printDerivation balanceExercise $ singleton $ let x=Var "x" in
+   (x+2+7/2*x)/(3/2) :==: -3/2*x/4*0 -}
+ src/Domain/Math/Polynomial/BalanceUtils.hs view
@@ -0,0 +1,239 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.BalanceUtils
+   ( eqView, minusView, negView
+   , matchLin, matchPlusCon
+   , cleaner, cleanerExpr
+   , linbal, checkForChange
+   , termRef, factorRef, factor1Ref, factor2Ref
+   , buggyBalanceRule, buggyBalanceRuleArg
+   , buggyBalanceExprRule
+   , buggyBalanceRecognizer
+   , collectLocal, collectGlobal
+   , distributeDiv, distributeTimes
+   , isPlusT, diffPlus
+   , isTimesT, diffTimes
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Data.WithBool
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Safe
+import Domain.Math.Simplification (mergeAlikeSum)
+import Ideas.Common.Library
+import Ideas.Common.Utils (fixpoint)
+import Ideas.Common.Utils.Uniplate
+
+eqView :: View (WithBool (Equation Expr)) (WithBool (String, Rational))
+eqView = makeView (either (Just . fromBool) f . fromWithBool) (fmap g)
+ where
+   f (lhs :==: rhs) = do
+      (s, p) <- match (polyViewWith rationalApproxView) (lhs-rhs)
+      case degree p of
+         0 -> Just $ fromBool $ coefficient 0 p == 0
+         1 -> Just $ singleton (s, - coefficient 0 p / coefficient 1 p)
+         _ -> Nothing
+   g (s, r) = Var s :==: fromRational r
+
+minusView :: View Expr (Expr, Expr)
+minusView = makeView isMinus (uncurry (:-:))
+
+negView :: View Expr Expr
+negView = makeView isNegate Negate
+
+matchLin :: MonadPlus m => Expr -> m (Expr, Rational, Rational)
+matchLin expr = do
+   (s, p) <- matchM (polyNormalForm rationalView) expr
+   guard (degree p == 1)
+   return (Var s, coefficient 1 p, coefficient 0 p)
+
+matchPlusCon :: MonadPlus m => Expr -> m (Expr, Rational)
+matchPlusCon expr =
+   matchM (plusView >>> second rationalView) expr
+ `mplus`
+   matchM (plusView >>> toView swapView >>> second rationalView) expr
+
+------------------------------------------------------------
+-- Strategy
+
+cleaner :: WithBool (Equation Expr) -> WithBool (Equation Expr)
+cleaner = fmap (fmap cleanerExpr)
+
+cleanerExpr :: Expr -> Expr
+cleanerExpr = transform f -- no fixpoint is needed
+ where
+   f (a :/: Nat 1) = f a
+   f (a :/: Negate (Nat 1)) = f $ Negate a
+   f (Negate a :/: Negate b) = f (a/b)
+   f (a :/: Negate b) = f $ Negate (a/b)
+   f (Negate a :/: b) = f $ Negate (a/b)
+   f (Negate (Negate a)) = f a
+   f e = cleanSum (cleanProduct (simplify rationalView e))
+
+   cleanSum =
+      let g x y = canonical rationalView (x :+: y)
+      in simplifyWith (adjacent g) simpleSumView
+
+   cleanProduct =
+      let g x y   = canonical rationalView (x :*: y)
+          reorder = uncurry (++) . partition (`belongsTo` rationalView)
+      in simplifyWith (mapSecond (adjacent g . reorder)) simpleProductView
+
+adjacent :: (a -> a -> Maybe a) -> [a] -> [a]
+adjacent f = rec
+ where
+   rec (x:y:rest) =
+      case f x y of
+         Just xy -> rec (xy:rest)
+         Nothing -> x:rec (y:rest)
+   rec xs = xs
+
+{-
+trivial :: Equation Expr -> WithBool (Equation Expr)
+trivial eq@(lhs :==: rhs) =
+   case (match rationalView lhs, match rationalView rhs) of
+      (Just r1, Just r2)
+         | r1 == r2                -> true
+         | otherwise               -> false
+      _  | any nonsense [lhs, rhs] -> false
+         | lhs == rhs              -> true
+         | otherwise               -> singleton eq
+
+nonsense :: Expr -> Bool
+nonsense = any p . universe
+ where
+   p (_ :/: a) = maybe False (==0) (match rationalView a)
+   p _         = False -}
+
+------------------------------------------------------------
+-- References
+
+termRef, factorRef, factor1Ref, factor2Ref :: Ref Expr
+termRef    = makeRef "term"
+factorRef  = makeRef "factor"
+factor1Ref = makeRef "factor1"
+factor2Ref = makeRef "factor2"
+
+------------------------------------------------------------
+-- Rules
+
+linbal :: Id
+linbal = newId "algebra.equations.linear.balance"
+
+bugbal :: IsId n => n -> Id
+bugbal n = newId (linbal, "buggy", n)
+
+checkForChange :: (MonadPlus m, Eq a) => (a -> m a) -> a -> m a
+checkForChange f a = f a >>= \b -> guard (a /= b) >> return b
+
+buggyBalanceRule :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr)) -> Rule (Equation Expr)
+buggyBalanceRule n = addTransRecognizer eq . buggyRule (bugbal n)
+ where
+   eq = viewEquivalent (traverseView (polyViewWith rationalView))
+
+buggyBalanceRuleArg :: IsId n => n -> (Equation Expr -> EnvMonad (Equation Expr)) -> Rule (Equation Expr)
+buggyBalanceRuleArg n = addTransRecognizer eq . buggyRule (bugbal n)
+ where
+   eq = viewEquivalent (traverseView (polyViewWith rationalView))
+
+buggyBalanceExprRule :: IsId n => n -> (Expr -> Maybe Expr) -> Rule Expr
+buggyBalanceExprRule = buggyRule . bugbal
+
+buggyBalanceRecognizer :: IsId n => n -> (a -> a -> EnvMonad ()) -> Rule a
+buggyBalanceRecognizer n p =
+   addRecognizerEnvMonad p $ buggy $ emptyRule (bugbal n)
+
+------------------------------------------------------------
+-- Helpers
+
+collectLocal :: Expr -> Expr
+collectLocal = simplifyWith (mapSecond f) simpleProductView
+             . simplifyWith mergeAlikeSum simpleSumView
+ where
+   f xs | length ys > 1 = ys++zs
+        | otherwise     = xs
+    where
+      (ys, zs) = partition hasNoVar xs
+
+collectGlobal :: Expr -> Expr
+collectGlobal = fixpoint (transform collectLocal)
+
+distributeDiv :: Expr -> Expr
+distributeDiv expr = fromMaybe expr $ do
+   (a, r) <- match (divView >>> second rationalView) expr
+   return $ simplifyWith (fmap (`divide` r)) simpleSumView a
+ where
+   divide x r = fromMaybe (x/fromRational r) $ do
+      (y, z) <- match (timesView >>> first rationalView) x
+      new    <- y `safeDiv` r
+      return (fromRational new * z)
+    `mplus` do
+      (y, z) <- match (timesView >>> second rationalView) x
+      new    <- z `safeDiv` r
+      return (y * fromRational new)
+
+distributeTimes :: Expr -> Expr
+distributeTimes expr = fromMaybe expr $ do
+   (r, a) <- match (timesView >>> first rationalView) expr
+              `mplus`
+             match (timesView >>> second rationalView >>> toView swapView) expr
+   return $ simplifyWith (fmap (times r)) simpleSumView a
+ where
+   times r x = fromMaybe (fromRational r*x) $ do
+      (a, b) <- match (divView >>> second rationalView) x
+      guard (b /= 0)
+      return (fromRational (r/b) * a)
+
+isPlusT :: Equation Expr -> Equation Expr -> Bool
+isPlusT old new = isJust (diffPlusEq old new)
+
+diffPlusEq :: Equation Expr -> Equation Expr -> Maybe Expr
+diffPlusEq (a1 :==: a2) (b1 :==: b2) = do
+   d1 <- diffPlus a1 b1
+   d2 <- diffPlus a2 b2
+   guard (d1 == d2)
+   return d1
+
+diffPlus :: Expr -> Expr -> Maybe Expr
+diffPlus a b = do
+   let myView = polyViewWith rationalView
+   (x, pa) <- matchM myView a
+   (y, pb) <- matchM myView b
+   guard (x==y)
+   let d = pb - pa
+   return $ build myView (x, d)
+
+isTimesT :: Equation Expr -> Equation Expr -> Bool
+isTimesT old new = isJust (diffTimesEq old new)
+
+diffTimesEq :: Equation Expr -> Equation Expr -> Maybe Expr
+diffTimesEq (a1 :==: a2) (b1 :==: b2) = do
+   d1 <- diffTimes a1 b1
+   d2 <- diffTimes a2 b2
+   guard (d1 == d2)
+   return d1
+
+diffTimes :: MonadPlus m => Expr -> Expr -> m Expr
+diffTimes a b = do
+   let myView = polyViewWith rationalView
+   (x, pa) <- matchM myView a
+   (y, pb) <- matchM myView b
+   guard (x==y)
+   if pa==0 && pb==0 then return 1 else do
+   d <- maybe (fail "diffTimes") return (pb `safeDiv` pa)
+   return $ build myView (x, d)
+ src/Domain/Math/Polynomial/BuggyBalance.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.BuggyBalance
+   ( buggyBalanceRules, buggyBalanceExprRules, buggyPriority
+   ) where
+
+import Control.Monad
+import Data.Ratio
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.BalanceUtils
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+
+buggyBalanceRules :: [Rule (Equation Expr)]
+buggyBalanceRules =
+   [ rule1234, rule201, rule2111, rule2112, rule2113, rule2114
+   , rule2121, rule2122, rule2131, rule2132, rule2133, rule2134
+   , rule2135, rule2136, rule2137, rule2138, rule2141, rule2142
+   , rule221, rule222, rule2232, rule2233
+   , rule311, rule322, rule2231, rule227, rule321, rule323
+   ]
+
+buggyBalanceExprRules :: [Rule Expr]
+buggyBalanceExprRules =
+   [ rule121, rule122, rule1231, rule1232, rule1311, rule1312
+   , rule1314, rule1321, rule1322, rule133, rule134, rule135
+   , rule136, rule137
+   ]
+
+buggyPriority :: [Id]
+buggyPriority =
+   [ getId rule1312, getId rule121, getId rule221, getId rule222
+   , getId rule2232, getId rule2233, getId rule227, getId rule323
+   ]
+
+-------------------------------------------------------------------
+-- 1.2 Fout bij vermenigvuldigen
+
+-- (a*b)/c  ->  a/(b*c)
+rule121 :: Rule Expr
+rule121 = describe "1.2.1: fout bij vermenigvuldigen" $
+   buggyBalanceExprRule "multiply1" f
+ where
+   f (expr :/: c) = do
+      (a, b) <- match timesView expr
+      return $ a/(b*c)
+   f _ = Nothing
+
+-- a*(bx+c)  ->  x/(ab) + ac
+rule122 :: Rule Expr
+rule122 = describe "1.2.2: fout bij vermenigvuldigen" $
+   buggyBalanceExprRule "multiply2" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ x/(a*b) + a*c
+   f _ = Nothing
+
+-- a(b-cx)  -> ab+acx
+rule1231 :: Rule Expr
+rule1231 = describe "1.2.3.1: fout bij vermenigvuldigen; min raakt kwijt" $
+   buggyBalanceExprRule "multiply3" f
+ where
+   f (a :*: expr) = do
+      (b, (c, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b+a*c*x
+   f _ = Nothing
+
+-- -a*(x-b)  -> -ax-ab
+rule1232 :: Rule Expr
+rule1232 = describe "1.2.3.2: fout bij vermenigvuldigen; min te veel" $
+   buggyBalanceExprRule "multiply4" f
+ where
+   f expr = do
+      (a, (x, b)) <- match (timesView >>> negView *** minusView) expr
+      return $ -a*x-a*b
+
+-- -ax=b  ->  x=b/a
+rule1234 :: Rule (Equation Expr)
+rule1234 = describe "1.2.3.4: fout bij vermenigvuldigen; delen door negatief getal" $
+   buggyBalanceRule "multiply5" f
+ where
+   f (expr :==: b) = do
+      (a, x) <- match (timesView >>> first negView) expr
+      return $ x :==: b/a
+
+-------------------------------------------------------------------
+-- 1.3 Fout bij haakjes wegwerken
+
+-- a(x-b)  ->  ax-b    (verruimt naar +)
+rule1311 :: Rule Expr
+rule1311 = describe "1.3.1.1: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par1" f
+ where
+   f expr = do
+      (a, (x, b)) <- match (timesView >>> second plusView) expr
+      return $ a*x+b
+
+-- 1/a*(x-b)  -> 1/a*x-b   (specialized version of par1)
+rule1312 :: Rule Expr
+rule1312 = describe "1.3.1.2: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par2" f
+ where
+   f (e1 :*: e2) = do
+      (n, a) <- match (divView >>> first integerView) e1
+      guard (n==1)
+      (x, b) <- match plusView e2
+      return $ 1/a*x+b
+   f _ = Nothing
+
+-- a(b-cx)  -> ab-cx
+{- zie par1
+rule1313 :: Rule (Equation Expr)
+rule1313 = describe "1.3.1.3: fout bij haakjes wegwerken; haakjes staan e
+r niet voor niets" $
+
+   buggyBalanceExprRule "par3") f
+ where
+   f (a :*: expr) = do
+      (b, (c, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b-c*x
+   f _ = Nothing -}
+
+-- -(a+b)  ->  -a+b
+rule1314 :: Rule Expr
+rule1314 = describe "1.3.1.4: fout bij haakjes wegwerken met unaire min; haakjes staan er niet voor niets" $
+   buggyBalanceExprRule "par11" f
+ where
+   f expr = do
+      (a, b) <- match (negView >>> plusView) expr
+      return $ -a+b
+
+-- a(bx+c)  ->  ax+ac
+rule1321 :: Rule Expr
+rule1321 = describe "1.3.2.1: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par4" f
+ where
+   f (a :*: expr) = do
+      ((_, x), c) <- match (plusView >>> first timesView) expr
+      return $ a*x+a*c
+   f _ = Nothing
+
+-- a(b-cx)  -> ab-ax
+rule1322 :: Rule Expr
+rule1322 = describe "1.3.2.2: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par5" f
+ where
+   f (a :*: expr) = do
+      (b, (_, x)) <- match (minusView >>> second timesView) expr
+      return $ a*b-a*x
+   f _ = Nothing
+
+-- a(bx+c)  -> bx+ac
+rule133 :: Rule Expr
+rule133 = describe "1.3.3: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par6" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ b*x+a*c
+   f _ = Nothing
+
+-- a-(b+c)  -> a-b+c
+rule134 :: Rule Expr
+rule134 = describe "1.3.4: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par7" f
+ where
+   f expr = do
+      (a, (b, c)) <- match (minusView >>> second plusView) expr
+      return $ a-b+c
+
+-- a*(b-c)-d  ->  ab-ac-ad
+rule135 :: Rule Expr
+rule135 = describe "1.3.5: fout bij haakjes wegwerken; kijk goed waar de haakjes staan" $
+   buggyBalanceExprRule "par8" f
+ where
+   f expr = do
+      ((a, (b, c)), d) <- match (minusView >>> first (timesView >>> second minusView)) expr
+      return $ a*b-a*c-a*d
+
+--  a(bx+c)  ->  (a+b)x+ac
+rule136 :: Rule Expr
+rule136 = describe "1.3.6: fout bij haakjes wegwerken; haakjes goed uitwerken" $
+   buggyBalanceExprRule "par9" f
+ where
+   f (a :*: expr) = do
+      ((b, x), c) <- match (plusView >>> first timesView) expr
+      return $ (a+b)*x+a*c
+   f _ = Nothing
+
+-- a+b(x-c)  -> (a+b)(x-c)
+rule137 :: Rule Expr
+rule137 = describe "1.3.7: fout bij haakjes wegwerken; denk aan 'voorrangsregels'" $
+   buggyBalanceExprRule "par10" f
+ where
+   f (a :+: expr) = do
+      (b, (x, c)) <- match (timesView >>> second plusView) expr
+      return $ (a+b)*(x+c)
+   f _ = Nothing
+
+-------------------------------------------------------------------
+-- 2.0 Links en rechts hetzelfde doen, of verwisselen
+
+-- a=b-c  ->  c-b=a
+rule201 :: Rule (Equation Expr)
+rule201 = describe "2.0.1: Links en rechts alleen maar verwisseld?" $
+   buggyBalanceRule "flip1" f
+ where
+   f (a :==: rhs) = do
+      (b, c) <- match minusView rhs
+      return $ c-b :==: a
+
+-------------------------------------------------------------------
+-- 2.1 Links en rechts hetzelfde optellen/aftrekken
+
+{-
+
+   schema addbal regels: (telkens paren met positief/negatief argument)
+   1+2   constante naar rechts
+   3+4   variabele naar links
+   7+8   variabele naar rechts
+   9+10  constante naar links
+   ---
+   5/6    constante links  weggehaald, maar rechts onveranderd gelaten
+   11/12  constante rechts weggehaald, maar links  onveranderd gelaten
+   13/14  variabele links  weggehaald, maar rechts onveranderd gelaten
+   15/16  variabele rechts weggehaald, maar links  onveranderd gelaten
+-}
+
+-- ax+b=[cx]+d  -> ax=[cx]+d+b
+rule2111 :: Rule (Equation Expr)
+rule2111 = describe "2.1.1.1: Links en rechts hetzelfde optellen; links +b en rechts -b" $
+   buggyBalanceRuleArg "addbal1" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b>0)
+      termRef := fromRational b
+      return (ax :==: rhs+fromRational b)
+
+-- ax-b=[cx]+d  -> ax=[cx+d-b
+rule2112 :: Rule (Equation Expr)
+rule2112 = describe "2.1.1.2: Links en rechts hetzelfde optellen; links -b en rechts +b" $
+   buggyBalanceRuleArg "addbal2" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b<0)
+      termRef := fromRational (abs b)
+      return (ax :==: rhs+fromRational b)
+
+-- a=cx+d  -> a+d=cx
+rule2113 :: Rule (Equation Expr)
+rule2113 = describe "2.1.1.3: Je trekt er rechts {?} vanaf, maar links tel je {?} erbij op." $
+   buggyBalanceRuleArg "addbal9" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(cx, d) <- matchPlusCon rhs
+      guard (d>0)
+      termRef := fromRational d
+      return (lhs+fromRational d :==: cx)
+
+-- a=cx-d  -> a-d=cx
+rule2114 :: Rule (Equation Expr)
+rule2114 = describe "2.1.1.4: Je telt er rechts {?} bij op, maar links trek je {?} er vanaf." $
+   buggyBalanceRuleArg "addbal10" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(cx, d) <- matchPlusCon rhs
+      guard (d<0)
+      termRef := fromRational (abs d)
+      return (lhs+fromRational d :==: cx)
+
+-- ax[+b]=cx+d  ->  (a+c)x[+b]=d
+rule2121 :: Rule (Equation Expr)
+rule2121 = describe "2.1.2.1: Links en rechts hetzelfde optellen; links +cx en rechts -cx" $
+   buggyBalanceRuleArg "addbal3" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (c>0 && x==y)
+      termRef := fromRational c*x
+      return (fromRational (a+c)*x+fromRational b :==: fromRational d)
+
+-- ax[+b]=-cx+d  -> (a-c)x[+b]=d
+rule2122 :: Rule (Equation Expr)
+rule2122 = describe "2.1.2.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
+   buggyBalanceRuleArg "addbal4" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (c<0 && x==y)
+      termRef := fromRational (abs c)*x
+      return (fromRational (a+c)*x+fromRational b :==: fromRational d)
+
+-- ax+b=cx+d  ->  b=(a+c)*x+d
+rule2141 :: Rule (Equation Expr)
+rule2141 = describe "2.1.4.1: Links en rechts hetzelfde optellen; links -ax en rechts +ax" $
+   buggyBalanceRuleArg "addbal7" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (a>0 && x==y)
+      termRef := fromRational a*x
+      return (fromRational b :==: fromRational (a+c)*x+fromRational d)
+
+-- -ax+b=cx+d  ->  b=(-a+c)*x+d
+rule2142 :: Rule (Equation Expr)
+rule2142 = describe "2.1.4.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
+   buggyBalanceRuleArg "addbal8" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      ~(y, c, d) <- matchLin rhs
+      guard (a<0 && x==y)
+      termRef := fromRational (abs a)*x
+      return (fromRational b :==: fromRational (a+c)*x+fromRational d)
+
+-- ax+b=e  -> ax=e
+rule2131 :: Rule (Equation Expr)
+rule2131 = describe "2.1.3.1: Links en rechts hetzelfde optellen; links -b rechts niet(s)" $
+   buggyBalanceRuleArg "addbal5" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b > 0)
+      termRef := fromRational b
+      return (ax :==: rhs)
+
+-- ax-b=e  -> ax=e
+rule2132 :: Rule (Equation Expr)
+rule2132 = describe "2.1.3.2: Links en rechts hetzelfde optellen; links +b en rechts niet(s)" $
+   buggyBalanceRuleArg "addbal6" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon lhs
+      guard (b < 0)
+      termRef := fromRational (abs b)
+      return (ax :==: rhs)
+
+-- e=ax+b  -> e=ax
+rule2133 :: Rule (Equation Expr)
+rule2133 = describe "2.1.3.3: Links en rechts hetzelfde optellen; rechts -b links niet(s)" $
+   buggyBalanceRuleArg "addbal11" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon rhs
+      guard (b > 0)
+      termRef := fromRational b
+      return (lhs :==: ax)
+
+-- e=ax-b  -> e=ax
+rule2134 :: Rule (Equation Expr)
+rule2134 = describe "2.1.3.4: Links en rechts hetzelfde optellen; rechts +b en links niet(s)" $
+   buggyBalanceRuleArg "addbal12" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(ax, b) <- matchPlusCon rhs
+      guard (b < 0)
+      termRef := fromRational (abs b)
+      return (lhs :==: ax)
+
+-- ax+b=e  -> b=e
+rule2135 :: Rule (Equation Expr)
+rule2135 = describe "2.1.3.5: Links en rechts hetzelfde optellen; links -ax rechts niet(s)" $
+   buggyBalanceRuleArg "addbal13" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      guard (a > 0)
+      termRef := fromRational a*x
+      return (fromRational b :==: rhs)
+
+-- -ax+b=e  -> b=e
+rule2136 :: Rule (Equation Expr)
+rule2136 = describe "2.1.3.6: Links en rechts hetzelfde optellen; links +ax en rechts niet(s)" $
+   buggyBalanceRuleArg "addbal14" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin lhs
+      guard (a < 0)
+      termRef := fromRational (abs a)*x
+      return (fromRational b :==: rhs)
+
+-- e=ax+b  -> e=b
+rule2137 :: Rule (Equation Expr)
+rule2137 = describe "2.1.3.7: Links en rechts hetzelfde optellen; rechts -ax links niet(s)" $
+   buggyBalanceRuleArg "addbal15" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin rhs
+      guard (a > 0)
+      termRef := fromRational a*x
+      return (lhs :==: fromRational b)
+
+-- e=-ax+b  -> e=b
+rule2138 :: Rule (Equation Expr)
+rule2138 = describe "2.1.3.8: Links en rechts hetzelfde optellen; rechts +ax en links niet(s)" $
+   buggyBalanceRuleArg "addbal16" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, a, b) <- matchLin rhs
+      guard (a < 0)
+      termRef := fromRational (abs a)*x
+      return (lhs :==: fromRational b)
+
+-------------------------------------------------------------------
+-- 2.2 Links en rechts hetzelfde vermenigvuldigen/delen
+
+-- ax=c  -> x=a/c
+rule221 :: Rule (Equation Expr)
+rule221 = describe "2.2.1: Links en rechts hetzelfde vermenigvuldigen; verkeerd om gedeeld" $
+   buggyBalanceRule "mulbal1" f
+ where
+   f (expr :==: c) = do
+      (a, x) <- match timesView expr
+      return $ x :==: a/c
+
+-- 1/*a+b=2/c*x+d  -> x+ba  -> 2x+cd
+rule222 :: Rule (Equation Expr)
+rule222 = describe "2.2.2: Links en rechts hetzelfde vermenigvuldigen; links *a; rechts *b" $
+   buggyBalanceRuleArg "mulbal2" f
+ where
+   f ~(lhs :==: rhs) = do
+      ~(x, ra, b) <- matchLin lhs
+      ~(y, rc, d) <- matchLin rhs
+      let a = denom ra
+          c = denom rc
+          denom = fromInteger . denominator
+          num   = fromInteger . numerator
+      guard (a /= c && (a /= 1 || c /= 1))
+      factor1Ref := a
+      factor2Ref := c
+      return (num ra*x+fromRational b*a :==: num rc*y+c*fromRational d)
+
+-- ax-b=cx+d  -> pax-pb=cx+d
+rule2231 :: Rule (Equation Expr)
+rule2231 = describe "2.2.3.1: Links en rechts hetzelfde vermenigvuldigen; links *p, rechts niet (of andersom)" $
+   buggyBalanceRecognizer "mulbal3" p
+ where -- currently, symmetric
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      ~dl <- diffTimes a1 b1
+      ~dr <- diffTimes a2 b2
+      guard ((dl==1) /=  (dr==1)) -- xor; only one of dl/dr equals 1
+      factorRef := if dr/=1 then dr else dl
+
+-- (x+a)/b=c  -> x+a=c
+rule2232 :: Rule (Equation Expr)
+rule2232 = describe "2.2.3.2: Links en rechts hetzelfde vermenigvuldigen; links /p, rechts niet" $
+   buggyBalanceRuleArg "mulbal4" f
+ where
+   f ~(expr :==: c) = do
+      ~(a, b) <- matchM divView expr
+      factorRef := b
+      return (a :==: c)
+
+-- a+b=c  -> -a-b=c
+rule2233 :: Rule (Equation Expr)
+rule2233 = describe "2.2.3.3: Links en rechts hetzelfde vermenigvuldigen; links en rechts *-1" $
+   buggyBalanceRule "mulbal5" f
+ where
+   f (expr :==: c) = do
+      (a, b) <- match plusView expr
+      return $ -a-b :==: c
+
+-- pa+pb=c -> a+b=c
+rule227 :: Rule (Equation Expr)
+rule227 = describe "2.2.7: Links en rechts hetzelfde vermenigvuldigen; een kant door p delen, andere kant niets" $
+   buggyBalanceRecognizer "mulbal6" p
+ where -- currently, symmetric
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      dl <- diffTimes a1 b1
+      dr <- diffTimes a2 b2
+      rl <- matchM rationalView dl
+      rr <- matchM rationalView dr
+      guard ( rl == 1 && rr /= 1 && numerator rr == 1 ||
+              rl /= 1 && rr == 1 && numerator rl == 1 )
+      factorRef := fromIntegral (denominator (if rr /= 1 then rr else rl))
+
+-------------------------------------------------------------------
+-- 3.1 Doe je wat je wilt doen?
+
+-- ax-b=cx-d  -> (c-a)x-b=-d
+rule311 :: Rule (Equation Expr)
+rule311 = describe "3.1.1: Doe je wat je wilt doen?" $
+   buggyBalanceRule "misc1" f
+ where
+   f (lhs :==: rhs) = do
+      (x, a, b) <- matchLin lhs
+      (y, c, d) <- matchLin rhs
+      guard (x==y)
+      return (fromRational (c-a)*x+fromRational b :==: fromRational d)
+
+-- ax-b=cd+d  -> pax-b=pcx+pd
+rule321 :: Rule (Equation Expr)
+rule321 = describe "3.2.1: Doe je wat je wilt doen? vermenigvuldig de hele linkerkant met p" $
+   buggyBalanceRecognizer "misc2" p
+ where -- currently, not symmetric
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      d <- diffTimes a2 b2
+      let as = from simpleSumView a1
+      guard (d `notElem` [1, -1] && length as > 1)
+      guard $ flip any (take (length as) [0..]) $ \i ->
+         let (xs,y:ys) = splitAt i as
+             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
+         in viewEquivalent (polyViewWith rationalView) aps b1
+      factorRef := d
+
+-- a-b=c  -> -a-b=-c
+rule322 :: Rule (Equation Expr)
+rule322 = describe "3.2.2: Doe je wat je wilt doen? neem het tegengestelde van de hele linkerkant" $
+   buggyBalanceRule "misc3" f
+ where
+   f (expr :==: c) = do
+      (a, b) <- match minusView expr
+      return $ -a-b :==: -c
+
+-- pax+pb=pc  ->  ax+pb=c
+rule323 :: Rule (Equation Expr)
+rule323 = describe "3.2.3: Doe je wat je wilt doen? Deel de hele linkerkant door p" $
+   buggyBalanceRecognizer "misc4" p
+   -- REFACTOR: code copied from rule misc2
+ where -- currently, not symmetric
+   p ~(a1 :==: a2) ~(b1 :==: b2) = do
+      d  <- diffTimes a2 b2
+      dr <- matchM rationalView d
+      let as = from simpleSumView a1
+      guard (dr `notElem` [0, 1, -1] && numerator dr == 1 && length as > 1)
+      guard $ flip any (take (length as) [0..]) $ \i ->
+         let (xs,y:ys) = splitAt i as
+             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
+         in viewEquivalent (polyViewWith rationalView) aps b1
+      factorRef := fromRational (1/dr)
+ src/Domain/Math/Polynomial/BuggyRules.hs view
@@ -0,0 +1,463 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 (also on the abc-formula)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Polynomial.BuggyRules
+   ( buggyRulesExpr, buggyRulesEquation
+   , abcBuggyRules, buggyQuadratic, buggySquareMultiplication
+   ) where
+
+import Control.Monad
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library hiding (makeRule, root, ruleList)
+import Prelude hiding ((^))
+import qualified Ideas.Common.Library as C
+
+makeRule :: IsId n => n -> Transformation a -> Rule a
+makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a
+makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a
+ruleList :: (RuleBuilder f a, IsId n) => n -> [f] -> Rule a
+
+makeRule           = buggyName C.ruleTrans
+makeSimpleRule     = buggyName C.makeRule
+makeSimpleRuleList = buggyName C.makeRule
+ruleList           = buggyName C.rewriteRules
+
+buggyName :: IsId n => (Id -> a) -> n -> a
+buggyName f s = f ("algebra.equations.buggy" # s)
+
+buggyRulesExpr :: [Rule Expr]
+buggyRulesExpr =
+   map (siblingOf distributeTimes)
+   [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign
+   , buggyDistrTimesTooMany, buggyDistrTimesDenom
+   ] ++
+   [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined
+   ]
+
+buggyRulesEquation :: [Rule (Equation Expr)]
+buggyRulesEquation =
+   [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide
+   , buggyNegateAll
+   , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus
+   , buggyMultiplyOneSide, buggyMultiplyForgetOne
+   ]
+
+buggyPlus :: Rule (Equation Expr)
+buggyPlus = describe "Moving a term from the left-hand side to the \
+   \right-hand side (or the other way around), but forgetting to change \
+   \the sign." $
+   buggy $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM plusView lhs
+      [ a :==: rhs + b, b :==: rhs + a ]
+    `mplus` do
+      (a, b) <- matchM plusView rhs
+      [ lhs + a :==: b, lhs + b :==: a ]
+
+buggyNegateOneSide :: Rule (Equation Expr)
+buggyNegateOneSide = describe "Negate terms on one side only." $
+   buggy $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) ->
+      [ -lhs :==: rhs, lhs :==: -rhs  ]
+
+buggyFlipNegateOneSide :: Rule (Equation Expr)
+buggyFlipNegateOneSide = describe "Negate terms on one side only." $
+   buggy $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) ->
+      [ -rhs :==: lhs, rhs :==: -lhs  ]
+
+buggyNegateAll :: Rule (Equation Expr)
+buggyNegateAll = describe "Negating all terms (on both sides of the equation, \
+   \but forgetting one term." $
+   buggy $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do
+      xs <- matchM sumView lhs
+      ys <- matchM sumView rhs
+      let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys)
+          makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys)
+          makeEq as bs = build sumView as :==: build sumView bs
+          f i j = if i==j then id else negate
+          len as = let n = length as in if n < 2 then -1 else n
+      map makeL [0 .. len xs] ++ map makeR [0 .. len ys]
+
+buggyDivNegate :: Rule (Equation Expr)
+buggyDivNegate = describe "Dividing, but wrong sign." $
+   buggy $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM timesView lhs
+      [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ]
+    `mplus` do
+      (a, b) <- matchM timesView rhs
+      [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ]
+
+buggyDivNumDenom :: Rule (Equation Expr)
+buggyDivNumDenom = describe "Dividing both sides, but swapping \
+   \numerator/denominator." $
+   buggy $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do
+      (a, b) <- matchM timesView lhs
+      [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ]
+    `mplus` do
+      (a, b) <- matchM timesView rhs
+      [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ]
+
+buggyDistrTimes :: Rule Expr
+buggyDistrTimes = describe "Incorrect distribution of times over plus: one \
+   \term is not multiplied." $
+   buggy $ makeSimpleRuleList "distr-times-plus" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a*b+c, b+a*c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ a*c+b, a+b*c ]
+
+buggyDistrTimesForget :: Rule Expr
+buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \
+   \one term is forgotten." $
+   buggy $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b]
+ where
+   forget :: Expr -> [Expr]
+   forget expr =
+      case match productView expr of
+         Just (b, xs) | n > 1 ->
+            [ build productView (b, make i) | i <- [0..n-1] ]
+          where
+            make i = [ x | (j, x) <- zip [0..] xs, i/=j ]
+            n = length xs
+         _ -> [0]
+
+buggyDistrTimesSign :: Rule Expr
+buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \
+   \changing sign of addition." $
+   buggy $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [ a.*.b .-. a.*.c ]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [ a.*.c .-. b.*.c ]
+
+buggyDistrTimesTooMany :: Rule Expr
+buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \
+   \a*(b+c)+d, where 'a' is also multiplied to d." $
+   buggy $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do
+      ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr
+      [cleanUpExpr $ a*b+a*c+a*d]
+
+buggyDistrTimesDenom :: Rule Expr
+buggyDistrTimesDenom = describe "Incorrect distribution of times over plus: \
+   \one of the terms is a fraction, and the outer expression is multiplied by \
+   \the fraction's denominator." $
+   buggy $ makeSimpleRuleList "distr-times-denom" $ \expr -> do
+      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
+      [(1/a)*b + a*c, a*b + (1/a)*c]
+    `mplus` do
+      ((a, b), c) <- matchM (timesView >>> first plusView) expr
+      [a*(1/c) + b*c, a*c + b*(1/c)]
+
+buggyMinusMinus :: Rule Expr
+buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \
+   \change sign." $
+   buggy $ makeSimpleRule "minus-minus" $ \expr ->
+      case expr of
+         a :-: (b :-: c)  -> Just (a-b-c)
+         Negate (a :-: b) -> Just (a-b)
+         _ -> Nothing
+
+buggyCancelMinus :: Rule (Equation Expr)
+buggyCancelMinus = describe "Cancel terms on both sides, but terms have \
+   \different signs." $
+   buggy $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do
+      xs <- matchM sumView lhs
+      ys <- matchM sumView rhs
+      [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys
+           , cleanUpExpr x == cleanUpExpr (-y)
+           , let f n as = build sumView $ take n as ++ drop (n+1) as
+           , let eq = f i xs :==: f j ys
+           ]
+
+buggyPriorityTimes :: Rule Expr
+buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \
+   \ignoring some parentheses." $
+   buggy $ makeSimpleRuleList "priority-times" $ \expr -> do
+      (a, (b, c)) <- matchM (plusView >>> second timesView) expr
+      [(a+b)*c]
+    `mplus` do
+      ((a, b), c) <- matchM (plusView >>> first timesView) expr
+      [a*(b+c)]
+
+buggyMultiplyOneSide :: Rule (Equation Expr)
+buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $
+   addRecognizerBool recognizeEq $ buggy $ buggyName emptyRule "multiply-one-side"
+ where
+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
+      let p r  = r `notElem` [-1, 0, 1] &&
+                 any (myEq eq2) (multiplyOneSide (fromRational r) eq1)
+      in maybe False p (recognizeMultiplication a1 b1)
+      || maybe False p (recognizeMultiplication a2 b2)
+
+recognizeMultiplication :: Expr -> Expr -> Maybe Rational
+recognizeMultiplication a b = do
+   (_, pa) <- match (polyViewWith rationalView) a
+   (_, pb) <- match (polyViewWith rationalView) b
+   let d = coefficient (degree pa) pa
+   guard (d /= 0)
+   return (coefficient (degree pb) pb / d)
+
+multiplyOneSide :: Expr -> Equation Expr -> [Equation Expr]
+multiplyOneSide r (lhs :==: rhs) = do
+   xs <- matchM sumView lhs
+   ys <- matchM sumView rhs
+   let f = map (*r)
+   [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)]
+
+buggyMultiplyForgetOne :: Rule (Equation Expr)
+buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \
+   \equation, but forget one." $
+   addRecognizerBool recognizeEq $ buggy $ buggyName emptyRule "multiply-forget-one"
+ where
+   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
+      let p r  = r `notElem` [-1, 0, 1] &&
+                 any (myEq eq2) (multiplyForgetOne (fromRational r) eq1)
+      in maybe False p (recognizeMultiplication a1 b1)
+      || maybe False p (recognizeMultiplication a2 b2)
+
+multiplyForgetOne :: Expr -> Equation Expr -> [Equation Expr]
+multiplyForgetOne r (lhs :==: rhs) = do
+   xs <- matchM sumView lhs
+   ys <- matchM sumView rhs
+   let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys)
+       makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys)
+       f as bs = build sumView as :==: build sumView bs
+       mul b   = if b then (*r) else id
+   do guard (length xs > 1)
+      map makeL [0 .. length xs-1]
+    `mplus` do
+      guard (length ys > 1)
+      map makeR [0 .. length ys-1]
+
+-- Redundant function; should come from exercise
+myEq :: Equation Expr -> Equation Expr -> Bool
+myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr)
+
+---------------------------------------------------------
+-- Quadratic and Higher-Degree Polynomials
+
+buggyQuadratic :: IsTerm a => [Rule (Context a)]
+buggyQuadratic =
+   map use
+      [ buggyCoverUpTimesMul, buggyCoverUpEvenPower
+      , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth
+      , buggyDivisionByVarZero
+      ] ++
+   map use
+      [ buggyDistributionSquare, buggyDistributionSquareForget
+      , buggySquareMultiplication
+      ] ++
+   map use
+      [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget
+      , buggyCoverUpSquareMinus
+      ]
+
+buggyCoverUpEvenPower :: Rule (Equation Expr)
+buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \
+   \the negative root" $ buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) ->
+      make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab c = do
+      (a, b) <- isBinary powerSymbol ab
+      n <- matchM integerView b
+      guard (n > 0 && even n)
+      return (a `equals` root c (fromInteger n))
+
+buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr))
+buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \
+   \but there is some other operation to be done first. Example: x^2+1=9" $
+   buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power-too-early" $
+      oneDisjunct $ helperBuggyCUPower True
+
+buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr))
+buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \
+   \but there is some other operation to be done first. Example: 9*x^2=81, \
+   \ and rewriting this into x=9 or x=-9." $
+   buggy $ siblingOf coverUpPower $
+   makeSimpleRuleList "coverup.even-power-forget" $
+      oneDisjunct $ helperBuggyCUPower False
+
+helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)]
+helperBuggyCUPower mode (lhs :==: rhs) =
+   make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab c = do
+      (sym, xs) <- getFunction ab
+      (i, x)    <- zip [0..] xs
+      (a, b)    <- isBinary powerSymbol x
+      n         <- matchM integerView b
+      guard (n > 0 && even n)
+      let opa | mode      = function sym (take i xs ++ [a] ++ drop (i+1) xs)
+              | otherwise = a
+          rb  = root c (fromInteger n)
+      return $ toOrList [opa `equals` rb, opa `equals` (-rb)]
+
+buggyCoverUpTimesMul :: Rule (Equation Expr)
+buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \
+   \dividing the right-hand side, multiplication is used." $
+   buggy $ siblingOf coverUpTimes $
+   makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do
+      guard (rhs /= 0)
+      (a, b) <- isTimes lhs
+      [a :==: rhs*b, b :==: rhs*a]
+    `mplus` do
+      guard (lhs /= 0)
+      (a, b) <- isTimes rhs
+      [lhs*a :==: b, lhs*b :==: a]
+
+buggyDistributionSquare :: Rule Expr
+buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \
+   \addition: forgetting the 2ab term" $
+   buggy $ siblingOf distributionSquare $
+   ruleList "distr-square"
+      [ \a b -> (a+b)^2 :~> a^2+b^2
+      , \a b -> (a-b)^2 :~> a^2-b^2
+      , \a b -> (a-b)^2 :~> a^2+b^2
+      ]
+
+buggyDistributionSquareForget :: Rule Expr
+buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \
+   \addition: squaring only one term" $
+   buggy $ siblingOf distributionSquare $
+   ruleList "distr-square-forget"
+      [ \a b -> (a+b)^2 :~> a^2+b
+      , \a b -> (a+b)^2 :~> a+b^2
+      , \a b -> (a-b)^2 :~> a^2-b
+      , \a b -> (a-b)^2 :~> a-b^2
+      ]
+
+buggySquareMultiplication :: Rule Expr
+buggySquareMultiplication = describe "Incorrect square of a term that involves \
+   \a multiplication." $ buggy $
+   ruleList "square-multiplication"
+      [ \a b -> (a*b)^2 :~> a*b^2
+      , \a b -> (a*b)^2 :~> a^2*b
+      , \a b -> a*b^2   :~> (a*b)^2
+      , \a b -> a^2*b   :~> (a*b)^2
+      ]
+
+buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr))
+buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \
+   \on the right-hand side, resulting in an error in the signs" $
+   buggy $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq ->
+      case eq of
+         Sym s [a, 2] :==: b | isPowerSymbol s ->
+            Just $ toOrList [a :==: sqrt b, a :==: sqrt (-b)]
+         _ -> Nothing
+
+buggyCoverUpTimesWithPlus :: Rule (Equation Expr)
+buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \
+   \addition on the other side. Only one of the terms is divided." $
+   buggy $ makeSimpleRuleList "coverup.times-with-plus" $
+   \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
+ where
+   make equals ab cd = do
+      (a, b) <- isTimes ab
+      (c, d) <- isPlus cd
+      [ a `equals` (c/b+d), a `equals` (c+d/b),
+        b `equals` (c/a+d), b `equals` (c+d/a) ]
+
+buggyDivisionByVarBoth :: Rule (Equation Expr)
+buggyDivisionByVarBoth = describe "Divide both sides by variable, without \
+   \introducing the x=0 alternative." $
+   buggy $ makeSimpleRule "division-by-var-both" $
+   \(lhs :==: rhs) -> do
+      (s1, p1) <- match polyView lhs
+      (s2, p2) <- match polyView rhs
+      let n = lowestDegree p1 `min` lowestDegree p2
+      guard (n > 0 && s1==s2)
+      let f p = build polyView (s1, raise (-n) p)
+      return (f p1 :==: f p2)
+
+buggyDivisionByVarZero :: Rule (Equation Expr)
+buggyDivisionByVarZero = describe "Divide both sides by variable, without \
+   \introducing the x=0 alternative." $
+   buggy $ makeSimpleRuleList "division-by-var-zero" $
+   \(lhs :==: rhs) -> do
+      guard (rhs == 0)
+      (s, p) <- matchM polyView lhs
+      let n = lowestDegree p
+      guard (n > 0)
+      -- Quick fix to do some trivial steps for a linear equation, so that
+      -- buggy rules are recognized.
+      let eq = build polyView (s, raise (-n) p) :==: 0
+      eq : applyM coverUpPlus eq
+
+---------------------------------------------------------
+-- ABC formula misconceptions
+
+abcBuggyRules :: [Rule (OrList (Equation Expr))]
+abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ]
+
+abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)])
+                 -> Transformation (OrList (Equation Expr))
+abcMisconception f = makeTrans $
+   oneDisjunct $ \(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 = buggy $ makeRule "abc.minus-b" $
+   abcMisconception $ \x a b c -> do
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op bug =
+             let minus = if bug then id else negate
+             in Var x :==: (minus (fromRational b) `op` discr) / (2 * fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+twoA :: Rule (OrList (Equation Expr))
+twoA = buggy $ makeRule "abc.two-a" $
+   abcMisconception $ \x a b c -> do
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op bug =
+             let twice = if bug then id else (2*)
+             in Var x :==: (-fromRational b `op` discr) / twice (fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+minus4AC :: Rule (OrList (Equation Expr))
+minus4AC = buggy $ makeRule "abc.minus-4ac" $
+   abcMisconception $ \x a b c -> do
+      let discr op = sqrt (fromRational ((b*b) `op` (4 * a * c)))
+          f op bug =
+             let sign = if bug then (+) else (-)
+             in Var x :==: (-fromRational b `op` discr sign) / (2 * fromRational a)
+      [ toOrList [ f (+) True,  f (-) True  ],
+        toOrList [ f (+) False, f (-) True  ],
+        toOrList [ f (+) True,  f (-) False ]]
+
+oneSolution :: Rule (OrList (Equation Expr))
+oneSolution = buggy $ makeRule "abc.one-solution" $
+   abcMisconception $ \x a b c ->
+      let discr = sqrt (fromRational (b*b - 4 * a * c))
+          f op = Var x :==: (-fromRational b `op` discr) / (2 * fromRational a)
+      in [ singleton $ f (+), singleton $ f (-) ]
+ src/Domain/Math/Polynomial/Equivalence.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Equivalence
+   ( linEq, quadrEqContext, highEqContext, simLogic, flipGT
+   , eqAfterSubstitution, intervalRelations
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Ord
+import Domain.Logic.Formula hiding (Var)
+import Domain.Math.CleanUp
+import Domain.Math.Data.Interval
+import Domain.Math.Data.Polynomial hiding (eval)
+import Domain.Math.Data.Relation hiding (eval)
+import Domain.Math.Data.SquareRoot
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Context
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils.Uniplate
+import Ideas.Common.View
+import Prelude hiding ((^), sqrt)
+import qualified Data.Traversable as T
+import qualified Domain.Logic.Formula as Logic
+import qualified Domain.Logic.Generator as Logic
+
+relationInterval :: Ord a => RelationType -> a -> Interval a
+relationInterval relType =
+   case relType of
+      EqualTo              -> point
+      NotEqualTo           -> except
+      LessThan             -> lessThan
+      GreaterThan          -> greaterThan
+      LessThanOrEqualTo    -> lessThanOrEqualTo
+      GreaterThanOrEqualTo -> greaterThanOrEqualTo
+      Approximately        -> point -- i.e., equalTo
+
+intervalRelations :: Eq a => a -> Interval a -> Logic (Relation a)
+intervalRelations v = ors . map (ands . map Logic.Var . make) . segments
+ where
+   make pair =
+      case pair of
+         (Unbounded, Unbounded)   -> []
+         (Unbounded, Including b) -> [v .<=. b]
+         (Unbounded, Excluding b) -> [v .<. b]
+         (Including a, Unbounded) -> [v .>=. a]
+         (Excluding a, Unbounded) -> [v .>. a]
+         (Including a, Including b)
+            | a == b    -> [v .==. a]
+            | otherwise -> [v .>=. a, v .<=. b]
+         (Including a, Excluding b) -> [v .>=. a, v .<. b]
+         (Excluding a, Including b) -> [v .>. a, v .<=. b]
+         (Excluding a, Excluding b) -> [v .>. a, v .<. b]
+
+logicInterval :: Ord a => Logic (Interval a) -> Interval a
+logicInterval =
+   foldLogic (id, implies, equivalent, intersect, union, complement, true, false)
+
+-----------------------------------------------------------
+
+linEq :: Relation Expr -> Relation Expr -> Bool
+linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b)
+
+linRel :: Relation Expr -> Maybe (String, Interval Rational)
+linRel = linRelWith rationalView
+
+linRelWith :: (Ord a, Fractional a)
+           => View Expr a -> Relation Expr -> Maybe (String, Interval a)
+linRelWith v rel =
+   case match (linearViewWith v) (lhs - rhs) of
+      Nothing -> do
+         (s, p) <- match (polyViewWith v) (lhs - rhs)
+         guard (degree p == 0)
+         let list = case compare (coefficient 0 p) 0 of
+                       LT -> [LessThan, LessThanOrEqualTo]
+                       EQ -> [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo]
+                       GT -> [GreaterThan, GreaterThanOrEqualTo]
+         return (s, fromBool $ relationType rel `elem` list)
+      Just (s, a, b)
+         | a==0 ->
+              return (s, fromBool (b==0))
+         | otherwise -> do
+              let zero = -b/a
+                  tp = relationType $ (if a<0 then flipSides else id) rel
+              return (s, relationInterval tp zero)
+ where
+   lhs = leftHandSide rel
+   rhs = rightHandSide rel
+
+newtype Q = Q (SquareRoot Rational) deriving (Show, Eq, Num, Fractional)
+
+-- Use normal (numeric) ordering on square roots
+instance Ord Q where
+   Q a `compare` Q b = comparing f a b
+    where
+      f :: SquareRoot Rational -> Double
+      f = eval . fmap fromRational
+
+qView :: View (SquareRoot Rational) Q
+qView = makeView (return . Q) (\(Q a) -> a)
+
+quadrEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
+quadrEqContext = eqContextWith (polyEq quadrRel)
+
+highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
+highEqContext = eqContextWith (polyEq highRel)
+
+eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool)
+              -> Context (Logic (Relation Expr))
+              -> Context (Logic (Relation Expr))
+              -> Bool
+eqContextWith eq a b = isJust $ do
+   termA <- fromContext a
+   termB <- fromContext b
+   guard $
+      case (ineqOnClipboard a, ineqOnClipboard b) of
+         (Just x,  Just y)  -> eq x y && eq termA termB
+         (Just x,  Nothing) -> eq (fmap toEq x) termA && eq x termB
+         (Nothing, Just y)  -> eq (fmap toEq y) termB && eq termA y
+         (Nothing, Nothing) -> eq termA termB
+ where
+   toEq :: Relation Expr -> Relation Expr
+   toEq r = leftHandSide r .==. rightHandSide r
+
+ineqOnClipboard :: Context a -> Maybe (Logic (Relation Expr))
+ineqOnClipboard = lookupClipboardG "ineq"
+
+polyEq :: (Relation Expr -> Maybe (String, Interval Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool
+polyEq f p q = fromMaybe False $ do
+   xs <- T.mapM f p
+   ys <- T.mapM f q
+   let vs = map fst (varsLogic xs ++ varsLogic ys)
+   guard (null vs || all (==head vs) vs)
+   let ix = logicInterval (fmap snd xs)
+       iy = logicInterval (fmap snd ys)
+   return (ix == iy)
+
+cuPlus :: Relation Expr -> Maybe (Relation Expr)
+cuPlus rel = do
+   (a, b) <- match plusView (leftHandSide rel)
+   guard (hasNoVar b && hasNoVar (rightHandSide rel))
+   return $ constructor rel a (rightHandSide rel - b)
+ `mplus` do
+   (a, b) <- match plusView (leftHandSide rel)
+   guard (hasNoVar a && hasNoVar (rightHandSide rel))
+   return $ constructor rel b (rightHandSide rel - a)
+ `mplus` do
+   a <- isNegate (leftHandSide rel)
+   return $ constructor (flipSides rel) a (-rightHandSide rel)
+
+cuTimes :: Relation Expr -> Maybe (Relation Expr)
+cuTimes rel = do
+   (a, b) <- match timesView (leftHandSide rel)
+   r1 <- match rationalView a
+   r2 <- match rationalView (rightHandSide rel)
+   guard (r1 /= 0)
+   let make = constructor (if r1>0 then rel else flipSides rel)
+       new   = make b (build rationalView (r2/r1))
+   return new
+
+cuPower :: Relation Expr -> Maybe (Logic (Relation Expr))
+cuPower rel = do
+   (a, b) <- isBinary powerSymbol (leftHandSide rel)
+   n <- match integerView b
+   guard (n > 0 && hasNoVar (rightHandSide rel))
+   let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n))
+       new = constructor rel a expr
+       opp = constructor (flipSides rel) a (-expr)
+       rt  = relationType rel
+   return $ if odd n
+            then Logic.Var new
+            else if rt `elem` [LessThan, LessThanOrEqualTo]
+                 then Logic.Var new :&&: Logic.Var opp
+                 else Logic.Var new :||: Logic.Var opp
+
+highRel2 :: Logic (Relation Expr) -> Maybe (String, Interval Q)
+highRel2 p = do
+   xs <- T.mapM highRel p
+   let vs = map fst (varsLogic xs)
+   guard (null vs || all (==head vs) vs)
+   return (head vs, logicInterval (fmap snd xs))
+
+highRel :: Relation Expr -> Maybe (String, Interval Q)
+highRel rel = msum
+   [ cuTimes rel >>= highRel
+   , cuPower rel >>= highRel2
+   , cuPlus rel >>= highRel
+   , quadrRel rel
+   ]
+
+quadrRel :: Relation Expr -> Maybe (String, Interval Q)
+quadrRel rel =
+   case match (quadraticViewWith rationalView) (lhs - rhs) of
+      Nothing ->
+         linRelWith (squareRootViewWith rationalView >>> qView) rel
+      Just (s, xa, xb, xc) -> do
+         let (tp, a, b, c)
+                | xa<0 =
+                     (relationType (flipSides rel), -xa, -xb, -xc)
+                | otherwise =
+                     (relationType rel, xa, xb, xc)
+             discr = b*b - 4*a*c
+             pa = Q ((-fromRational b-sqrtRational discr) / (2 * fromRational a))
+             pb = Q ((-fromRational b+sqrtRational discr) / (2 * fromRational a))
+         guard (a/=0)
+         (\is -> Just (s, is)) $
+          case compare discr 0 of
+            LT -> fromBool $ tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo]
+            EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] ->
+                    point pa
+               | tp == NotEqualTo           -> except pa
+               | tp == LessThan             -> false
+               | tp == GreaterThan          -> except pa
+               | tp == GreaterThanOrEqualTo -> true
+            GT | tp `elem` [EqualTo, Approximately] ->
+                    point pa <||> point pb
+               | tp == NotEqualTo ->
+                    except pa `intersect` except pb
+               | tp == LessThan ->
+                    open pa pb
+               | tp == LessThanOrEqualTo ->
+                    closed pa pb
+               | tp == GreaterThan ->
+                    lessThan pa <||> greaterThan pb
+               | tp == GreaterThanOrEqualTo ->
+                    lessThanOrEqualTo pa <||> greaterThanOrEqualTo pb
+            _ -> error "unknown case in quadrRel"
+ where
+   lhs = leftHandSide rel
+   rhs = rightHandSide rel
+
+flipGT :: Relation a -> Relation a
+flipGT r
+   | relationType r == GreaterThan =
+        rightHandSide r .<. leftHandSide r
+   | relationType r == GreaterThanOrEqualTo =
+        rightHandSide r .<=. leftHandSide r
+   | otherwise = r
+
+-- for similarity
+simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool
+simLogic f p0 q0 = Logic.equalLogicACI (fmap f p0) (fmap f q0)
+
+eqAfterSubstitution :: (Functor f, Functor g)
+   => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool
+eqAfterSubstitution eq ca cb = fromMaybe False $ do
+   a <- fromContext ca
+   b <- fromContext cb
+   let f = maybe id (fmap . fmap . substitute) . substOnClipboard
+   return (f ca a `eq` f cb b)
+
+substitute :: (String, Expr) -> Expr -> Expr
+substitute (s, a) (Var b) | s==b = a
+substitute pair expr = descend (substitute pair) expr
+
+substOnClipboard :: Context a -> Maybe (String, Expr)
+substOnClipboard c = do
+   eq <- lookupClipboardG "subst" c
+   case eq of
+      Var s :==: a -> return (s, a)
+      _            -> fail "not a substitution"
+ src/Domain/Math/Polynomial/Examples.hs view
@@ -0,0 +1,394 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Polynomial.Examples
+   ( linearExamples, quadraticExamples, higherDegreeExamples
+   , factorizeExamples, expandExamples
+   , ineqLin1, ineqQuad1, ineqQuad2, extraIneqQuad, ineqHigh
+   ) where
+
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Exercise
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+x :: Expr
+x = variable "x"
+
+linearExamples :: Examples (Equation Expr)
+linearExamples =
+   level Easy -- applet level 1
+      [ 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
+      ] ++
+   level Easy -- applet level 2
+      [ 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
+      ] ++
+   level Medium -- applet level 3
+      [ 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)
+      ] ++
+   level Medium -- applet level 4
+      [ (1/2)*x - 4            :==: 2*x + mixed 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 + mixed 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)
+      , (-mixed 1 2 5)*x + mixed 3 1 2 :==: (3/5)*x + (9/10)
+      ] ++
+   level Medium -- applet level 4
+      [ (1/4)*(x-3)         :==: (1/2)*x - 4
+      , (x+3)/2             :==: 5*((1/2)*x + mixed 1 1 2)
+      , (1/2)*(7-(2/3)*x)   :==: 2 + (1/9)*x
+      , (3/4)*x - (x-1)     :==: 3 + mixed 2 1 2*(x-1)
+      , -(5/4)*(x-7)        :==: (3/4)*(x+2) - mixed 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)
+      ]
+
+quadraticExamples :: Examples (Equation Expr)
+quadraticExamples =
+   level Easy -- applet level 1
+      [ 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
+      ] ++
+   level Medium -- applet level 2
+      [ (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
+      ] ++
+   level Medium -- applet level 3
+      [ 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
+      ] ++
+   level Medium -- applet level 4
+      [ 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
+      ] ++
+   level Difficult -- applet level 5
+      [ (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)
+      ] ++
+   level Difficult -- applet level 6
+      [ 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
+      ]
+
+factorizeExamples :: Examples Expr
+factorizeExamples =
+   level Easy
+      [ -- (buiten haakjes brengen)
+       4*x^2 -4*x
+      , 36*x^2+30*x
+      , -6*x^2-18*x
+      , 14*x^2-10*x
+        --(product-som methode)
+      , x^2+11*x+24
+      , x^2-8*x+15
+      , x^2-x-2
+      , x^2-11*x+28
+      ]
+
+expandExamples :: Examples Expr
+expandExamples = level Easy
+   [ 5*(x+1), -3*(x-3), (x-1)*7
+   , 4*(3-2*x), (x+1)*(x-3), (x+1)*(1-x)
+   , x*(x-1), 3*(x-2)*2*x
+   , (x-1)^2, (x+1)^2, (x-1)^2*(x+1)
+   , (x+1)^3, (x-1)^3*x, (x-1)*(x+3)*(x-5)
+   , x/2, (x+1)/2, (x+1)/2 + (x+2)/3, ((x+1)/2) * ((x+2)/3)
+   ]
+
+--------------------------------------------------------------------
+-- Algemene applet
+
+higherDegreeExamples :: Examples (Equation Expr)
+higherDegreeExamples =
+   -- Havo B hoofdstuk 3, Hogeregraadsvgl.
+   level Easy
+      [ -- level 1
+        (1/3)*x^3 :==: 9
+      , x^5 - 12 :==: 20
+      , 1 - 8*x^3 :==: -124
+      , 16 - 32*x^5 :==: - 227
+        -- level 2
+      , 3*x^4 :==: 48
+      , (1/9)*x^6 + 12 :==: 93
+      , 39 - 8*x^2 :==: 21
+      , (1/2)*x^4 - 13 :==: 27.5
+        -- level 3
+      , 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
+        -- level 4
+      , 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
+      ] ++
+   level Easy
+      [ -- level 1
+        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
+        -- level 2
+      , 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
+        -- level 3
+      , 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
+        -- level 4
+      , 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
+        -- level 5
+      , (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
+      ] ++
+   level Medium
+      -- (Ontbinden applet)
+      [ -- level 1
+        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
+        -- level 2
+      , 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)
+        -- level 1
+      , 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
+        -- level 2
+      , 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
+      ] ++
+   level Difficult
+      [ 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
+      ]
+
+--------------------------------------------------------------------
+-- Havo applets
+
+-- Havo B Voorkennis: lineaire ongelijkheden
+ineqLin1 :: [[Inequality Expr]]
+ineqLin1 =
+   let a = Var "a" 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)
+ineqQuad1 :: [[Inequality Expr]]
+ineqQuad1 =
+   [ [ 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 :: [Inequality Expr]
+ineqHigh =
+   [ 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
+   ]
+
+--------------------------------------------------------------------
+-- VWO A/C applets
+
+-- hoofdstuk 2
+ineqQuad2 :: [Inequality Expr]
+ineqQuad2 =
+   [ 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
+   ]
+
+--------------------------------------------------------------------
+-- Extra test cases
+
+extraIneqQuad :: [Inequality Expr]
+extraIneqQuad =
+   [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x
+   , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0
+   ]
+ src/Domain/Math/Polynomial/Exercises.hs view
@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( linearExercise, linearMixedExercise
+   , quadraticExercise, quadraticNoABCExercise
+   , quadraticWithApproximationExercise
+   , higherDegreeExercise
+   , findFactorsExercise, expandExercise
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.Maybe
+import Domain.Math.Approximation
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Equation.Views
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.BuggyRules
+import Domain.Math.Polynomial.Equivalence
+import Domain.Math.Polynomial.Examples
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Strategies
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+import qualified Data.Foldable as F
+import qualified Data.Traversable as T
+
+------------------------------------------------------------
+-- Exercises
+
+linearExercise :: Exercise (Equation Expr)
+linearExercise = makeExercise
+   { exerciseId   = describe "solve a linear equation" $
+                       newId "algebra.equations.linear"
+   , status       = Stable
+   , parser       = parseEqExpr
+   , similarity   = withoutContext (viewEquivalent (traverseView cleanUpACView))
+   , equivalence  = withoutContext (viewEquivalent linearEquationView)
+   , suitable     = predicateView linearEquationView
+   , ready        = predicateView (equationSolvedWith mixedFractionNF)
+                    <||> predicateView (equationSolvedWith rationalNF)
+                    <||> predicateView (equationSolvedWith doubleNF)
+   , extraRules   = map use buggyRulesEquation ++
+                    map use buggyRulesExpr
+   , ruleOrdering = ruleOrderingWithId
+                       [ getId coverUpTimes, getId flipEquation
+                       , getId removeDivision
+                       ]
+   , strategy     = linearStrategy
+   , navigation   = termNavigator
+   , examples     = linearExamples
+   }
+
+linearMixedExercise :: Exercise (Equation Expr)
+linearMixedExercise = linearExercise
+   { exerciseId   = describe "solve a linear equation with mixed fractions" $
+                       newId "algebra.equations.linear.mixed"
+   , status       = Provisional
+   , ready        = predicateView (equationSolvedWith mixedFractionNF)
+   , strategy     = linearMixedStrategy
+   }
+
+quadraticExercise :: Exercise (OrList (Relation Expr))
+quadraticExercise = makeExercise
+   { exerciseId   = describe "solve a quadratic equation" $
+                       newId "algebra.equations.quadratic"
+   , status       = Stable
+   , parser       = parseOrsEqExpr
+                       >>> right (build (traverseView equationView))
+   , similarity   = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
+   , equivalence  = withoutContext (equivalentRelation (viewEquivalent quadraticEquationsView))
+   , suitable     = predicateView (traverseView equationView >>> quadraticEquationsView)
+   , ready        = predicateView relationsSolvedForm
+   , extraRules   = map use abcBuggyRules ++ buggyQuadratic ++
+                    map use buggyRulesEquation ++ map use buggyRulesExpr
+   , ruleOrdering = ruleOrderingWithId $
+                       quadraticRuleOrder ++ [getId buggySquareMultiplication]
+   , strategy     = quadraticStrategy
+   , navigation   = termNavigator
+   , examples     = mapExamples (singleton . build equationView) quadraticExamples
+   }
+
+higherDegreeExercise :: Exercise (OrList (Relation Expr))
+higherDegreeExercise = makeExercise
+   { exerciseId    = describe "solve an equation (higher degree)" $
+                        newId "algebra.equations.polynomial"
+   , status        = Stable
+   , parser        = parser quadraticExercise
+   , similarity    = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
+   , equivalence   = eqAfterSubstitution $
+                        equivalentRelation (viewEquivalent higherDegreeEquationsView)
+   , suitable      = predicateView (traverseView equationView >>> higherDegreeEquationsView)
+   , ready         = predicateView relationsSolvedForm
+   , extraRules    = map use abcBuggyRules ++ buggyQuadratic ++
+                     map use buggyRulesEquation ++ map use buggyRulesExpr
+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
+   , strategy      = higherDegreeStrategy
+   , navigation    = termNavigator
+   , examples      = mapExamples (singleton . build equationView) higherDegreeExamples
+   }
+
+quadraticNoABCExercise :: Exercise (OrList (Relation Expr))
+quadraticNoABCExercise = quadraticExercise
+   { exerciseId   = describe "solve a quadratic equation without abc-formula" $
+                       newId "algebra.equations.quadratic.no-abc"
+   , status       = Provisional
+   , strategy     = configure cfg quadraticStrategy
+   }
+ where
+   cfg = makeStrategyConfiguration
+      [ (byName prepareSplitSquare, Reinsert)
+      , (byName bringAToOne, Reinsert)
+      , (byName (newId "abc form"), Remove)
+      , (byName simplerPolynomial, Remove)
+      ]
+
+quadraticWithApproximationExercise :: Exercise (OrList (Relation Expr))
+quadraticWithApproximationExercise = quadraticExercise
+   { exerciseId   = describe "solve a quadratic equation with approximation" $
+                       newId "algebra.equations.quadratic.approximate"
+   , status        = Provisional
+   , parser       = parseOrsRelExpr
+   , strategy     = configure cfg quadraticStrategy
+   , equivalence  = withoutContext equivalentApprox
+   }
+ where
+   cfg = makeStrategyConfiguration
+      [ (byName (newId "approximate result"), Reinsert)
+      , (byName (newId "square root simplification"), Remove)
+      ]
+
+findFactorsExercise :: Exercise Expr
+findFactorsExercise = makeExercise
+   { exerciseId   = describe "factorize the expression" $
+                       newId "algebra.manipulation.polynomial.factor"
+   , status       = Provisional
+   , parser       = parseExpr
+   , similarity   = withoutContext ((==) `on` cleanUpExpr)
+   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))
+   , ready        = predicateView linearFactorsView
+   , ruleOrdering = ruleOrderingWithId quadraticRuleOrder
+   , strategy     = findFactorsStrategy
+   , navigation   = termNavigator
+   , extraRules   = map liftToContext buggyRulesExpr
+   , examples     = factorizeExamples
+   }
+
+expandExercise :: Exercise Expr
+expandExercise = makeExercise
+   { exerciseId   = describe "expand an expression to polynomial normal form" $
+                       newId "algebra.manipulation.polynomial.expand"
+   , status       = Provisional
+   , parser       = parseExpr
+   , similarity   = withoutContext ((==) `on` cleanUpExpr)
+   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))
+   , ready        = predicateView (polyNormalForm rationalView)
+   , ruleOrdering = ruleOrderingWithId (getId fractionProduct:quadraticRuleOrder)
+   , strategy     = expandStrategy
+   , navigation   = termNavigator
+   , extraRules   = map liftToContext buggyRulesExpr
+   , examples     = expandExamples
+   }
+
+linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)])
+linearFactorsView = toView productView >>> second (listView myLinearView)
+ where
+   myLinearView :: View Expr (String, Expr, Expr)
+   myLinearView = makeView f (build linearView)
+
+   f expr = do
+      triple@(_, e1, e2) <- match linearView expr
+      a <- match integerView e1
+      b <- match integerView e2
+      guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined
+      return triple
+    `mplus` do
+      guard (expr `belongsTo` rationalView)
+      return ("x", 0, expr)
+
+--------------------------------------------
+-- Equality
+
+equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool
+equivalentApprox a b
+   | hasApprox a || hasApprox b =
+        let norm = liftM ( simplify orSetView
+                         . fmap (fmap (acExpr . cleanUpExpr) . toApprox)
+                         . simplify quadraticEquationsView
+                         ) . T.mapM toEq
+        in fromMaybe False $ liftM2 (==) (norm a) (norm b)
+   | otherwise =
+        equivalentRelation (viewEquivalent quadraticEquationsView) a b
+ where
+   hasApprox = F.any isApproximately
+   isApproximately = (==Approximately) . relationType
+   toEq rel | relationType rel `elem` [EqualTo, Approximately] =
+      Just (leftHandSide rel :==: rightHandSide rel)
+            | otherwise = Nothing
+
+toApprox :: Equation Expr -> Relation Expr
+toApprox (a :==: b) = f a .~=. f b
+ where
+   f x = maybe x (fromDouble . precision 4) (match doubleView x)
+
+equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool
+equivalentRelation f ra rb = fromMaybe False $ do
+   a <- T.mapM (match equationView) ra
+   b <- T.mapM (match equationView) rb
+   return (f a b)
+ src/Domain/Math/Polynomial/Generators.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Numeric.Generators
+import Prelude hiding ((^))
+import Test.QuickCheck
+
+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
+      elements [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 <- elements [ 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/IneqExercises.hs view
@@ -0,0 +1,310 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.IneqExercises
+   ( ineqLinearExercise, ineqQuadraticExercise, ineqHigherDegreeExercise
+   ) where
+
+import Control.Monad
+import Data.Foldable (toList)
+import Data.Function
+import Data.List
+import Data.Maybe (fromMaybe)
+import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic)
+import Domain.Math.CleanUp
+import Domain.Math.Data.Interval
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)
+import Domain.Math.Equation.Views
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Equivalence
+import Domain.Math.Polynomial.Examples
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Strategies
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library hiding (isEmpty)
+import Ideas.Common.Utils.Uniplate (descend)
+import qualified Domain.Logic.Formula as Logic
+import qualified Domain.Logic.Views as Logic
+
+ineqLinearExercise :: Exercise (Relation Expr)
+ineqLinearExercise = makeExercise
+   { exerciseId   = describe "solve a linear inequation" $
+                       newId "algebra.inequalities.linear"
+   , status       = Provisional
+   , parser       = parseRelExpr
+   , ready        = predicateView relationSolvedForm
+   , equivalence  = withoutContext linEq
+   , similarity   = withoutContext (viewEquivalent (traverseView cleanUpView))
+   , strategy     = ineqLinear
+   , navigation   = termNavigator
+   , examples     = let x = Var "x"
+                        extra = (x-12) / (-2) :>: (x+3)/3
+                    in level Medium $
+                       map (build inequalityView) (concat ineqLin1 ++ [extra])
+   }
+
+ineqQuadraticExercise :: Exercise (Logic (Relation Expr))
+ineqQuadraticExercise = makeExercise
+   { exerciseId    = describe "solve a quadratic inequation" $
+                        newId "algebra.inequalities.quadratic"
+   , status        = Provisional
+   , parser        = parseLogicRelExpr
+   , prettyPrinter = showLogicRelation
+   , ready         = predicateView relationsSolvedForm
+   , equivalence   = quadrEqContext
+   , similarity    = simIneqContext
+   , strategy      = ineqQuadratic
+   , navigation    = termNavigator
+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
+   , examples      = level Medium $
+                     map (Logic.Var . build inequalityView)
+                         (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad])
+   }
+
+ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr))
+ineqHigherDegreeExercise = makeExercise
+   { exerciseId    = describe "solve an inequation of higher degree" $
+                        newId "algebra.inequalities.polynomial"
+   , status        = Provisional
+   , parser        = parseLogicRelExpr
+   , prettyPrinter = showLogicRelation
+   , ready         = predicateView relationsSolvedForm
+   , equivalence   = highEqContext
+   , similarity    = simIneqContext
+   , strategy      = ineqHigherDegree
+   , navigation    = termNavigator
+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
+   , examples      = level Medium $ map (Logic.Var . build inequalityView) ineqHigh
+   }
+
+ineq :: String
+ineq = "algebra.inequalities"
+
+simIneqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
+simIneqContext a b =
+   sameClipboard a b &&
+   withoutContext (simLogic (fmap cleanUpExpr . flipGT)) a b
+ where
+   sameClipboard = eqExpr `on` lookupClipboardG "ineq"
+   eqExpr = (==) :: Maybe Expr -> Maybe Expr -> Bool
+
+--inEquation <- lookupClipboard "ineq" >>= fromExpr
+
+showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String
+showLogicRelation logic =
+   case logic of
+      Logic.T     -> "true"
+      Logic.F     -> "false"
+      Logic.Var a -> show a
+      p :||: q    -> showLogicRelation p ++ " or " ++ showLogicRelation q
+      p :&&: q    -> case match betweenView logic of
+                        Just (x, o1, y, o2, z) ->
+                           let f b = if b then "<=" else "<"
+                           in unwords [show x, f o1, show y, f o2, show z]
+                        _ -> showLogicRelation p ++ " and " ++ showLogicRelation q
+      _           -> show logic
+
+betweenView :: Eq a => View (Logic (Relation a)) (a, Bool, a, Bool, a)
+betweenView = makeView f h
+ where
+   f (Logic.Var r1 :&&: Logic.Var r2) = do
+      ineq1 <- match inequalityView r1
+      ineq2 <- match inequalityView r2
+      let g (a :>=: b) = b :<=: a
+          g (a :>:  b) = b :<:  a
+          g e          = e
+      make (g ineq1) (g ineq2)
+   f _ = Nothing
+
+   make a b
+      | la == rb && ra /= lb = make b a
+      | ra == lb =
+           Just (la, op a, ra, op b, rb)
+      | otherwise = Nothing
+    where
+      (la, ra) = (leftHandSide a, rightHandSide a)
+      (lb, rb) = (leftHandSide b, rightHandSide b)
+      op (_ :<=: _) = True
+      op _          = False
+
+   h (x, o1, y, o2, z) =
+      let g b = if b then (.<=.) else (.<.)
+      in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z)
+
+ineqLinear :: LabeledStrategy (Context (Relation Expr))
+ineqLinear = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) ineqLinearG
+
+ineqLinearG :: IsTerm a => LabeledStrategy (Context a)
+ineqLinearG = label "Linear inequation" $
+   label "Phase 1" (repeatS
+       (  use removeDivision
+      <|> multi (showId distributeTimes)
+             (oncetd (use distributeTimes))
+      <|> multi (showId merge) (layer [] (use merge))
+       ))
+   <*>
+   label "Phase 2"
+       (  try (use varToLeft)
+      <*> try coverUpPlus
+      <*> try (use flipSign)
+      <*> try (use coverUpTimesPositive)
+       )
+
+-- helper strategy (todo: fix needed, because the original rules do not
+-- work on relations)
+coverUpPlus :: IsTerm a => Strategy (Context a)
+coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps)
+ where
+   coverUps :: [ConfigCoverUp -> Rule (Relation Expr)]
+   coverUps =
+      [ coverUpBinaryRule "plus" (commOp . isPlus) (-)
+      , coverUpBinaryRule "minus-left" isMinus (+)
+      , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))
+      ]
+
+coverUpTimesPositive :: Rule (Relation Expr)
+coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp
+ where
+   m expr = do
+      (a, b) <- matchM timesView expr
+      r <- matchM rationalView a
+      guard (r>0)
+      return (a, b)
+
+flipSign :: Rule (Relation Expr)
+flipSign = describe "Flip sign of inequality" $
+   ruleMaybe (ineq, "flip-sign") $ \r -> do
+   let lhs = leftHandSide r
+       rhs = rightHandSide r
+   guard (isNegative lhs)
+   return $ constructor (flipSides r) (neg lhs) (neg rhs)
+ where
+   isNegative (Negate _) = True
+   isNegative expr =
+      maybe False fst (match productView expr)
+
+ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr)))
+ineqQuadratic = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $
+   label "Quadratic inequality" $
+      use trivialRelation
+       |> try (useC turnIntoEquation)
+      <*> quadraticStrategyG
+      <*> useC solutionInequation
+
+ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr)))
+ineqHigherDegree = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $
+   label "Inequality of a higher degree" $
+      use trivialRelation
+       |> try (useC turnIntoEquation)
+      <*> higherDegreeStrategyG
+      <*> useC solutionInequation
+
+-- First, cleanup expression. Then, cleanup equations only (there is an
+-- explicit rule for the other relations). Finally, simplify the logical
+-- proposition (including impotency or).
+cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr)
+cleanUpLogicRelation =
+   let f a | relationType a == EqualTo = build orListView (cleanUpRelation a)
+           | otherwise                 = Logic.Var a
+   in simplifyWith noDuplicates orListView . Logic.simplify
+    . catLogic . fmap (f . fmap cleanUpExpr)
+
+trivialRelation :: Rule (OrList (Relation Expr))
+trivialRelation =
+   ruleMaybe (ineq, "trivial") $ oneDisjunct $ \a -> do
+      let new = cleanUpRelation a
+      guard (isTrue new || isFalse new)
+      return new
+
+turnIntoEquation :: Rule (Context (Relation Expr))
+turnIntoEquation = describe "Turn into equation" $
+   ruleMaybe (ineq, "to-equation") $ \cr -> do
+   r <- currentInContext cr
+   guard (relationType r `elem` ineqTypes)
+   return $ addToClipboard "ineq" (toExpr r)
+          $ replaceInContext (leftHandSide r .==. rightHandSide r) cr
+ where
+   ineqTypes =
+      [LessThan, GreaterThan, LessThanOrEqualTo, GreaterThanOrEqualTo]
+
+-- Todo: cleanup this function
+solutionInequation :: Rule (Context (Logic (Relation Expr)))
+solutionInequation = describe "Determine solution for inequality" $
+   makeRule (ineq, "give-solution") $ \clr -> do
+   r <- currentInContext clr
+   inEquation <- lookupClipboardG "ineq" clr
+   let rt = relationType inEquation
+   orv  <- matchM orListView r
+   new <- case toList orv of
+      _ | isTrue orv ->
+         return $ fromBool $
+            rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]
+      _ | isFalse orv -> do -- no solutions found for equations
+         let vs = vars (toExpr inEquation)
+         guard (not (null vs))
+         return $ fromBool $ evalIneq inEquation (head vs) 0
+      xs -> do
+         (vs, ys) <- liftM unzip $ matchM (listView (equationView >>> equationSolvedForm)) xs
+         let v  = head vs
+             zs = nub $ map (simplify (squareRootViewWith rationalView)) ys
+         ds <- matchM (listView doubleView) zs
+         guard (all (==v) vs)
+         let rs = makeRanges including (sort (zipWith A ds zs))
+             including = rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]
+         return $ fmap (fmap fromDExpr) $ intervalRelations (A 0 (Var v)) $
+            ors [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ]
+   return $ removeClipboard "ineq"
+          $ replaceInContext new clr
+ where
+   makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)]
+   makeRanges b xs =
+      [makeLeft $ head xs]
+      ++ concatMap (uncurry makeMiddle) (zip xs (drop 1 xs))
+      ++ [makePoint (last xs) | b]
+      ++ [makeRight $ last xs]
+    where
+      makeLeft  a@(A d _)
+         | b         = (d-1, False, lessThanOrEqualTo a)
+         | otherwise = (d-1, False, lessThan a)
+      makeRight a@(A d _)
+         | b         = (d+1, False, greaterThanOrEqualTo a)
+         | otherwise = (d+1, False, greaterThan a)
+      makePoint a@(A d _) = (d, True, point a)
+      makeMiddle a1@(A d1 _) a2@(A d2 _) =
+         [ makePoint a1 | b ] ++
+         [ ( (d1+d2)/2
+           , False
+           , open a1 a2
+           )
+         ]
+
+   evalIneq :: Relation Expr -> String -> Double -> Bool
+   evalIneq r v d = fromMaybe False $
+      liftM2 (eval (relationType r)) (useSide leftHandSide) (useSide rightHandSide)
+    where
+      useSide f = match doubleView (sub (f r))
+
+      sub (Var x) | x==v = fromDouble d
+      sub expr = descend sub expr
+
+data DExpr = A Double Expr
+
+instance Eq DExpr where
+   A d1 _ == A d2 _ = d1==d2
+
+instance Ord DExpr where
+   A d1 _ `compare` A d2 _ = d1 `compare` d2
+
+fromDExpr :: DExpr -> Expr
+fromDExpr (A _ e) = e
+ src/Domain/Math/Polynomial/LeastCommonMultiple.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.LeastCommonMultiple
+   ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM
+   , powerProductView
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ratio
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Views
+import Ideas.Common.Utils.TestSuite
+import Ideas.Common.View
+import Prelude hiding ((^))
+import Test.QuickCheck
+
+-- | Returns the least common multiple of two expressions.
+lcmExpr :: Expr -> Expr -> Expr
+lcmExpr a b = fromMaybe (a*b) $ do
+   (ar, as) <- match powerProductView a
+   (br, bs) <- match powerProductView b
+   return $ build powerProductView (lcmR ar br, merge as bs)
+ where
+   lcmR :: Rational -> Rational -> Rational
+   lcmR r1 r2 =
+      let f r = numerator r * denominator r
+      in fromIntegral (lcm (f r1) (f r2))
+
+   merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)]
+   merge = foldr op id
+    where
+      op (e, n1) f ys =
+         let n2   = fromMaybe 0 (lookup e ys)
+             rest = filter ((/=e) . fst) ys
+         in (e, n1 `max` n2) : f rest
+
+-- | Only succeeds if there is no remainder
+divisionExpr :: Expr -> Expr -> Maybe Expr
+divisionExpr a b = do
+   (ar, as) <- match powerProductView a
+   (br, bs) <- match powerProductView b
+   xs       <- as `without` bs
+   return $ build powerProductView (ar/br, xs)
+ where
+   without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)]
+   without [] ys =
+      guard (null ys) >> return []
+   without ((e,n1):xs) ys =
+      let n2   = fromMaybe 0 (lookup e ys)
+          rest = filter ((/=e) . fst) ys
+      in liftM ((e,n1-n2):) (without xs rest)
+
+powerProductView :: View Expr (Rational, [(Expr, Integer)])
+powerProductView = makeView f g
+ where
+   f expr = do
+      (b, xs) <- match productView expr
+      let (r, ys) = collectPairs xs
+      return (if b then -r else r, merge ys)
+
+   g (r, xs) =
+      build productView (False, fromRational r : map (build pvn) xs)
+
+   pvn :: View Expr (Expr, Integer)
+   pvn = powerView >>> second integerView
+
+   collectPairs :: [Expr] -> (Rational, [(Expr, Integer)])
+   collectPairs = foldr op (1, [])
+    where
+      op e (r, xs) =
+         let mr   = match rationalView e
+             h r2 = (r*r2, xs)
+             pair = fromMaybe (e,1) (match pvn e)
+         in maybe (r, pair:xs) h mr
+
+   merge :: [(Expr, Integer)] -> [(Expr, Integer)]
+   merge [] = []
+   merge xs@((e, _) : _) =
+      let (xs1, xs2) = partition ((==e) . fst) xs
+          n = sum (map snd xs1)
+      in (e, n) : merge xs2
+
+testLCM :: TestSuite
+testLCM = suite "lcmExpr" $ do
+   addProperty "transitivity" $ f3 $ \a b c ->
+      lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c
+   addProperty "commutativity" $ f2 $ \a b ->
+      lcmExpr a b ~= lcmExpr b a
+   addProperty "idempotency" $ f1 $ \a ->
+      lcmExpr a a ~= absExpr a
+   addProperty "zero" $ f1 $ \a ->
+      lcmExpr a 0 ~= 0
+   addProperty "one" $ f1 $ \a ->
+      lcmExpr a 1 ~= absExpr a
+   addProperty "sign" $ f2 $ \a b ->
+      lcmExpr a b ~= lcmExpr (-a) b
+ where
+   f1 g = liftM  g genExpr
+   f2 g = liftM2 g genExpr genExpr
+   f3 g = liftM3 g genExpr genExpr genExpr
+
+   genExpr, genTerm, genAtom :: Gen Expr
+   genExpr = do
+      n  <- choose (0, 10)
+      b  <- arbitrary
+      xs <- replicateM n genTerm
+      return $ build productView (b, xs)
+
+   genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)]
+
+   genAtom = do
+      v <- elements $ map Var ["a", "b", "c"]
+      i <- choose (-10, 10)
+      n <- choose (0, 10)
+      p <- frequency [(3, return v), (1, return (v .+. fromInteger i))]
+      frequency [(3, return p), (1, return (p^fromInteger n))]
+
+   (~=)    = equalFactors
+   absExpr = simplifyWith (first (const False)) productView
+
+noCommonFactor :: Expr -> Expr -> Bool
+noCommonFactor x y = lcmExpr x y `equalFactors` (x*y)
+
+equalFactors :: Expr -> Expr -> Bool
+equalFactors x y = f x == f y
+ where f = simplifyWith (second sort) powerProductView
+ src/Domain/Math/Polynomial/RationalExamples.hs view
@@ -0,0 +1,166 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Example exercises from the Digital Mathematics Environment (DWO),
+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Polynomial.RationalExamples
+   ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit
+   ) where
+
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+----------------------------------------------------------
+-- VWO B applets
+
+-- Hoofdstuk 1, gebroken vergelijkingen
+brokenEquations :: [[Equation Expr]]
+brokenEquations =
+   -- Bereken exact de oplossingen
+   let x = Var "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)
+     ]
+   ]
+
+-- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a)
+normBroken :: [[Expr]]
+normBroken =
+   -- Herleid
+   let x = Var "x" in
+   let y = Var "y" in
+   let a = Var "a" in
+   let b = Var "b" in
+   [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x)
+     , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a)
+     , 7/(2*a)-2/(3*a),  9/(5*a)-1/(2*a)
+     ]
+   , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y)
+     , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b)
+     ]
+   , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1
+     , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2
+     ]
+   , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3)
+     , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2)
+     ]
+   , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4)
+     , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5)
+     , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4)
+     ]
+   , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2)
+     , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6)
+     ]
+   ]
+
+-- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a)
+normBroken2 :: [[Expr]]
+normBroken2 =
+   -- Herleid
+   let x = Var "x" in
+   let a = Var "a" in
+   let p = Var "p" in
+   [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24)
+     , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6)
+     , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20)
+     , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2)
+     ]
+   , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9)
+     , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25)
+     , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p)
+     ]
+   , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6)
+     , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x)
+     , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6)
+     , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a)
+     ]
+   ]
+
+deelUit :: [[Expr]]
+deelUit =
+   let x = Var "x" in
+   let a = Var "a" in
+   let p = Var "p" in
+   let t = Var "t" in
+   [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5
+     [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x)
+     ]
+   , -- sommen (2a)
+     [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t)
+     , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p)
+     , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x)
+     ]
+   ]
+
+-- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4
+normBrokenCon :: [[Equation Expr]]
+normBrokenCon =
+   -- Herleid
+   let a = Var "a" in
+   let p = Var "p" in
+   let t = Var "t" in
+   let ca = symbol (newSymbol "A") in
+   let ct = symbol (newSymbol "T") in
+   let cn = symbol (newSymbol "N") in
+   [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9)
+     , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p)
+     , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16)
+     , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2)
+     ]
+   , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3)
+     , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4)
+     ]
+   ]
+ src/Domain/Math/Polynomial/RationalExercises.hs view
@@ -0,0 +1,272 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.RationalExercises
+   ( rationalEquationExercise
+   , simplifyRationalExercise, divisionRationalExercise
+   , eqSimplifyRational
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Domain.Logic.Formula hiding (Var)
+import Domain.Logic.Views ((.&&.))
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Equation.Views
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.LeastCommonMultiple
+import Domain.Math.Polynomial.RationalExamples
+import Domain.Math.Polynomial.RationalRules
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Strategies
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.OldViews (powerFactorViewWith)
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils (fst3)
+import Ideas.Common.Utils.Uniplate
+import Prelude hiding ((^))
+import qualified Data.Foldable as F
+import qualified Data.Set as S
+import qualified Data.Traversable as T
+import qualified Domain.Logic as Logic
+import qualified Domain.Logic.Views as Logic
+
+rationalEquationExercise :: Exercise (OrList (Equation Expr))
+rationalEquationExercise = makeExercise
+   { exerciseId    = describe "solve a rational equation (with a variable in a divisor)" $
+                        newId "algebra.equations.rational"
+   , status        = Provisional
+   , parser        = parseOrsEqExpr
+   , suitable      = predicate (isJust . rationalEquations)
+   , ready         = predicateView relationsSolvedForm
+   , equivalence   = eqRationalEquation
+   , similarity    = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
+   , strategy      = rationalEquationStrategy
+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
+   , navigation    = termNavigator
+   , examples      = level Medium $ map singleton (concat brokenEquations)
+   }
+
+simplifyRationalExercise :: Exercise Expr
+simplifyRationalExercise = makeExercise
+   { exerciseId    = describe "simplify a rational expression (with a variable in a divisor)" $
+                        newId "algebra.manipulation.rational.simplify"
+   , status        = Alpha
+   , parser        = parseExpr
+   , ready         = predicate simplifiedRational
+--   , equivalence   = withoutContext eqSimplifyRational
+   , similarity    = withoutContext (viewEquivalent cleanUpView)
+   , strategy      = simplifyRationalStrategy
+   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
+   , navigation    = termNavigator
+   , examples      = level Medium $ concat (normBroken ++ normBroken2)
+   }
+
+divisionRationalExercise :: Exercise Expr
+divisionRationalExercise = simplifyRationalExercise
+   { exerciseId   = describe "divide a rational expression ('uitdelen')" $
+                       newId "math.divrational"
+   , strategy     = label "divide broken fraction" succeed
+   , examples     = level Medium $ concat deelUit
+   }
+
+rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
+rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $
+   label "Rational equation" $
+       brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy
+ where
+   -- a custom-made clean-up function. (Standard) cleanUpExpr function
+   -- has some strange interaction with the rules
+   cleaner = transform (simplify (powerFactorViewWith rationalView))
+           . cleanUpSimple . transform smart
+
+   brokenFormToPoly = label "rational form to polynomial" $ untilS allArePoly $
+      (  useC divisionIsZero <|> useC divisionIsOne
+     <|> useC sameDivisor <|> useC sameDividend
+     <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight
+     <|> use coverUpNegate
+      ) |>
+      (  useC crossMultiply <|> useC multiplyOneDiv  )
+   checkSolutionStrategy = label "check solutions" $
+      try (multi (showId checkSolution) (somewhere checkSolution))
+
+allArePoly :: Context (OrList (Equation Expr)) -> Bool
+allArePoly =
+   let f a = a `belongsTo` polyView
+   in maybe False (all f . concatMap F.toList . F.toList) .  fromContext
+
+simplifyRationalStrategy :: LabeledStrategy (Context Expr)
+simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $
+   label "Simplify rational expression" $
+      phaseOneDiv <*> phaseSimplerDiv
+ where
+   -- a custom-made clean-up function. (Standard) cleanUpExpr function
+   -- has some strange interaction with the rules
+   cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple
+
+   phaseOneDiv = label "Write as division" $
+      untilS isDivC $
+         use fractionPlus <|> use fractionScale <|> use turnIntoFraction
+   phaseSimplerDiv = label "Simplify division" $
+      repeatS $
+         (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv)
+            <|> commitS (onlyUpperDiv (repeatS findFactorsStrategyG) <*> useC cancelTermsDiv))
+         |> ( somewhere (use merge)
+         <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes))
+          )
+
+isDivC :: Context a -> Bool
+isDivC = maybe False (isJust . isDivide) . currentTerm
+
+-- First check that the whole strategy can be executed. Cleaning up is not
+-- propagated correctly to predicate in check combinator, hence the use of
+-- cleanUpStrategy (which is not desirable here).
+commitS :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
+commitS s =
+   let cs  = cleanUpStrategy (applyTop cleanUpExpr) (label "" s)
+       f a = fromMaybe a (do c <- currentInContext a; return (changeInContext (const c) (top a)))
+   in check (applicable cs . f) <*> s
+
+exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
+exceptLowerDiv = traverse [parentFilter p]
+ where p a = if isDivC a then [0] else [0 .. arity a-1]
+
+onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
+onlyUpperDiv = layer [ parentFilter $ \a -> [ 0 | isDivC a ] ]
+
+onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
+onlyLowerDiv = layer [ parentFilter $ \a -> [ 1 | isDivC a ] ]
+
+simplifiedRational :: Expr -> Bool
+simplifiedRational expr =
+   case expr of
+      Negate a -> simplifiedRational a
+      _        -> f expr
+ where
+   f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b
+   f _ = False
+
+   inPolyForm :: Expr -> Bool
+   inPolyForm a =
+      a `belongsTo` polyNormalForm identity ||
+      S.size (varSet expr) > 1
+
+   inFactorForm :: Expr -> Bool
+   inFactorForm = flip belongsTo $
+      let v = first (polyNormalForm identity >>> second linearPolyView)
+      in powerProductView >>> second (listView v)
+
+rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr)
+rationalEquations = fmap (F.foldMap id) . T.mapM rationalEquation
+
+rationalEquation :: Equation Expr -> Maybe (OrList Expr)
+rationalEquation eq = do
+   let (lhs :==: rhs) = coverUp eq
+       (a, b, c) = rationalExpr (lhs .-. rhs)
+   (_, as) <- match productView a
+   (_, bs) <- match productView b
+   let condition = foldr ((.&&.) . notZero) c bs
+   new1    <- match higherDegreeEquationsView $ toOrList $ map (:==: 0) as
+   return (restrictOrList condition new1)
+
+restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr
+restrictOrList p0 = catOrList . fmap f
+ where
+   f a | p a       = singleton a
+       | otherwise = false
+   p zeroExpr =
+      case coverUp (zeroExpr :==: 0) of
+         Var x :==: a -> -- returns true if a contradiction was not found
+            substVar x (cleanUpExpr a) p0 /= F
+         _ -> True
+
+   substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst))
+    where
+      subst (Var s) | x == s = a
+      subst expr = descend subst expr
+
+   simpler r = fromMaybe (Logic.Var r) $ do
+      a <- match (squareRootViewWith rationalView) (leftHandSide r)
+      b <- match (squareRootViewWith rationalView) (rightHandSide r)
+      case (a==b, relationType r) of
+         (True,  EqualTo)    -> return true
+         (False, EqualTo)    -> return false
+         (True,  NotEqualTo) -> return false
+         (False, NotEqualTo) -> return true
+         _ -> Nothing
+
+eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool
+eqRationalEquation ca cb = fromMaybe False $
+   liftM2 (==) (solve ca) (solve cb)
+ where
+   solve ctx = do
+      let f = fromMaybe T . conditionOnClipboard
+      a  <- fromContext ctx
+      xs <- rationalEquations a
+      return $ simplify orSetView $ restrictOrList (f ctx) xs
+
+eqSimplifyRational :: Expr -> Expr -> Bool
+eqSimplifyRational a b = fromMaybe False $ do
+   let a1c = cleanUpExpr (fst3 (rationalExpr a))
+       b1c = cleanUpExpr (fst3 (rationalExpr b))
+       manyVars = S.size (varSet a `S.union` varSet b) > 1
+   if manyVars then return True else do
+   p1 <- match (polyViewWith rationalView) a1c
+   p2 <- match (polyViewWith rationalView) b1c
+   return (p1==p2)
+
+conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr))
+conditionOnClipboard = lookupClipboardG "condition"
+
+-- write expression as a/b, under certain conditions
+rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr))
+rationalExpr expr =
+   case expr of
+      a :+: b  -> rationalExpr a `fPlus` rationalExpr b
+      a :-: b  -> rationalExpr (a :+: Negate b)
+      Negate a -> fNeg (rationalExpr a)
+      a :*: b  -> rationalExpr a `fTimes` rationalExpr b
+      a :/: b  -> rationalExpr a `fTimes` fRecip (rationalExpr b)
+      Sym s [a, b] | isPowerSymbol s ->
+         fPower (rationalExpr a) b
+      _ -> (expr, 1, T)
+ where
+   fNeg   (a, b, p)   = (neg a, b, p)
+   fRecip (a, b, p)   = (b, a, notZero b .&&. p)
+   fPower (a, b, p) n = (a .^. n, b .^. n, p)
+   fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q)
+   fPlus  (a1, a2, p) (b1, b2, q) =
+      case (divisionExpr c2 a2, divisionExpr c2 b2) of
+         (Just a3, Just b3)
+            | a1 == b1     -> (a1 .*. (a3 .+. b3), c2, pq)
+            | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq)
+            | otherwise    -> (a1 .*. a3 .+. b1 .*. b3, c2, pq)
+         _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq)
+    where
+      c2 = lcmExpr a2 b2
+      pq = p .&&. q
+
+notZero :: Expr -> Logic (Relation Expr)
+notZero expr =
+   case match rationalView expr of
+      Just r | r /= 0    -> T
+             | otherwise -> F
+      _ -> Logic.Var (expr ./=. 0)
+
+{-
+q = checkExercise simplifyRationalExercise
+go = rationalExpr $ (a^2-2*a-15)/(a^3-3*a^2-10*a)
+ where a = Var "a" -}
+ src/Domain/Math/Polynomial/RationalRules.hs view
@@ -0,0 +1,195 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.RationalRules
+   ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend
+   , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv
+   , fractionScale, turnIntoFraction, checkSolution
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Domain.Logic.Formula hiding (Var)
+import Domain.Logic.Views
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.LeastCommonMultiple
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.Views
+import Ideas.Common.Library
+import qualified Domain.Logic.Formula as Logic
+
+ratId :: Id
+ratId = newId "algebra.equations.rational"
+
+---------------------------------------------------------------
+-- Rules for rational expressions and rational equations
+
+-- a/b = 0  iff  a=0 (and b/=0)
+divisionIsZero :: Rule (Context (Equation Expr))
+divisionIsZero = makeRule (ratId, "division-zero") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   guard (rhs == 0)
+   (a, b) <- match divView lhs
+   return $ conditionNotZero b
+          $ replaceInContext (a :==: 0) ceq
+
+-- a/b = 1  iff  a=b (and b/=0)
+divisionIsOne :: Rule (Context (Equation Expr))
+divisionIsOne = makeRule (ratId, "division-one") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   guard (rhs == 1)
+   (a, b) <- match divView lhs
+   return $ conditionNotZero b
+          $ replaceInContext (a :==: b) ceq
+
+-- a/c = b/c  iff  a=b (and c/=0)
+sameDivisor :: Rule (Context (Equation Expr))
+sameDivisor = makeRule (ratId, "same-divisor") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   (a, c1) <- match divView lhs
+   (b, c2) <- match divView rhs
+   guard (c1==c2)
+   return $ conditionNotZero c1
+          $ replaceInContext (a :==: b) ceq
+
+-- a/b = a/c  iff  a=0 or b=c (and b/=0 and c/=0)
+sameDividend :: Rule (Context (OrList (Equation Expr)))
+sameDividend = makeRule (ratId, "same-dividend") $ \cor -> do
+   oreq <- currentInContext cor
+   lhs :==: rhs <- getSingleton oreq
+   (a1, b) <- matchM divView lhs
+   (a2, c) <- matchM divView rhs
+   guard (a1==a2)
+   let new = singleton (a1 :==: 0) <> singleton (b :==: c)
+   return $ conditionNotZero c
+          $ conditionNotZero b
+          $ replaceInContext new cor
+
+-- a/b = c/d  iff  a*d = b*c   (and b/=0 and d/=0)
+crossMultiply :: Rule (Context (Equation Expr))
+crossMultiply = makeRule (ratId, "cross-multiply") $ \ceq -> do
+   lhs :==: rhs <- currentInContext ceq
+   (a, b) <- match divView lhs
+   (c, d) <- match divView rhs
+   return $ conditionNotZero d
+          $ conditionNotZero b
+          $ replaceInContext (a*d :==: b*c) ceq
+
+-- a/b = c  iff  a = b*c  (and b/=0)
+multiplyOneDiv :: Rule (Context (Equation Expr))
+multiplyOneDiv = ruleList (ratId, "multiply-one-div") $ \ceq -> do
+   lhs :==: rhs <- maybeToList (currentInContext ceq)
+   f (:==:) lhs rhs ceq `mplus` f (flip (:==:)) rhs lhs ceq
+ where
+   f eq ab c ceq = do
+      guard (not (c `belongsTo` divView))
+      (a, b) <- matchM divView ab
+      return $ conditionNotZero b
+             $ replaceInContext (a `eq` (b*c)) ceq
+
+-- a/c + b/c = a+b/c   (also see Numeric.Rules)
+fractionPlus :: Rule Expr -- also minus
+fractionPlus = makeRule (ratId, "rational-plus") $ \expr -> do
+   ((a, b), (c, d)) <- match myView expr
+   guard (b == d)
+   return (build divView (a+c, b))
+ where
+   myView = plusView >>> (divView *** divView)
+
+-- ab/ac  =>  b/c  (if a/=0)
+-- Note that the common term can be squared (in one of the parts)
+cancelTermsDiv :: Rule (Context Expr)
+cancelTermsDiv = makeRule (ratId, "cancel-div") $ \ce -> do
+   expr <- currentInContext ce
+   ((b, xs), (c, ys)) <- match myView expr
+   let (ps, qs, rs) = rec (map f xs) (map f ys)
+       new = build myView ((b, map g ps), (c, map g qs))
+   guard (not (null rs))
+   return $ conditionNotZero (build productView (False, map g rs))
+          $ replaceInContext new ce
+ where
+   myView = divView >>> toView (productView *** productView)
+   powInt = powerView >>> second integerView
+   f a = fromMaybe (a, 1) (match powInt a)
+   g   = build powInt
+   rec ((_, 0):xs) ys = rec xs ys
+   rec (pair@(a, n):xs) ys =
+      case break ((==a) . fst) ys of
+         (ys1, (b, m):ys2)
+            | m == 0 ->
+                 rec (pair:xs) (ys1++ys2)
+            | otherwise ->
+                 let i = n `min` m
+                     (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2)
+                 in (ps, qs, (a,i):rs)
+         _ ->
+            let (ps,qs,rs) = rec xs ys
+            in (pair:ps, qs,rs)
+   rec xs ys = (xs, ys, [])
+
+fractionScale :: Rule Expr
+fractionScale = liftView myView $
+   makeRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do
+      guard (e1 /= e2)
+      let e3 = lcmExpr e1 e2
+      ma <- divisionExpr e3 e1
+      mb <- divisionExpr e3 e2
+      guard (ma /= 1 || mb /= 1)
+      return ((ma*a, e3), (mb*b, e3))
+ where
+   myView = plusView >>> (divView *** divView)
+
+turnIntoFraction :: Rule Expr
+turnIntoFraction = liftView plusView $
+   makeRule (ratId, "to-rational") $ \(a, b) ->
+      liftM (\c -> (c, b)) (f a b) `mplus`
+      liftM (\c -> (a, c)) (f b a)
+ where
+   f a b = do
+      guard (not (a `belongsTo` divView))
+      (_, e) <- match divView b
+      return $ build divView (a*e, e)
+
+-- A simple implementation that considers the condition stored in the context
+checkSolution :: Rule (Context (OrList (Equation Expr)))
+checkSolution = makeRule (ratId, "check-solution") $ \cor -> do
+   oreq <- currentInContext cor
+   x :==: a <- getSingleton oreq
+   c  <- lookupClipboardG "condition" cor
+   xs <- match andView c
+   guard ((x ./=. a) `elem` xs)
+   return $ replaceInContext false cor
+
+---------------------------------------------------------------
+-- Helper-code
+
+condition :: Logic (Relation Expr) -> Context a -> Context a
+condition p c
+   | new == T  = {- removeClipboardC "condition" -} c
+   | otherwise = addToClipboardG "condition" new c
+ where
+   mp  = lookupClipboardG "condition" c
+   new = maybe id (.&&.) mp p
+
+conditionNotZero :: Expr -> Context a -> Context a
+conditionNotZero expr = condition (f xs)
+ where
+   f  = pushNotWith (Logic.Var . notRelation) . Not
+   eq = expr :==: 0
+   xs = fmap (build equationView . fmap cleanUpExpr) $
+        case match higherDegreeEquationsView (singleton eq) of
+           Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys))
+           Nothing -> Logic.Var (coverUp eq)
+ src/Domain/Math/Polynomial/Rules.hs view
@@ -0,0 +1,609 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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
+   ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms
+   , commonFactorVar, commonFactorVarNew, defPowerNat
+   , distributeDivisionT, distributeDivisionMulti
+   , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare
+   , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero
+   , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar
+   , prepareSplitSquare, quadraticRuleOrder, removeDivision
+   , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational
+   , ruleNormalizePolynomial
+   , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRootMulti
+   , squareBothSides, substBackVar, varToLeft, conditionVarsRHS, fractionProduct
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Data.Ratio
+import Domain.Math.Approximation (precision)
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.BalanceRules
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.OldViews (powerFactorView)
+import Domain.Math.Safe
+import Domain.Math.Simplification hiding (simplifyWith, distribution)
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library hiding (terms, simplify)
+import Ideas.Common.Utils (thd3)
+import Ideas.Common.Utils.Uniplate (universe, descend)
+import Prelude hiding ( (^) )
+import qualified Prelude
+
+quadraticRuleOrder :: [Id]
+quadraticRuleOrder =
+   [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar)
+   , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar)
+   , getId coverUpPower
+   , getId commonFactorVar, getId simplerPolynomial
+   , getId niceFactors, getId noLinFormula
+   , getId cancelTerms, getId sameConFactor, getId distributionSquare
+   , getId allPowerFactors
+   ]
+
+lineq, quadreq, polyeq :: String
+lineq   = "algebra.equations.linear"
+quadreq = "algebra.equations.quadratic"
+polyeq  = "algebra.equations.polynomial"
+
+------------------------------------------------------------
+-- General form rules: ax^2 + bx + c = 0
+
+quadraticNF :: View Expr (String, (Rational, Rational, Rational))
+quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView
+
+-- ax^2 + bx = 0
+commonFactorVar :: Rule (Equation Expr)
+commonFactorVar = rhsIsZero commonFactorVarNew
+
+-- Maybe to be replaced by more general factorVariablePower??
+commonFactorVarNew :: Rule Expr
+commonFactorVarNew = describe "Common factor variable" $
+   makeRule (quadreq, "common-factor") $ \expr -> do
+      (x, (a, b, c)) <- match quadraticNF expr
+      guard (a /= 0 && b /= 0 && c == 0)
+      -- also search for constant factor
+      let d = signum a * gcdFrac a b
+      return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)))
+
+gcdFrac :: Rational -> Rational -> Rational
+gcdFrac r1 r2 =
+   if denominator r1 == 1 && denominator r2 == 1
+   then fromInteger (numerator r1 `gcd` numerator r2)
+   else 1
+
+-- ax^2 + c = 0
+noLinFormula :: Rule (Equation Expr)
+noLinFormula = describe "No linear term ('b=0')" $ liftView myView $
+   ruleMaybe (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do
+      guard (rhs == 0 && b == 0 && c /= 0)
+      return $ if a>0 then ((x, (a, 0, 0)), -c)
+                      else ((x, (-a, 0, 0)), c)
+ where
+   myView = constantRight quadraticNF
+
+-- search for (X+A)*(X+B) decomposition
+niceFactors :: Rule (Equation Expr)
+niceFactors = rhsIsZero niceFactorsNew
+
+-- search for (X+A)*(X+B) decomposition
+niceFactorsNew :: Rule Expr
+niceFactorsNew = describe "Find a nice decomposition" $
+   makeRule (quadreq, "nice-factors") $ \expr -> do
+   let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t
+   (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> second quadraticPolyView) expr)
+   guard (a==1)
+   let ok (i, j) = i+j == b
+       f  (i, j)
+          | i == j = -- special case
+              (Var x + fromInteger i) ^ 2
+          | otherwise =
+              (Var x + fromInteger i) * (Var x + fromInteger j)
+   map f (filter ok (factors c))
+ where
+   factors :: Integer -> [(Integer, Integer)]
+   factors n = [ pair
+               | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n)))
+               , a <- [1..h], let b = n `div` a, a*b == n
+               , pair <- [(a, b), (negate a, negate b)]
+               ]
+
+-- Simplify polynomial by multiplying (or dividing) the terms:
+-- 1) If a,b,c are ints, then find gcd
+-- 2) If any of a,b,c is a fraction, find lcm of denominators
+-- 3) If a<0, then also suggest to change sign (return two solutions)
+simplerPolynomial :: Rule (Equation Expr)
+simplerPolynomial = describe "simpler polynomial" $
+   rhsIsZero $ liftViewIn (quadraticNF >>> toView swapView) $
+   makeRule (quadreq, "simpler-poly") $ \(a, b, c) -> do
+      r <- findFactor (filter (/=0) [a, b, c])
+      d <- if a >= 0 then [r] else [-r, r]
+      guard (d `notElem` [0, 1])
+      return (a*d, b*d, c*d)
+
+-- Simplified variant of simplerPoly: just bring a to 1.
+-- Needed for quadratic strategy without square formula
+bringAToOne :: Rule (Equation Expr)
+bringAToOne = rhsIsZero $ liftViewIn (quadraticNF >>> toView swapView) $
+   describe "Bring 'a' to one" $
+   ruleMaybe (quadreq, "scale") $ \(a, b, c) -> do
+      guard (a `notElem` [0, 1])
+      return (1, b/a, c/a)
+
+------------------------------------------------------------
+-- General form rules: expr = 0
+
+-- Rule must be symmetric in side of equation
+mulZero :: Rule (OrList (Equation Expr))
+mulZero = describe "multiplication is zero" $
+   makeRule (quadreq, "product-zero") $ oneDisjunct bothSides
+ where
+   bothSides eq = oneSide eq ++ oneSide (flipSides eq)
+   oneSide (lhs :==: rhs) = do
+      guard (rhs == 0)
+      (_, xs) <- matchM productView lhs
+      guard (length xs > 1)
+      return $ toOrList $ flip map xs $ \e ->
+         case match (polyNormalForm rationalView >>> second linearPolyView) e of
+            -- special cases (simplify immediately, as in G&R)
+            Just (x, (a, b))
+               | a == 1 ->
+                    Var x :==: fromRational (-b)
+               | a == -1 ->
+                    Var x :==: fromRational b
+            _ -> e :==: 0
+
+------------------------------------------------------------
+-- 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        = "onevar"
+   , predicateCovered  = \a -> p1 a || p2 a
+   , predicateCombined = hasNoVar
+   , coverLHS          = True
+   , coverRHS          = True
+   }
+ where
+   p1 = (==1) . length . vars
+   -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56
+   p2 a = fromMaybe False $ do
+      (x, y) <- match timesView a
+      return (hasSomeVar x /= hasSomeVar y)
+
+------------------------------------------------------------
+-- Top form rules: expr1 = expr2
+
+simplerSquareRootMulti :: IsTerm a => Rule (Context a)
+simplerSquareRootMulti = describe "simpler square root" $
+   makeRule (quadreq, "simpler-sqrt") $ applyAll $
+   repeat1 (somewhere (use (makeRule () simplerSqrt)))
+ where
+   -- Do not simplify (5+sqrt 53)/2
+   simplerSqrt :: Expr -> Maybe Expr
+   simplerSqrt e = do
+      xs <- f e
+      guard (not (null xs))
+      new <- canonical (squareRootViewWith rationalView) e
+      ys <- f new
+      guard (xs /= ys)
+      return new
+
+   -- return numbers under sqrt symbol
+   f :: Expr -> Maybe [Rational]
+   f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ]
+
+cancelTerms :: Rule (Equation Expr)
+cancelTerms = describe "Cancel terms" $
+   makeRule (quadreq, "cancel") $ \(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)
+
+-- "merkwaardige producten"
+distributionSquare :: Rule Expr
+distributionSquare = describe "distribution for special products" $
+   rewriteRules (quadreq, "distr-square")
+      [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2
+      , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2
+      , \a b -> (a+b)*(a-b) :~> a^2 - b^2
+      , \a b -> (a-b)*(a+b) :~> a^2 - b^2
+      ]
+
+-- a^2 == b^2
+squareBothSides :: Rule (OrList (Equation Expr))
+squareBothSides = describe "square both sides" $
+   rewriteRule (quadreq, "square-both") $ \a b ->
+   singleton (a^2 :==: b^2) :~> toOrList [a :==: b, a :==: -b]
+
+-- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c
+prepareSplitSquare :: Rule (Equation Expr)
+prepareSplitSquare = describe "prepare split square" $
+   liftView myView $
+   ruleMaybe (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do
+      let newC   = (b/2)*(b/2)
+          newRHS = r + newC - c
+      guard (a==1 && b/=0 && c /= newC)
+      return ((x, (a, b, newC)), newRHS)
+ where
+   myView = constantRight quadraticNF
+
+-- factor left-hand side into (ax + c)^2
+factorLeftAsSquare :: Rule (Equation Expr)
+factorLeftAsSquare = describe "factor left as square" $
+   makeRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do
+      guard (hasNoVar rhs)
+      (x, (a, b, c)) <- match quadraticNF lhs
+      let h = b/2
+      guard (a==1 && b/=0 && h*h == c)
+      return ((Var x + build rationalView h)^2 :==: rhs)
+
+-- flip the two sides of an equation
+flipEquation :: Rule (Equation Expr)
+flipEquation = describe "flip equation" $
+   rewriteRule (lineq, "flip") $ \a b ->
+      (a :==: b) :~> (b :==: a)
+
+conditionVarsRHS :: Equation Expr -> Bool
+conditionVarsRHS (lhs :==: rhs) = hasSomeVar rhs && hasNoVar lhs
+
+-- Afterwards, merge and sort
+moveToLeft :: Rule (Equation Expr)
+moveToLeft = describe "Move to left" $
+   ruleMaybe (quadreq, "move-left") $ \(lhs :==: rhs) -> do
+      guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs))
+      return (collectLikeTerms (sorted (lhs - rhs)) :==: 0)
+ where
+   isComplex = maybe False ((>= 2) . length . filter hasSomeVar)
+             . match sumView . applyD merge
+
+   -- high exponents first, non power-factor terms at the end
+   sorted = simplifyWith (sortBy (comparing toPF)) sumView
+   toPF   = fmap (negate . thd3) . match powerFactorView
+
+ruleApproximate :: Rule (Relation Expr)
+ruleApproximate = describe "Approximate irrational number" $
+   makeRule (quadreq, "approx") $ \relation -> do
+      lhs :==: rhs <- match equationView relation
+      guard (not (simplify rhs `belongsTo` rationalView))
+      x <- getVariable lhs
+      d <- match doubleView rhs
+      let new = fromDouble (precision 4 d)
+      return (Var x .~=. new)
+
+ruleNormalizeRational :: Rule Expr
+ruleNormalizeRational =
+   describe "normalize rational number" $
+   ruleFromView (lineq, "norm-rational") rationalView
+
+ruleNormalizeMixedFraction :: Rule Expr
+ruleNormalizeMixedFraction =
+   describe "normalize mixed fraction" $
+   ruleFromView (lineq, "norm-mixed") mixedFractionView
+
+ruleNormalizePolynomial :: Rule Expr
+ruleNormalizePolynomial =
+   describe "normalize polynomial" $
+   ruleFromView (polyeq, "norm-poly") (polyNormalForm rationalView)
+
+-----------------------------------------------------------
+-------- Rules From HDE
+
+-- X*A + X*B = X*C + X*D
+-- New implementation, but slightly different than original
+-- This one does not factor constants
+
+allPowerFactors :: Rule (OrList (Equation Expr))
+allPowerFactors = describe "all power factors" $
+   makeRule (polyeq, "power-factors") $ oneDisjunct $
+   \(lhs :==: rhs) -> do
+      let myView = polyNormalForm rationalView
+      (s1, p1) <- match myView lhs
+      (s2, p2) <- match myView rhs
+      let n | p1 == 0   = lowestDegree p2
+            | p2 == 0   = lowestDegree p1
+            | otherwise = lowestDegree p1 `min` lowestDegree p2
+          ts  = filter (/= 0) (fromPolynomial p1 ++ fromPolynomial p2)
+          f p = build myView (s1, raise (-n) p)
+      guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1)
+      return $ toOrList [Var s1 :==: 0, f p1 :==: f p2]
+
+factorVariablePower :: Rule Expr
+factorVariablePower = describe "factor variable power" $
+   makeRule (polyeq, "factor-varpower") $ \expr -> do
+   let myView = polyNormalForm rationalView
+   (s, p) <- match (polyNormalForm rationalView) expr
+   let n = lowestDegree p
+   guard (n > 0 && length (filter (/=0) (fromPolynomial p)) > 1)
+   new <- p `safeDiv` (var Prelude.^ n)
+   return $ Var s .^. fromIntegral n * build myView (s, new)
+
+-- A*B = A*C  implies  A=0 or B=C
+sameFactor :: Rule (OrList (Equation Expr))
+sameFactor = describe "same factor" $
+   makeRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do
+      (b1, xs) <- match productView lhs
+      (b2, ys) <- match productView rhs
+      (x, y) <- listToMaybe [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong?
+      return $ toOrList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ]
+
+-- N*(A+B) = N*C + N*D   recognize a constant factor on both sides
+-- Example: 3(x^2+1/2) = 6+6x
+sameConFactor :: Rule (Equation Expr)
+sameConFactor =
+   describe "same constant factor" $
+   liftView myView $
+   makeRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do
+      let (bs, zs) = unzip (ps1 ++ ps2)
+          (rs, es) = unzip (map (f 1 []) zs)
+          f r acc []     = (r, reverse acc)
+          f r acc (x:xs) = case match rationalView x of
+                              Just r2 -> f (r*r2) acc xs
+                              Nothing -> f r (x:acc) xs
+      c <- whichCon rs
+      guard (c /= 1)
+      let make b r e          = (b, fromRational (r/c):e)
+          (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es)
+      return (newLeft :==: newRight)
+ where
+   myView = bothSidesView (toView sumView >>> listView (toView productView))
+
+   whichCon :: [Rational] -> Maybe Rational
+   whichCon xs
+      | all (\x -> denominator x == 1 && x /= 0) xs =
+           Just (fromInteger (foldr1 gcd (map numerator xs)))
+      | otherwise = Nothing
+
+abcFormula :: Rule (Context (OrList (Equation Expr)))
+abcFormula = describe "quadratic formula (abc formule)" $
+   makeRule (quadreq, "abc") $ \cor -> do
+   oreq <- currentInContext cor
+   lhs :==: rhs  <- getSingleton oreq
+   guard (rhs == 0)
+   (x, (a, b, c)) <- matchM quadraticNF lhs
+   let discr = b*b - 4 * a * c
+       sqD   = sqrt (fromRational discr)
+       eqs   = case compare discr 0 of
+                  LT -> false
+                  EQ -> singleton $
+                     Var x :==: (-fromRational b) / (2 * fromRational a)
+                  GT -> toOrList
+                     [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a)
+                     , Var x :==: (-fromRational b - sqD) / (2 * fromRational a)
+                     ]
+   return $ addToClipboard "a" (fromRational a)
+          $ addToClipboard "b" (fromRational b)
+          $ addToClipboard "c" (fromRational c)
+          $ addToClipboard "D" (fromRational discr)
+          $ replaceInContext eqs cor
+
+higherSubst :: Rule (Context (Equation Expr))
+higherSubst = describe "Substitute variable" $
+   ruleMaybe (polyeq, "subst") $ \ceq -> do
+      lhs :==: rhs <- fromContext ceq
+      guard (rhs == 0)
+      let myView = polyView >>> second trinomialPolyView
+      (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs
+      guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p")
+      let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2)))
+      return $ addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2))
+             $ replaceInContext (new :==: 0) ceq
+
+substBackVar :: Rule (Context Expr)
+substBackVar = describe "Substitute back a variable" $
+   makeRule (polyeq, "back-subst") $ \ca -> do
+   a    <- fromContext ca
+   expr <- lookupClipboard "subst" ca
+   case fromExpr expr of
+      Just (Var p :==: rhs) -> do
+         guard (hasVar p a)
+         return (replaceInContext (subst p rhs a) ca)
+      _ -> fail "no subst in clipboard"
+ where
+   subst a b (Var c) | a==c = b
+   subst a b expr = descend (subst a b) expr
+
+exposeSameFactor :: Rule (Equation Expr)
+exposeSameFactor = describe "expose same factor" $
+   liftView (bothSidesView (toView productView)) $
+   makeRule (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do
+      (nx, ny) <- [ (xs, new) | x <- xs, isOk x, new <- exposeList x ys ] ++
+                  [ (new, ys) | y <- ys, isOk y, new <- exposeList y xs ]
+      return ((bx, nx) :==: (by, ny))
+ where
+   isOk p = fromMaybe False $ do
+      (_, _, b) <- match (linearViewWith rationalView) p
+      guard (b /= 0)
+      return True
+
+   exposeList _ [] = []
+   exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs)
+
+   expose a b = do
+      (s1, p1) <- matchM (polyViewWith rationalView) a
+      (s2, p2) <- matchM (polyViewWith rationalView) b
+      guard (s1==s2 && p1/=p2)
+      case safeDiv p2 p1 of
+         Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3]
+         Nothing -> []
+
+---------------------------------------------------------
+-- From LinearEquations
+
+-- Only used for cleaning up
+distributeAll :: Expr -> Expr
+distributeAll expr =
+   case expr of
+      e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1)
+                       bs = fromMaybe [e2] (match sumView e2)
+                   in build sumView [ a .*. b | a <- as, b <- bs ]
+      _ -> expr
+
+-- 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"
+distribution :: Expr -> [Expr]
+distribution expr = do
+   (b, xs) <- matchM simpleProductView expr
+   ys      <- rec (combine xs)
+   return $ build simpleProductView (b, ys)
+ where
+   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 e1 e2 = do
+      as <- matchM sumView e1
+      bs <- matchM sumView e2
+      guard (length as > 1 || length bs > 1)
+      return $ build sumView [ a .*. b | a <- as, b <- bs ]
+
+-------------------------------------------------------
+-- Rewrite Rules
+
+varToLeft :: Rule (Relation Expr)
+varToLeft = doAfter (fmap collectLikeTerms) $
+   describe "variable to left" $
+   ruleTrans (lineq, "var-left") $
+   supplyParameters minusRule $ \eq -> do
+      (x, a, _) <- matchM (linearViewWith rationalView) (rightHandSide eq)
+      guard (a/=0)
+      return (fromRational a * Var x)
+
+-- factor is always positive due to lcm function
+removeDivision :: Rule (Relation Expr)
+removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $
+   describe "remove division" $
+   ruleTrans (lineq, "remove-div") $
+   supplyParameters timesRule $ \eq -> do
+      xs <- matchM sumView (leftHandSide eq)
+      ys <- matchM sumView (rightHandSide eq)
+      -- also consider parts without variables
+      -- (but at least one participant should have a variable)
+      zs <- forM (xs ++ ys) $ \a -> do
+               (_, list) <- matchM productView a
+               return [ (hasSomeVar a, e) | e <- list ]
+      let f (b, e) = do
+             (_, this) <- match (divView >>> second integerView) e
+             return (b, this)
+          (bs, ns) = unzip (mapMaybe f (concat zs))
+      guard (or bs)
+      return (fromInteger (foldr1 lcm ns))
+
+distributeTimes :: Rule Expr
+distributeTimes = describe "distribution multiplication" $
+   makeRule (lineq, "distr-times") $
+      liftM collectLikeTerms . distribution
+
+distributeDivisionMulti :: IsTerm a => Rule (Context a)
+distributeDivisionMulti = describe "distribution division" $
+   makeRule (quadreq, "distr-div") $ apply $ repeat1 $
+      somewhere (use (makeRule () distributeDivisionT))
+
+distributeDivisionT :: Expr -> Maybe Expr
+distributeDivisionT expr = do
+   (xs, r) <- match (divView >>> (toView sumView *** rationalView)) expr
+   guard (length xs > 1)
+   let ys = map (/fromRational r) xs
+   return $ build sumView ys
+
+merge :: Rule Expr
+merge = describe "merge similar terms" $
+   ruleMaybe (lineq, "merge") $ \old -> do
+      let norm = cleanUpSimple old -- don't use rule just for cleaning up
+          new  = collectLikeTerms norm
+          f    = maybe 0 length . match sumView
+      guard (f norm > f new)
+      return new
+
+simplerLinearFactor :: Rule Expr
+simplerLinearFactor = describe "simpler linear factor" $
+   makeRule (polyeq, "simpler-linfactor") $ \expr -> do
+   let myView = polyNormalForm rationalView >>> second linearPolyView
+   (x, (a, b)) <- match myView expr
+   let d = (if a<0 then negate else id) (gcdFrac a b)
+   guard (a /= 0 && b /= 0 && d `notElem` [1, -1])
+   return $ fromRational d * build myView (x, (a/d, b/d))
+
+ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a
+ruleFromView s v = makeRule s $ \a -> do
+   b <- canonical v a
+   guard (a /= b)
+   return b
+
+rhsIsZero :: Rule Expr -> Rule (Equation Expr)
+rhsIsZero r = makeRule (showId r) $ \(lhs :==: rhs) -> do
+   guard (rhs == 0)
+   a <- applyAll r lhs
+   return (a :==: rhs)
+
+constantRight :: View Expr a -> View (Equation Expr) (a, Rational)
+constantRight v = makeView f g
+ where
+   f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs)
+   g (a, r) = build v a :==: build rationalView r
+
+bothSidesView :: View a b -> View (Equation a) (Equation b)
+bothSidesView v = makeView f (fmap (build v))
+ where
+   f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs)
+
+findFactor :: Monad m => [Rational] -> m Rational
+findFactor rs
+   | null rs =
+        fail "no factor"
+   | all ((==1) . denominator) rs =
+        return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs
+   | otherwise =
+        return $ fromIntegral $ foldr1 lcm $ map denominator rs
+
+noDivisionConstant :: Rule Expr
+noDivisionConstant = makeRule (lineq, "no-div-con") f
+ where
+   f (a :/: b) | hasNoVar b && hasSomeVar a =
+      return ((1/b) * a)
+   f _ = Nothing
+
+-- (a/b) * (c/d) = (a*c)/(b*d)
+fractionProduct :: Rule Expr
+fractionProduct = makeRule (polyeq, "fraction-product") $ \expr -> do
+   ((a, b), (c, d)) <- match (timesView >>> divView *** divView) expr
+   return ((a .*. c) ./. (b .*. d))
+
+defPowerNat :: Rule Expr
+defPowerNat = makeRule (polyeq, "def-power-nat") f
+ where
+   f (Sym _ [Var _, _]) = Nothing -- should not work on x^5
+   f (Sym s [a, Nat n]) | isPowerSymbol s =
+      return (build productView (False, replicate (fromInteger n) a))
+   f _ = Nothing
+ src/Domain/Math/Polynomial/Strategies.hs view
@@ -0,0 +1,195 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, linearMixedStrategy, linearStrategyG
+   , quadraticStrategy, quadraticStrategyG
+   , higherDegreeStrategy, higherDegreeStrategyG
+   , findFactorsStrategy, findFactorsStrategyG, expandStrategy
+   ) where
+
+import Data.Maybe
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Rules
+import Domain.Math.Polynomial.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate (transform)
+
+------------------------------------------------------------
+-- Linear equations
+
+linearStrategy :: LabeledStrategy (Context (Equation Expr))
+linearStrategy = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) linearStrategyG
+
+linearMixedStrategy :: LabeledStrategy (Context (Equation Expr))
+linearMixedStrategy =
+   let f   = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple))
+       cfg = makeStrategyConfiguration
+                [ (byName ruleNormalizeMixedFraction, Reinsert)
+                , (byName ruleNormalizeRational, Remove)
+                ]
+   in cleanUpStrategyAfter f (configureNow (configure cfg linearStrategyG))
+
+linearStrategyG :: IsTerm a => LabeledStrategy (Context a)
+linearStrategyG =
+   label "Linear Equation" $
+       label "Phase 1" (repeatS (
+               use removeDivision
+          <|>  multi (showId distributeTimes) (oncetd (use distributeTimes))
+          <|>  multi (showId merge) (layer [] (use merge))))
+   <*> label "Phase 2" (repeatS (
+              (flipEquationS |> use varToLeft)
+          <|> use (coverUpPlusWith oneVar)
+          <|> use (coverUpMinusLeftWith oneVar)
+          <|> use (coverUpMinusRightWith oneVar)
+          <|> use coverUpTimes
+          <|> use coverUpNegate
+           ))
+   <*> repeatS (layer []
+          (  use ruleNormalizeRational
+         <|> remove (use ruleNormalizeMixedFraction)
+          ))
+
+------------------------------------------------------------
+-- Quadratic equations
+
+quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
+quadraticStrategy =
+   cleanUpStrategyAfter (applyTop cleanUpRelations) quadraticStrategyG
+
+quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a)
+quadraticStrategyG =
+   label "Quadratic Equation Strategy" $ repeatS $
+   -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula
+      somewhere (generalForm <|> generalABCForm)
+      |> somewhere zeroForm
+      |> somewhere constantForm
+      |> simplifyForm
+      |> topForm
+ where
+   -- ax^2 + bx + c == 0, without quadratic formula
+   generalForm = label "general form" $
+          use commonFactorVar
+      <|> use noLinFormula
+      <|> use simplerPolynomial
+      <|> remove (use bringAToOne)
+      <|> use niceFactors
+      <|> use coverUpPower -- to deal with special case x^2=0
+
+   generalABCForm = label "abc form" $
+      useC abcFormula
+
+   zeroForm = label "zero form" $
+      use mulZero
+
+   -- expr == c
+   constantForm = label "constant form" $
+          use (coverUpPlusWith oneVar)
+      <|> use (coverUpMinusLeftWith oneVar)
+      <|> use (coverUpMinusRightWith oneVar)
+      <|> use coverUpTimes
+      <|> use coverUpNegate
+      <|> use coverUpNumerator
+      <|> use squareBothSides
+      <|> use factorLeftAsSquare
+
+   -- simplifies square roots, or do an approximation
+   simplifyForm =
+      label "square root simplification" simplerSquareRootMulti
+      <|>
+      remove (label "approximate result" (
+         multi (showId ruleApproximate) (somewhere (use ruleApproximate))))
+
+   topForm = label "top form" $
+        somewhere (use cancelTerms  <|> use sameFactor)
+      |> (  somewhere (use sameConFactor)
+        <|> multi (showId merge) (somewhere (use merge))
+        <|> somewhere (use distributionSquare)
+        <|> multi (showId distributeTimes) (oncetd
+               (use distributeTimes))
+        <|> distributeDivisionMulti
+        <|> somewhere flipEquationS
+         )
+      |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare))
+
+-----------------------------------------------------------
+-- Higher degree equations
+
+higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
+higherDegreeStrategy =
+   cleanUpStrategyAfter (applyTop cleanUpRelations) higherDegreeStrategyG
+
+higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a)
+higherDegreeStrategyG = label "higher degree" $
+   higherForm
+   <*> label "quadratic"  quadraticStrategyG
+   <*> afterSubst
+ where
+   higherForm = label "higher degree form" $ repeatS $
+      somewhere (use allPowerFactors)
+      |> somewhere (
+              use coverUpPower
+          <|> use mulZero
+          <|> use sameFactor
+          <|> use coverUpTimes
+          <|> use exposeSameFactor
+          <|> use (coverUpPlusWith oneVar)
+          <|> use (coverUpMinusLeftWith oneVar)
+          <|> use (coverUpMinusRightWith oneVar)
+          <|> use sameConFactor
+          <|> useC higherSubst)
+      |> somewhere (use moveToLeft)
+
+   afterSubst = label "afterwards" $ try $
+      useC substBackVar  <*> repeatS (somewhere (use coverUpPower))
+
+-----------------------------------------------------------
+-- Finding factors in an expression
+
+findFactorsStrategy :: LabeledStrategy (Context Expr)
+findFactorsStrategy = cleanUpStrategyAfter (applyTop cleanUpSimple) $
+   label "find factors" $ repeatS findFactorsStrategyG
+
+findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a)
+findFactorsStrategyG = label "find factor step" $
+   somewhereTimes $
+      use niceFactorsNew <|> use commonFactorVarNew
+      <|> use factorVariablePower <|> use simplerLinearFactor
+
+somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a)
+somewhereTimes = traverse [ parentFilter p]
+ where p c = if isTimesC c then [0 .. arity c-1] else []
+
+isTimesC :: Context a -> Bool
+isTimesC = maybe False (isJust . isTimes) . currentTerm
+
+flipEquationS :: IsTerm a => Strategy (Context a)
+flipEquationS = use (check conditionVarsRHS) <*> use flipEquation
+
+-----------------------------------------------------------
+-- Expanding factors of an expression
+
+expandStrategy :: LabeledStrategy (Context Expr)
+expandStrategy = cleanUpStrategyAfter (applyTop f . changeInContext g) $
+   label "expand factors" $ repeatS (somewhere $
+      use distributionSquare <|> use merge <|> use distributeTimes <|>
+      use defPowerNat <|> use noDivisionConstant <|> use fractionProduct)
+   <*>
+      try (use ruleNormalizePolynomial)
+ where -- mergeAlike
+   f = transform (simplify (listOfPowerFactors "x" rationalView))
+     -- . cleanUpSimple
+   g = simplify (polyRelaxedForm rationalView)
+ src/Domain/Math/Polynomial/Tests.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Tests (tests) where
+
+import Control.Monad
+import Domain.Math.Data.Polynomial
+import Ideas.Common.Algebra.Field
+import Ideas.Common.Algebra.FieldLaws
+import Ideas.Common.Algebra.Law
+import Ideas.Common.Utils.TestSuite
+
+tests :: TestSuite
+tests = suite "Polynomial is a commutative ring" $
+   forM_ (commutativeRingLaws :: [Law (SafeNum (Polynomial Int))]) $ \p ->
+      addProperty (show p) p
+ src/Domain/Math/Polynomial/Views.hs view
@@ -0,0 +1,333 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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, polyViewWith
+   , quadraticView, quadraticViewWith
+   , linearView, linearViewWith
+   , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView
+   , monomialPolyView, binomialPolyView, trinomialPolyView
+   , polyNormalForm, polyRelaxedForm
+   , linearEquationView, quadraticEquationView, quadraticEquationsView
+   , higherDegreeEquationsView, listOfPowerFactors
+   ) where
+
+import Control.Monad
+import Data.Foldable (foldMap, toList)
+import Data.Maybe
+import Data.Traversable (mapM)
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Polynomial
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.OldViews (powerFactorViewForWith)
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Classes
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils (distinct)
+import Ideas.Common.Utils.Uniplate (transform, descend, children)
+import Ideas.Common.View
+import Prelude hiding ((^))
+import qualified Domain.Math.Data.SquareRoot as SQ
+import qualified Prelude
+
+polyViewWithNew :: View (String, Expr) (String, Polynomial Expr)
+polyViewWithNew = makeView matchPoly buildPoly
+ where
+   matchPoly (s, expr) = liftM ((,) s) (matchPolyFor s expr)
+   buildPoly (s, p)    = (s, buildPolyFor s p)
+
+   matchPolyFor pv 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
+            guard (withoutVar pv b)
+            p <- f a
+            d <- match rationalApproxView b
+            guard (d /= 0)
+            return (fmap (/fromRational d) p)
+         Sym s [a, n] | isPowerSymbol s ->
+           liftM2 (Prelude.^) (f a) (matchNat n)
+         _ -> do
+            guard (withoutVar pv expr)
+            return (con expr)
+    where
+      f = matchPolyFor pv
+
+   buildPolyFor pv =
+      let f (a, n) = a .*. (Var pv .^. fromIntegral n)
+      in build sumView . map f . reverse . terms
+
+   matchNat expr = do
+      n <- match integerView expr
+      guard (n >= 0)
+      return n
+
+-------------------------------------------------------------------
+-- Polynomial view
+
+polyView :: View Expr (String, Polynomial Expr)
+polyView = (f <-> snd) >>> polyViewWithNew
+ where
+   f a = (fromMaybe "" (selectVar a), a)
+
+polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a)
+polyViewWith v = polyView >>> second (traverseView v)
+
+-------------------------------------------------------------------
+-- Quadratic view
+
+quadraticView :: View Expr (String, Expr, Expr, Expr)
+quadraticView = quadraticViewWith identity
+
+quadraticViewWith :: (Eq a,Fractional a) => View Expr a -> View Expr (String, a, a, a)
+quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> (f <-> g)
+ where
+   f (s, (a, b, c)) = (s, a, b, c)
+   g (s, a, b, c)   = (s, (a, b, c))
+
+-------------------------------------------------------------------
+-- Linear view
+
+linearView :: View Expr (String, Expr, Expr)
+linearView = linearViewWith identity
+
+linearViewWith :: (Eq a,Fractional a) => View Expr a -> View Expr (String, a, a)
+linearViewWith v = polyViewWith v >>> second linearPolyView >>> (f <-> g)
+ where
+   f (s, (a, b)) = (s, a, b)
+   g (s, a, b)   = (s, (a, b))
+
+-------------------------------------------------------------------
+-- Views on polynomials (degree)
+
+constantPolyView :: (Eq a,Num a) => View (Polynomial a) a
+constantPolyView = makeView (isList1 . fromPolynomial) (buildList . list1)
+
+linearPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a)
+linearPolyView = makeView (isList2 . fromPolynomial) (buildList . list2)
+
+quadraticPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a, a)
+quadraticPolyView = makeView (isList3 . fromPolynomial) (buildList . list3)
+
+cubicPolyView :: (Eq a,Num a) => View (Polynomial a) (a, a, a, a)
+cubicPolyView = makeView (isList4 . fromPolynomial) (buildList . list4)
+
+-------------------------------------------------------------------
+-- Views on polynomials (number of terms)
+
+monomialPolyView :: (Eq a,Num a) => View (Polynomial a) (a, Int)
+monomialPolyView = makeView (isList1 . terms) (buildPairs . list1)
+
+binomialPolyView :: (Eq a,Num a) => View (Polynomial a) ((a, Int), (a, Int))
+binomialPolyView = makeView (isList2 . terms) (buildPairs . list2)
+
+trinomialPolyView :: (Eq a,Num a) => View (Polynomial a) ((a, Int), (a, Int), (a, Int))
+trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3)
+
+-- helpers
+buildList :: (Eq a,Num a) => [a] -> Polynomial a
+buildList = buildPairs . flip zip [0..] . reverse
+
+buildPairs :: (Eq a,Num a) => [(a, Int)] -> Polynomial a
+buildPairs as
+   | null as   = 0
+   | otherwise = sum (map f as)
+ where
+   f (a, n) = con a * var Prelude.^ n
+
+list1 :: a -> [a]
+list1 a = [a]
+
+list2 :: (a, a) -> [a]
+list2 (a, b)     = [a, b]
+
+list3 :: (a, a, a) -> [a]
+list3 (a, b, c) = [a, b, c]
+
+list4 :: (a, a, a, a) -> [a]
+list4 (a, b, c, d) = [a, b, c, d]
+
+isList1 :: [a] -> Maybe a
+isList1 [a] = Just a
+isList1 _   = Nothing
+
+isList2 :: [a] -> Maybe (a, a)
+isList2 [a, b] = Just (a, b)
+isList2 _      = Nothing
+
+isList3 :: [a] -> Maybe (a, a, a)
+isList3 [a, b, c] = Just (a, b, c)
+isList3 _         = Nothing
+
+isList4 :: [a] -> Maybe (a, a, a, a)
+isList4 [a, b, c, d] = Just (a, b, c, d)
+isList4 _            = Nothing
+
+terms :: (Eq a,Num a) => Polynomial a -> [(a, Int)]
+terms = filter ((/=0) . fst) . flip zip [0..] . reverse . fromPolynomial
+
+-------------------------------------------------------------------
+-- Normal form, and list of power factors
+
+listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)]
+listOfPowerFactors pv v =
+   toView sumView >>> listView (powerFactorViewForWith pv v)
+
+-- Generalization
+polyForm :: (Eq a,Num a) => Bool -> View Expr a -> View Expr (String, Polynomial a)
+polyForm relaxed v = makeView f (uncurry g)
+ where
+   f e = do
+      pv <- selectVar e
+      xs <- match (listOfPowerFactors pv v) e
+      guard (relaxed || distinct (map snd xs))
+      return (pv, buildPairs xs)
+   g pv = build (listOfPowerFactors pv v) . reverse . terms
+
+polyNormalForm :: (Eq a,Num a) => View Expr a -> View Expr (String, Polynomial a)
+polyNormalForm = polyForm False
+
+-- relaxes the condition that all powers should be distinct
+polyRelaxedForm :: (Eq a,Num a) => View Expr a -> View Expr (String, Polynomial a)
+polyRelaxedForm = polyForm True
+
+-------------------------------------------------------------------
+-- Normal forms for equations
+
+-- Excludes equations such as 1==1 or 0==1
+linearEquationViewWith :: (Eq a,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 rationalApproxView
+
+quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational))
+quadraticEquationsView = makeView f (fmap g)
+ where
+   f = liftM (simplify orSetView . foldMap id)
+          . Data.Traversable.mapM (match quadraticEquationView)
+
+   g (x, a) = Var x :==: build (squareRootViewWith rationalApproxView) a
+
+quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational))
+quadraticEquationView = makeView f g
+ where
+   f (lhs :==: rhs) = do
+      (s, p) <- match (polyViewWith (squareRootViewWith rationalApproxView)) (lhs - rhs)
+      guard (degree p <= 2)
+      liftM (fmap ((,) s)) $
+         case fromPolynomial 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 $ singleton (-b/twoA)
+                  GT   -> return $ toOrList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA]
+            [a, b]     -> return $ singleton (-b/a)
+            [a] | a==0 -> return true
+            _          -> return false
+
+   g xs | isTrue xs = 0 :==: 0
+        | otherwise = build productView (False, map make (toList xs)) :==: 0
+    where
+      make (x, a) = Var x .-. build (squareRootViewWith rationalApproxView) a
+
+higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr)
+higherDegreeEquationsView = f <-> fmap (:==: 0)
+ where
+   f    = simplify orSetView . foldMap make . coverUpOrs
+   make = toOrList . filter (not . hasNegSqrt)
+        . map (cleanUpExpr . distr) . normHDE . sub
+   sub (a :==: b) = a-b
+
+   distr = transform g
+    where
+      g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c)
+      g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c)
+      g a = a
+
+hasNegSqrt :: Expr -> Bool
+hasNegSqrt (Sqrt a) =
+   case match rationalApproxView a of
+      Just r | r < 0 -> True
+      _ -> hasNegSqrt a
+hasNegSqrt (Sym s [a, b]) | isRootSymbol s =
+   case (match rationalApproxView a, match integerView b) of
+      (Just r, Just n) | r < 0 && even n -> True
+      _ -> hasNegSqrt a || hasNegSqrt b
+hasNegSqrt a =
+   any hasNegSqrt (children a)
+
+normHDE :: Expr -> [Expr]
+normHDE e =
+   case match (polyViewWith rationalApproxView) e of
+      Just (x, p)  -> normPolynomial x p
+      Nothing -> fromMaybe [e] $ do
+         (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalApproxView)) (e :==: 0)
+         return [ Var x .+. build (squareRootViewWith rationalApproxView) (-a) ]
+
+normPolynomial :: String -> Polynomial Rational -> [Expr]
+normPolynomial x p
+   | degree p == 0 =
+        []
+   | length (terms p) <= 1 =
+        [Var x]
+   | degree p == 1 =
+        [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)]
+   | degree p == 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 rationalApproxView))
+           [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)
+           , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)
+           ]
+   | otherwise =
+        case terms p of
+           [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 ->
+              let list = [(c, 0), (b, 1), (a, e2 `div` e1)]
+                  newp = sum (map (\(y, z) -> con y * (var Prelude.^ z)) list)
+                  sub  = map (substitute (x, Var x^fromIntegral e1))
+              in concatMap normHDE (sub (normPolynomial x newp))
+           [(c, 0), (a, n)]
+              | odd n  -> if c/a >= 0
+                          then [Var x + root (fromRational (c/a)) (fromIntegral n)]
+                          else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)]
+              | even n -> if c/a > 0
+                          then []
+                          else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n)
+                               , Var x - root (fromRational (abs (c/a))) (fromIntegral n)
+                               ]
+           _ ->
+              case factorize p of
+                 ps | length ps > 1 -> concatMap (normPolynomial x) ps
+                 _ -> [build (polyViewWith rationalApproxView) (x, p)]
+
+substitute :: (String, Expr) -> Expr -> Expr
+substitute (s, a) (Var b) | s==b = a
+substitute pair expr = descend (substitute pair) expr
+ src/Domain/Math/Power/Equation/Examples.hs view
@@ -0,0 +1,356 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Example exercises from the Digital Mathematics Environment (DWO),
+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Power.Equation.Examples
+   ( powerEquations, expEquations, logEquations, higherPowerEquations
+   , rootEquations, rootEquations2, rootSubstEquations, expEquations2
+   ) where
+
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Prelude hiding ((^))
+
+----------------------------------------------------------
+-- HAVO B applets
+
+-- Hoofdstuk 7, vergelijkingen met machten algebraisch (6)
+powerEquations :: [[Equation Expr]]
+powerEquations =
+  -- los vergelijkingen algebraisch op
+  let x = Var "x" in
+  [ [ x^14 :==: 25
+    , x^(-7) :==: 110
+    , 2*x^3.5 :==: 70
+    , 8*x^(-9.2) :==: 1000
+    ]
+  , [ root x 5 :==: 2.9
+    , 5 * root x 3 :==: 7
+    , root (x^3) 4 :==: 720
+    , root (x^2) 5 :==: 5.5
+    ]
+  , [ 4*x^(-12) :==: 28
+    , 7*x^5.1 + 16 :==: 100
+    , 8*x^(-1.9) - 5 :==: 2
+    , 0.8 * x^0.7 + 7 :==: 12.5
+    ]
+  , [ 4*root x 7 + 7 :==: 11.8
+    , 9*x^3.2+17 :==: 37
+    , 6*x^(-3.1)-9 :==: 12
+    , 0.7 * x^(-1.1) + 17 :==: 40
+    ]
+  ]
+
+-- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7)
+expEquations :: [[Equation Expr]]
+expEquations =
+  -- los exponentiele vergelijkingen algebraisch op
+  let x = Var "x" in
+  [ [ 2^x :==: 16 * sqrt 2
+    , 2^(x+2) :==: 1/4
+    , 3^(x-1) :==: 81
+    , 3^(x+5) :==: 243/sqrt 3
+    ]
+  , [ 5^(2-x) :==: 0.04
+    , 3^(2*x) :==: 1/9
+    , 3^(1-3*x) :==: 81
+    , 3^(3*x-2) :==: 3*sqrt 3
+    ]
+  , [ 5*2^(x-1) :==: 20*sqrt 2
+    , 6*5^(2-x) :==: 150
+    , 2*7^(4*x-1) :==: 98
+    , 8*3^(5-2*x) :==: 72*sqrt 3
+    ]
+  , [ 2^x-7 :==: 9
+    , 4^(3*x)+5 :==: 69
+    , 7*3^(2*x+1) :==: 189
+    , 5*2^(1-4*x)+11 :==: 51
+    ]
+  , [ 5^(x-4) :==: (1/5)^(2*x+1)
+    , 7^(1-2*x) :==: 1
+    , 4^(2*x-3) :==: 2*sqrt 2
+    , 2*9^(1-2*x) :==: 6*sqrt 3
+    ]
+  ]
+
+-- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8)
+logEquations :: [[Equation Expr]]
+logEquations =
+  -- los algebraisch op
+  let x = Var "x" in
+  [ [ logBase 2 x :==: 7
+    , logBase 3 (x-2) :==: 2
+    , logBase 4 (x-3) :==: 1+(1/2)
+    , logBase 5 ((1/10)*x-3) :==: -1
+    , logBase x 7 :==: 1
+    , logBase x 4 :==: -1
+    , logBase 2 (x^2-1) :==: 3
+    , logBase (1/3) (1-5*x) :==: -1
+    ]
+  ]
+
+----------------------------------------------------------
+-- VWO A/C applets
+
+-- Hoofdstuk 5, hogeremachtswortels (1)
+higherPowerEquations :: [[Equation Expr]]
+higherPowerEquations =
+  -- bereken exacte oplossing
+  let x = Var "x" in
+  [ [ 2*x^3+9 :==: 19
+    , 4*x^5-17 :==: 27
+    , 3*x^7+8 :==: 62
+    , 5*x^3-1 :==: 9
+    , 6-5*x^3 :==: 76
+    , 11-7*x^5 :==: 53
+    , 4-(1/5)*x^7 :==: 9
+    , 18-11*x^7 :==: 62
+    ]
+  , [ (1/2)*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
+    , (1/5)*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
+    ]
+    -- Geef in twee decimalen nauwkeurig
+  , [ 3*x^5+7 :==: 15
+    , 0.7 * x^4 - 1.3 :==: 2
+    , (1/3)*x^7 :==: 720
+    ]
+  ]
+
+-- Hoofdstuk 5, hogeremachtswortels (2)
+rootEquations :: [[Equation Expr]]
+rootEquations =
+  -- Bereken exacte oplossing
+  let x = Var "x" in
+  let y = Var "y" in
+  [ [ x^4 :==: 6
+    , root x 4 :==: 6
+    , sqrt x :==: 10
+    , root x 5 :==: 2
+    ]
+  , [ 3*x^5-1 :==: 20
+    , 3*root (x-1) 5 - 1 :==: 20
+    , (1/10)*sqrt x + 2 :==: 12
+    , (1/5)*x^7+8 :==: 26
+    ]
+  , [ 3*root x 4+2 :==: 14
+    , (1/2)*x^8-2 :==: 18
+    , 5-2*root x 3 :==: 3
+    ]
+  -- Maak x vrij
+  , [ y :==: x^5
+    , y :==: 2*x^5+4
+    , y :==: (1/10)*x^3-6
+    , y :==: root x 7
+    , y :==: 2*root x 3+8
+    , y :==: (1/10)*root x 5-6
+    ]
+  , [ y :==: 3*root x 7-6
+    , y :==: (1/4)*x^9-6
+    , y :==: 8+(1/2)*root x 3
+    ]
+  ]
+
+----------------------------------------------------------
+-- VWO B applets
+
+-- Hoofdstuk 1, wortelvergelijkingen
+rootEquations2 :: [[Equation Expr]]
+rootEquations2 =
+  let x = Var "x" in
+  -- los algebraisch op
+  [ [ 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
+    ]
+  ]
+
+-- Hoofdstuk 1, wortelvergelijkingen
+rootSubstEquations :: [[Equation Expr]]
+rootSubstEquations =
+  let x = Var "x" in
+  -- los algebraisch op
+  [ [ 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
+    ]
+  ]
+
+-- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a)
+expEquations2 :: [[Equation Expr]]
+expEquations2 =
+  let x = Var "x" in
+  -- los algebraisch op
+  -- 1
+  [ [ 2^(2*x-1) :==: 1/16
+    , 3^(1-x) :==: 81
+    , 5^(1-2*x) :==: 1/5
+    , (1/2)^(4*x-3) :==: 1/4
+    , (1/3)^(5*x+2) :==: 1/3
+    , 6^(3*x-2) :==: 1/216
+    ]
+  , [ 2^(3*x+2) :==: 2*sqrt 2
+    , 3^(2*x+1) :==: 9*sqrt 3
+    , 5^(4*x+3) :==: 625*sqrt 5
+    , (1/2)^(x+1) :==: 4
+    , (1/3)^(x-3) :==: 3
+    , 4^(x+2) :==: 64*root 4 3
+    ]
+  , [ 2^(x+3) :==: (1/2)*root 2 3
+    , 3^(4*x+1) :==: 27
+    , 5^(-x+2) :==: 1/25
+    , (1/2)^(1-x) :==: sqrt 2
+    , (1/3)^(x+1) :==: (1/9)*sqrt 3
+    , 2^(1-3*x) :==: (1/8)*sqrt 2
+    ]
+  , [ 3*2^x+1 :==: 25
+    , 4*3^x-9 :==: 27
+    , 2*5^x+4 :==: 14
+    , 5*(1/2)^x+11 :==: 51
+    , 8*(1/3)^x+27 :==: 99
+    , 3*(1/5)^x-35 :==: 40
+    ]
+  , [ 2^(4*x+3) :==: 1
+    , (1/2)^(2*x-1) :==: 1
+    , 3^(2*x+4) :==: 1
+    , (1/3)^(x-3) :==: 1
+    , 4^(4*x-7) :==: 1
+    , 5^(3*x-6) :==: 1
+    ]
+  -- 2
+  , [ 2^(2*x+1) :==: (1/2)^(x+2)
+    , 4^(2*x-1) :==: 2^(3*x+2)
+    , 2^(5*x-4) :==: 8^(x-3)
+    , (1/4)^(2*x+1) :==: 2^(6-2*x)
+    , (1/3)^(2*x-3) :==: 3^(4*x-3)
+    , 3^(3*x-2) :==: 9^(2-x)
+    , 27^(2*x+1) :==: 3^(2*x-5)
+    , 3^(5*x-1) :==: (1/9)^(2*x-1)
+    ]
+  , [ 6^(7*x-3) :==: 36^(2*x+3)
+    , (1/7)^(2*x-1) :==: 7^(2*x-7)
+    , 5^(5-2*x) :==: (1/5)^(x+2)
+    , 25^(4*x+1) :==: 5^(5*x-4)
+    , 3^(x^2) :==: (1/3)^(2*x)
+    , (1/2)^(x^2) :==: 2^(2*x)
+    , 5^(x^2) :==: 25^(3*x)
+    , 2^(x^2) :==: (1/8)^(-x)
+    ]
+  , [ (1/2)^(2-2*x) :==: 4^(3*x+5)
+    , 8^(x+1) :==: (1/2)^(x+7)
+    , (1/4)^(x+2) :==: 8^(2*x-1)
+    , 8^(2*x-3) :==: 16^(2*x+3)
+    , (1/3)^(x-2) :==: 9^(x+4)
+    , 9^(2*x-1) :==: 27^(2*x-1)
+    , (1/9)^(x+3) :==: 27^(2*x+2)
+    , 27^(3-2*x) :==: (1/3)^(4*x+3)
+    ]
+  , [ 4*2^x :==: 2^(3*x-2)
+    , 2^(5*x-9) :==: (1/8)*2^x
+    , 3^(4*x+6) :==: 27*3^x
+    , (1/9)*3^x :==: 3^(2-3*x)
+    , 3*3^x :==: (1/3)^(2*x+5)
+    , 4^(x+1) :==: 8*2^x
+    , (1/2)*2^x :==: (1/2)^x
+    , 9^(x+2) :==: (1/3)*3^x
+    ]
+  , [ (1/5)*5^(3*x-2) :==: 25^(x+1)
+    , 9*3^(2*x+1) :==: (1/3)^(4*x-3)
+    , 4^(3*x-5) :==: 8*2^(x+2)
+    , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4)
+    , 2^(x+2)+2^x :==: 40
+    , 2^(x+4) :==: 3/4+2^(x+2)
+    , 2^(x-2)+2^(x+1) :==: 9
+    , 2^(x+5)-2^(x+4) :==: 16
+    ]
+  -- 2a
+  , [ 3^(x+2) :==: 72+3^x
+    , 3^(x-1)+3^(x+1) :==: 10
+    , 3^(x+3)+3^(x+2) :==: 12
+    , 3^x-3^(x-1) :==: 54
+    ]
+  , [ 5^(x+1)+5^x :==: 150
+    , 5^(x+1) :==: 100+5^x
+    , 5^(x+2)+5^x :==:1+1/25
+    , 5^(x+1)+5^(x+2) :==: 30
+    ]
+  , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2
+    , 3^(x-1)+3^x :==: 12*sqrt 3
+    , 5^x-5^(x-1) :==: 4*sqrt 5
+    , 2^(x+2)+2^(x-3) :==: 66*sqrt 2
+    ]
+  ]
+ src/Domain/Math/Power/Equation/Exercises.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Equation.Exercises
+   ( powerEqExercise
+   , expEqExercise
+   , logEqExercise
+   , higherPowerEqExercise
+   , rootEqExercise
+   ) where
+
+import Prelude hiding ( (^) )
+
+import Data.Function (on)
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.Views
+import Domain.Math.Expr hiding (isPower)
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.Equation.Examples
+import Domain.Math.Power.Equation.NormViews
+import Domain.Math.Power.Equation.Strategies
+import Domain.Math.Power.Rules
+import Domain.Math.Power.Utils (sortOrList)
+import Ideas.Common.Library
+
+------------------------------------------------------------
+-- Exercises
+
+powerEqExercise :: Exercise (Relation Expr)
+powerEqExercise = let precision = 2 in makeExercise
+  { status         = Provisional
+  , parser         = parseRelExpr
+  , strategy       = powerEqApproxStrategy
+  , navigation     = termNavigator
+  , exerciseId     = describe "solve power equation algebraically with x > 0" $
+                       newId "algebra.manipulation.exponents.equation"
+  , examples       = level Medium $ concatMap (map $ build equationView) $
+                       powerEquations ++ [last higherPowerEquations]
+  , ready          = predicateView relationSolvedForm
+  , suitable       = predicateView (normPowerEqApproxView precision)
+  , equivalence    = withoutContext (viewEquivalent (normPowerEqApproxView precision))
+  }
+
+expEqExercise :: Exercise (Equation Expr)
+expEqExercise = makeExercise
+  { status         = Provisional
+  , parser         = parseEqExpr
+  , strategy       = expEqStrategy
+  , navigation     = termNavigator
+  , exerciseId     = describe "solve exponential equation algebraically" $
+                       newId "algebra.manipulation.exponential.equation"
+  , examples       = level Medium $ concat expEquations
+  , ready          = predicate $ \ rel -> isVariable (leftHandSide rel)
+                           && rightHandSide rel `belongsTo` rationalView
+  , suitable       = predicateView normExpEqView
+  , equivalence    = withoutContext (viewEquivalent normExpEqView)
+  , ruleOrdering   = ruleOrderingWithId [getId root2power]
+  }
+
+logEqExercise :: Exercise (OrList (Relation Expr))
+logEqExercise = makeExercise
+  { status         = Provisional
+  , parser         = parseOrsRelExpr
+  , strategy       = logEqStrategy
+  , navigation     = termNavigator
+  , exerciseId     = describe "solve logarithmic equation algebraically" $
+                       newId "algebra.manipulation.logarithmic.equation"
+  , examples       = level Medium $ map (singleton . build equationView) (concat logEquations)
+  , ready          = predicateView relationsSolvedForm
+  , suitable       = predicateView (traverseView equationView >>> normLogEqView)
+  , equivalence    = withoutContext (viewEquivalent (traverseView equationView >>> normLogEqView))
+  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
+  }
+
+higherPowerEqExercise :: Exercise (OrList (Equation Expr))
+higherPowerEqExercise = makeExercise
+  { status         = Provisional
+  , parser         = parseOrsEqExpr
+  , strategy       = higherPowerEqStrategy
+  , navigation     = termNavigator
+  , exerciseId     = describe "solve higher power equation algebraically" $
+                       newId "algebra.manipulation.exponents.equation"
+  , examples       = level Medium $ map singleton $ concat $
+                       higherPowerEquations ++ take 3 rootEquations
+  , ready          = predicateView relationsSolvedForm
+  , suitable       = predicateView (traverseView normPowerEqView)
+  , equivalence    = withoutContext (viewEquivalent (normPowerEqView' hasSomeVar >>> higherDegreeEquationsView))
+  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
+  }
+
+rootEqExercise :: Exercise (OrList (Equation Expr))
+rootEqExercise = makeExercise
+  { status         = Provisional
+  , parser         = parseOrsEqExpr
+  , strategy       = rootEqStrategy
+  , navigation     = termNavigator
+  , exerciseId     = describe "solve higher power equation algebraically" $
+                       newId "algebra.manipulation.exponents.equation"
+  , examples       = level Medium $ map singleton $ concat $ drop 3 rootEquations
+  , ready          = predicateView relationsSolvedForm
+  , suitable       = predicateView (traverseView normPowerEqView)
+  , equivalence    = withoutContext (on (==) (sortOrList . simplify (normPowerEqView' $ elem "x" . vars)))
+  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
+  }
+ src/Domain/Math/Power/Equation/NormViews.hs view
@@ -0,0 +1,204 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Equation.NormViews
+   ( normPowerEqApproxView, normExpEqView, normLogEqView
+   , normPowerEqView, normPowerEqView'
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Ratio
+import Domain.Math.Approximation
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.PrimeFactors
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Polynomial.Views
+import Domain.Math.Power.NormViews
+import Domain.Math.Power.Utils
+import Domain.Math.Power.Views
+import Domain.Math.Simplification hiding (simplify, simplifyWith)
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils.Uniplate
+import Ideas.Common.View
+import Prelude hiding ((^))
+import qualified Data.Traversable as T
+import qualified Prelude
+
+normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr)
+normPowerEqApproxView d = makeView f (uncurry (.~=.))
+   where
+     f rel = case relationType rel of
+      EqualTo       -> fmap (second (simplifyWith (precision d) doubleView))
+                     $ match (equationView >>> normPowerEqView) rel
+      Approximately -> return (leftHandSide rel, rightHandSide rel)
+      _             -> Nothing
+
+normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0!
+normPowerEqView = makeView f (uncurry (:==:))
+  where
+    f expr = do
+      -- selected var to the left, the rest to the right
+      (lhs :==: rhs) <- varLeft hasSomeVar expr >>= constRight hasSomeVar
+      -- match power
+      let simpl   = simplify normPowerView lhs
+          (c, ax) = fromMaybe (1, simpl) (match timesView simpl)
+          (a, x)  = fromMaybe (simpl, 1) $
+             match powerView ax
+           `mplus` do
+             (h, k) <- match rootView ax
+             return (h, 1 ./. k)
+      -- simplify, scale and take root
+      guard $ c /= 0 && x /= 0
+      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)
+      return (a, simplify rationalView y)
+
+normPowerEqView' :: (Expr -> Bool) -> View (OrList (Equation Expr)) (OrList (Equation Expr))
+normPowerEqView' isVar = makeView f id
+  where -- general clean up, write root as power, try to simplify powers
+    f = fmap ( fmap (fmap (cleanUpExpr . root2power . simplerPower))
+             . catOrList
+             )
+      . T.mapM takeRoot'   -- power to left and take root
+
+    root2power (Sym s [x, y])
+       | isRootSymbol s = x .^. (1 ./. y)
+    root2power expr = expr
+
+    takeRoot' expr = do
+      -- selected var to the left, the rest to the right
+      (lhs :==: rhs) <- varLeft isVar expr >>= constRight isVar
+      -- match power
+      (c, (a, x))    <- match unitPowerView lhs
+      -- simplify, scale and take root
+      let rhs' = simplify rationalView $ cleanUpExpr $ rhs ./. c
+      y <- maybe (Just [rhs' .^. (1 ./. x)]) (tr rhs') $ match integerView x
+      return $ toOrList $ map (a :==:) y
+
+tr :: Expr -> Integer -> Maybe [Expr]
+tr n x | odd x     = case n of
+                       Negate n' -> Just [neg (n' .^. (1 ./. x'))]
+                       _         -> Just [n .^. (1 ./. x')]
+       | otherwise = case n of
+                       Negate _ -> Nothing
+                       _        -> Just $ let e = n .^. (1 ./. x') in [e, neg e]
+  where x' = fromInteger x
+
+constRight :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
+constRight isVar (lhs :==: rhs) = do
+  (vs, cs) <- fmap (partition isVar) (match sumView lhs)
+  let rhs' = rhs .+. build sumView (map neg cs)
+  return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs'
+
+negateEq :: Equation Expr -> Equation Expr
+negateEq (lhs :==: rhs) =
+  case lhs of
+    Negate lhs' -> lhs' :==: neg rhs
+    _           -> lhs  :==: rhs
+
+varLeft :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
+varLeft isVar (lhs :==: rhs) = do
+  (vs, cs) <- fmap (partition isVar) (match sumView rhs)
+  return $ lhs .+. build sumView (map neg vs) :==: build sumView cs
+
+scaleLeft :: Equation Expr -> Maybe (Equation Expr)
+scaleLeft (lhs :==: rhs) =
+  match timesView lhs >>= \(c, x) -> return $
+    x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c)
+
+normExpEqView :: View (Equation Expr) (String, Rational)
+normExpEqView = makeView f id >>> linearEquationView
+  where
+    try g a = fromMaybe a $ g a
+    f e = do
+      let (l :==: r) = try scaleLeft $ try (constRight hasSomeVar) e
+      return $ case match powerView l of
+        Just (b, x) -> x :==: simplify normLogView (logBase b r)
+        Nothing     -> l :==: r
+
+normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr))
+normLogEqView = makeView (liftM g . T.mapM f) id
+  where
+    f expr@(lhs :==: rhs) = return $
+      case match logView lhs of
+        Just (b, x) -> x :==: b .^. rhs
+        Nothing     -> expr
+    g = simplify orSetView . fmap (fmap cleaner) . simplify (normPowerEqView' hasSomeVar)
+      . simplify higherDegreeEquationsView
+
+    -- Quick fix: 4^(3/2) should be simplified to sqrt (4^3), which is 8
+    cleaner = cleanUpExpr . transform h . cleanUpExpr
+    h expr@(Sym s [a, b]) | isPowerSymbol s =
+       case (match rationalView a, match rationalView b) of
+          (Just x, Just y) | denominator y /= 1 ->
+             root (fromRational (x Prelude.^ numerator y)) (fromInteger $ denominator y)
+          _ -> expr
+    h expr = expr
+
+normLogView :: View Expr Expr
+normLogView = makeView g id
+  where
+    g expr =
+      case expr of
+        Sym s [x, y]
+          | isLogSymbol s -> do
+              b <- match integerView x
+              let divExp (be, n) = return $ f be y ./. fromInteger n
+              maybe (Just $ f b y) divExp $ greatestPower b
+          | otherwise -> Nothing
+        _ -> Nothing
+    f b expr=
+      case expr of
+        Nat 1         -> 0
+        Nat n
+          | n == b    -> 1
+          | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) fromInteger
+                       $ lookup b (allPowers n)
+        e1 :*: e2 -> f b e1 .+. f b e2
+        e1 :/: e2 -> f b e1 .-. f b e2
+        Sqrt e    -> f b (e .^. (1 ./. 2))
+        Negate e  -> Negate $ f b e
+        Sym s [x,y]
+          | isPowerSymbol s -> y .*. f b x
+          | isRootSymbol  s -> f b (x .^. (1 ./. y))
+        _         -> expr
+
+simplerPower :: Expr -> Expr
+simplerPower expr =
+   case expr of
+     Sqrt x -> x ^ (1/2)
+     Sym s [x, y]
+       | isRootSymbol s  -> x ^ (1/y)
+       | isPowerSymbol s -> f x y
+     _ -> expr
+ where
+   f x y
+      | y == 0 = 1
+      | y == 1 = x
+      | x == 0 = 0
+      | otherwise = fromMaybe expr $
+           -- geheel getal
+           liftM fromRational (match rationalView expr)
+         `mplus` do
+           -- breuk
+           ry <- match rationalView y
+           rx <- match rationalView x
+           guard $ denominator rx == 1 && denominator ry /= 1
+           fmap fromInteger $
+              takeRoot (numerator rx Prelude.^ numerator ry) (denominator ry)
+         `mplus` do
+           -- (a/b)^y -> a^y/b^y
+           (a, b) <- match divView x
+           return $ build divView (a .^. y, b .^. y)
+ src/Domain/Math/Power/Equation/Rules.hs view
@@ -0,0 +1,136 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Equation.Rules
+  -- ( -- * Power equation rules
+  --   commonPower, nthRoot, sameBase, equalsOne, greatestPower
+  -- , approxPower, reciprocalFor, coverUpRootWith, coverUpRoot
+  -- )
+  where
+
+import Control.Monad
+import Data.Maybe
+import Ideas.Common.Library hiding (simplify)
+--import Data.List (partition)
+import Domain.Math.Approximation (precision)
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import qualified Domain.Math.Data.PrimeFactors as PF
+--import Domain.Math.CleanUp (collectLikeTerms)
+import Domain.Math.Polynomial.Rules (distributeTimes, distributeDivisionT)
+import Domain.Math.Power.Utils
+import Domain.Math.Power.Views
+import Domain.Math.Simplification (simplify)
+
+-- | Identifier prefix --------------------------------------------------------
+
+powereq :: String
+powereq = "algebra.manipulation.exponents.equation"
+
+-- | Power relation rules -----------------------------------------------------
+
+-- | a^x = b^y  =>  a^(x/c) = b^(y/c)  where c = gcd x y
+commonPower :: Rule (Equation Expr)
+commonPower = makeRule (powereq, "common-power") $ \expr -> do
+  let v = eqView (powerView >>> second integerView)
+  ((a, x), (b, y)) <- match v expr
+  let c = gcd x y
+  guard $ c > 1
+  return $ build v ((a, x `div` c), (b, y `div` c))
+
+-- | a^x = n  =>  a^x = b^e
+greatestPower :: Rule (Equation Expr)
+greatestPower = makeRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do
+  n      <- match integerView rhs
+  (_, x) <- match (powerView >>> second integerView) lhs
+  (b, e) <- PF.greatestPower n
+  guard $ gcd x e > 1
+  return $ lhs :==: fromInteger b .^. fromInteger e
+
+-- a^x = c*b^y  =>  a = c*b^(y/x)
+nthRoot :: Rule (Equation Expr)
+nthRoot = makeRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do
+  guard $ hasSomeVar lhs
+  (a, x)      <- match powerView lhs
+  (c, (b, y)) <- match unitPowerView rhs
+  return $ a :==: build unitPowerView (c, (b, simplify (y ./. x)))
+
+-- x = a^x  =>  x ~= d
+approxPower :: Rule (Relation Expr)
+approxPower = ruleTrans (powereq, "approx-power") $ approxPowerT 2
+
+-- x = a^x  =>  x ~= d
+approxPowerT :: Int -> Transformation (Relation Expr)
+approxPowerT n = makeTrans $ match equationView >=> f
+  where
+    f (Var x :==: d) =
+      match doubleView d >>= Just . (Var x .~=.) . fromDouble . precision n
+    f (d :==: Var x) =
+      match doubleView d >>= Just . (.~=. Var x) . fromDouble . precision n
+    f _              = Nothing
+
+-- a^x = a^y  =>  x = y
+sameBase :: Rule (Equation Expr)
+sameBase = makeRule (powereq, "same-base") $ \ expr -> do
+  ((a, x), (b, y)) <- match (eqView powerView) expr
+  guard $ a == b
+  return $ x :==: y
+
+-- | c*a^x = d*(1/a)^y  => c*a^x = d*a^-y
+reciprocalFor :: Rule (Equation Expr)
+reciprocalFor = makeRule (powereq, "reciprocal-for-base") $
+  \ (lhs :==: rhs) -> do
+    (_, (a,  _)) <- match unitPowerView lhs
+    (one, _)     <- match divView rhs
+    (d, (a'', y)) <- match consPowerView rhs
+    guard $ one == 1 && a'' == a
+    return $ lhs :==: d .*. a'' .^. negate y
+
+-- | a^x = 1  =>  x = 0
+equalsOne :: Rule (Equation Expr)
+equalsOne = makeRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do
+  guard $ rhs == 1
+  (_, x) <- match powerView lhs
+  return $ x :==: 0
+
+----------------------- Move these funcs to right place ----------------------
+
+-- add these two functions to coverUpRules?
+coverUpRootWith :: ConfigCoverUp -> Rule (Equation Expr)
+coverUpRootWith = coverUpBinaryRule "root" (isBinary rootSymbol) (.^.)
+
+coverUpRoot :: Rule (Equation Expr)
+coverUpRoot = coverUpRootWith configCoverUp
+
+-- | Negations are pushed inside
+myCoverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr)
+myCoverUpTimesWith = doAfter f . coverUpTimesWith
+ where
+   f (lhs :==: rhs) = lhs :==: g (applyD distributeTimes rhs)
+   g a              = fromMaybe a (distributeDivisionT a)
+
+-- flip condition
+condXisRight :: Equation Expr -> Bool
+condXisRight (lhs :==: rhs) = hasVar "x" rhs && withoutVar "x" lhs
+
+--xToLeft = makeRule (powereq, "x -to-left") $  toLeftRightT $ elem "x" . vars
+
+-- toLeftRightT :: (Expr -> Bool) -> Transformation (Equation Expr)
+-- toLeftRightT p = makeTrans $
+--   \ (lhs :==: rhs) -> do
+--     (xs, cs) <- fmap (partition p) (match sumView lhs)
+--     (ys, ds) <- fmap (partition p) (match sumView rhs)
+--     guard $ length cs > 0 || length ys > 0
+--     return $ fmap collectLikeTerms $
+--       build sumView (xs ++ map neg ys) :==: build sumView (ds ++ map neg cs)
+ src/Domain/Math/Power/Equation/Strategies.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Equation.Strategies
+   -- ( powerEqStrategy
+   -- , powerEqApproxStrategy
+   -- , expEqStrategy
+   -- , logEqStrategy
+   -- , higherPowerEqStrategy
+   -- )
+   where
+
+import Data.Maybe
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Rules
+import Domain.Math.Polynomial.Rules (flipEquation, conditionVarsRHS)
+import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy)
+import Domain.Math.Power.Equation.Rules
+import Domain.Math.Power.Rules
+import Domain.Math.Power.Utils
+import Ideas.Common.Library
+
+-- | Strategies ---------------------------------------------------------------
+
+powerEqStrategy :: IsTerm a => LabeledStrategy (Context a)
+powerEqStrategy = cleanUpStrategy clean strat
+  where
+    strat =  label "Power equation" $ repeatS
+          $  myCoverUpStrategy
+         <*> option (use greatestPower <*> use commonPower)
+         <*> use nthRoot
+         <*> remove (label "useApprox" $ try $ use approxPower)
+
+    clean = applyD $ exhaustiveUse rules
+    rules = onePower : fractionPlus : naturalRules ++ rationalRules
+
+powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr))
+powerEqApproxStrategy = label "Power equation with approximation" $
+  configureNow (configure cfg powerEqStrategy)
+    where
+      cfg = makeStrategyConfiguration [ (byName (newId "useApprox"), Reinsert) ]
+
+expEqStrategy :: LabeledStrategy (Context (Equation Expr))
+expEqStrategy = cleanUpStrategy cleanup strat
+  where
+    strat =  label "Exponential equation"
+          $  myCoverUpStrategy
+         <*> repeatS (somewhereNotInExp (use factorAsPower))
+         <*> repeatS (somewhereNotInExp (use reciprocal))
+         <*> powerS
+         <*> (use sameBase <|> use equalsOne)
+         <*> linearStrategy
+
+    cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules)
+            . applyTop (fmap (mergeConstantsWith isIntRatio))
+
+    isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v
+      where v = divView >>> first myIntegerView >>> second myIntegerView
+
+    powerS = exhaustiveUse [ root2power, addExponents, subExponents
+                           , mulExponents,  simpleAddExponents ]
+
+logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
+logEqStrategy = label "Logarithmic equation"
+              $  try (use logarithm)
+             <*> try (use (check conditionVarsRHS) <*> use flipEquation)
+             <*> repeatS (somewhere $  use nthRoot
+                                   <|> use calcPower
+                                    <|> use calcPowerPlus
+                                   <|> use calcPowerMinus
+                                   <|> use calcPlainRoot
+                                   <|> use calcPowerRatio)
+             <*> quadraticStrategy
+
+higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
+higherPowerEqStrategy =  cleanUpStrategy cleanup coverUpStrategy'
+  where
+    cleanup = applyTop $ fmap $ fmap cleanUpExpr
+
+rootEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
+rootEqStrategy =  cleanUpStrategy cleanup strat
+  where
+    strat =  label "Cover up"
+          $ try ( use (check condXisRight) <*> use flipEquation )
+         <*> exhaustiveSomewhere myCoverUpRulesOr
+    cleanup = applyTop $ fmap $ fmap cleanUpExpr
+
+-- | Help functions -----------------------------------------------------------
+
+myCoverUpStrategy :: IsTerm a => Strategy (Context a)
+myCoverUpStrategy = repeatS $ alternatives $ map use coverUpRules
+
+coverUpStrategy' :: LabeledStrategy (Context (OrList (Equation Expr)))
+coverUpStrategy' = cleanUpStrategy (applyTop $ fmap $ fmap cleanUpExpr) $
+   label "Cover-up" $
+   repeatS $ somewhere $ alternatives $ use coverUpRoot : coverUpRulesOr
+
+somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a)
+somewhereNotInExp = traverse [parentFilter f]
+  where
+    f a = if isPowC a then [0] else [0 .. arity a-1]
+    isPowC = maybe False (isJust . isPower) . currentTerm
+
+myConfigCoverUp :: ConfigCoverUp
+myConfigCoverUp = configCoverUp
+   { configName        = ""
+   , predicateCovered  = elem "x" . vars
+   , predicateCombined = notElem "x" . vars
+   , coverLHS          = True
+   , coverRHS          = True
+   }
+
+myCoverUpRulesOr :: IsTerm a => [Rule (Context a)]
+myCoverUpRulesOr = use (coverUpPowerWith myConfigCoverUp)
+                 : map (\f -> use $ f myConfigCoverUp) coverUpRulesWith
+
+coverUpRulesWith :: [ConfigCoverUp -> Rule (Equation Expr)]
+coverUpRulesWith =
+   [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith
+   , coverUpNegateWith, {-myCoverUpTimesWith-} coverUpTimesWith, coverUpNumeratorWith
+   , coverUpDenominatorWith, coverUpSqrtWith, coverUpRootWith
+   ]
+ src/Domain/Math/Power/Examples.hs view
@@ -0,0 +1,482 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- Example exercises from the Digital Mathematics Environment (DWO),
+-- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Power.Examples where
+
+import Domain.Math.Expr
+import Ideas.Common.Rewriting
+import Prelude hiding ((^))
+
+----------------------------------------------------------
+-- HAVO B, hfd 7 applets
+
+simplerPowers :: [[Expr]]
+simplerPowers = [level1, level2, level3, level4]
+ where
+   a = variable "a"
+   b = variable "b"
+   level1 =
+      [ 4*a^3 * 5*a^2
+      , 14*a^6 / (-2*a^3)
+      , -21*a^7 / (3*a)
+      , 5*a * (-3)*a^2 * 2*a^3
+      ]
+
+   level2 =
+      [ a^2 * (-2*a)^3
+      , (2*a)^5 / (-4*a)^2
+      , (2*a)^4 * (-3)*a^2
+      , (-3*a)^4 / (9*a^2)
+      ]
+
+   level3 =
+      [ (a^2 * b^3)^7
+      , -a^3 * (2*b)^5 * a^2
+      , 3*a * (-2*b)^3 * (-a*b)^2
+      , (2*a*b^3)^2 * (-3*a^2*b)^3
+      ]
+
+   level4 =
+      [ ((1/2)*a)^3 - (4*a)^2 * (1/4)*a
+      , (2*a)^5 + ((1/3)*a)^2 * (-3*a)^3
+      , (2*a^3)^4 - 6*a^3 * (-a^3)^3
+      , (-2*a^3)^2 - 6*(3*a)^2 * (-4*a^4)
+      ]
+
+powersOfA :: [[Expr]]
+powersOfA = [level1, level2, level3, level4]
+  where
+    a = variable "a"
+    level1 =
+      [ a^3 * a^(-4)
+      , a^4 * (1/a^2)
+      , a^(-1) * a^5
+      , (1/a^3) * a
+      ]
+
+    level2 =
+      [ (a^(-2))^3
+      , (a^(-3))^4
+      , (1/a^6) * a^(-2)
+      , (1/a^2) * (1/a^4)
+      ]
+
+    level3 =
+      [ (a^(-2))^3 * (1/a^4)
+      , (1/a^3)^2
+      , (a^3)^2 * (1/a)
+      , (a^(-2))^(-3) * a^(-4)
+      ]
+
+    level4 =
+      [ (a^(-1))^2 / a^3
+      , (a^2)^(-3) / a^(-1)
+      , ((a^(-2))^4 / (a^2)^3) * a
+      , (1/a^(-3))^4 * (1/a)^3
+      ]
+
+nonNegExp :: [[Expr]]
+nonNegExp = [level1, level2]
+  where
+    a = variable "a"
+    b = variable "b"
+    level1 =
+      [ a * b^(-2)
+      , a^(-1) * b^2
+      , a^(-2) * b^(-3)
+      , (1/a^(-3)) * (b^(-2))^2
+      ]
+
+    level2 =
+      [ (1/(a*b)^(-2)) * a * b^(-1)
+      , (2*a)^(-1) / (4*b)^(-2)
+      , (4*a*b)^(-1) * (b^2)^(-3)
+      , (5*a)^(-2) * 10*b^(-1)
+      ]
+
+-- schrijf als een macht van x
+powersOfX :: [[Expr]]
+powersOfX =
+   [ [root x 3, 1/root x 4, sqrt (1/x), (x^2) / root (x^2) 5]
+   , [sqrt x/(x^2), root (x/(x^3)) 3, x*root x 3, root x 3 * root (1/(x^2)) 4]
+   ]
+ where
+   x = Var "x"
+
+-- Schrijf zonder negatieve of gebroken exponenten
+nonNegExp2 :: [[Expr]]
+nonNegExp2 =
+   [ [ 4^(1/3), 5^(-(1/4)), 5*a^(1/2), 3*a^(-(1/4))]
+   , [ 4/(a^(-1)*b^(1/3)), a^(-1)/(8*b^(-(2/3)))
+     , 1/(3*a^(2/5)*b^(-1)), 3*a^(1/4)*b^(-(1/2))
+     ]
+   ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+----------------------------------------------------------
+-- VWO A/C applets, hfd 5
+
+-- herleid
+powers1 :: [[Expr]]
+powers1 =
+   [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7
+     , 2*a^4*5*a^3, 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a
+     ]
+   , [ 5*a^4*(1/a), 8*a^4*(1/2*a^2), 2*a^6*(6/a^4), a^2*(8/a)
+     , (4*a^3)/(a^5), a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3)
+     ]
+   , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3
+     , (-a^6)^5, (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4
+     ]
+   , [ 6*a^5+7*a^5-4*a^9, 8*a^2-4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2
+     , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7
+     , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3
+     ]
+   , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2
+     , 6*a^7*(2*a^4)^3, a^17/((a^3)^5), a^9/((a^3)^2)
+     , a^14/((a^2)^4), a^16/((a^5)^3)
+     ]
+   ]
+ where
+   a = Var "a"
+
+-- herleid
+powers2 :: [[Expr]]
+powers2 =
+   [ [ 4*a^3*5*a^2, (14*a^6)/(-2*a^3), (-21*a^7)/(3*a)
+     , 5*a*(-3*a^2)*(2*a^3)
+     ]
+   , [ a^2*(-2*a)^3, (2*a)^5/(-4*a)^2
+     , (2*a)^4*(-3*(a^2)), (-3*a)^4/(9*a^2)
+     ]
+   , [ (a^2*b^3)^7, (-a)^3*(2*b)^5*a^2
+     , 3*a*(-2*b)^3*(-a*b)^2, (2*a*b^3)^2*(-3*a^2*b)^3
+     ]
+   , [ (2*a^3)^4-6*a^3*(-a^3)^3, (-2*a^3)^2-6*(3*a)^2*(-4*a^4)
+     ]
+   ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+negExp1 :: [[Expr]]
+negExp1 =
+   [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5
+     , (1/a^3)/a, a/a^7, (1/a^2)/a
+     ]
+   , [ (1/(a^4))/a^6, (1/(a^3))/a^5, (1/a^5)/a^2, 1/(a^4)/a^3
+     , 1/a^3, 1/a^5, 1/a^(-4), 1/a^(-6)
+     ]
+   , [ a^8/(1/a^2), a^4/(1/a^4), (a^6)/(1/a^5), a^3/(1/a^6)
+     , 1/(a^3)/a^(-2), (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8)
+     ]
+   ]
+ where
+   a = Var "a"
+
+negExp2 :: [[Expr]]
+negExp2 =
+   [ [ a^3*a^(-4), a^4*(1/a^2), a^(-1)*a^5, (1/a^3)*a]
+   , [ (a^(-2))^3,(a^(-3))^4, (1/a^6)*a^(-2), (1/a^2)*(1/a^4)]
+   , [ (a^(-2))^3*(1/a^4), (1/a^3)^2, (a^3)^2*(1/a), (a^(-2))^(-3)*a^(-4)]
+   , [ (a^(-1))^2/a^3, (a^2)^(-3)/a^(-1), ((a^(-2))^4/(a^2)^3)*a
+     , (1/a^(-3))^4*(1/a)^3
+     ]
+   ]
+ where
+   a = Var "a"
+
+negExp3 :: [[Expr]]
+negExp3 =
+   [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5)
+     , (1/4)^(-3), (1/7)^(-2), (1/2)^(-4), (1/3)^(-4)
+     ]
+   , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1)
+     , 5*3^(-2), 7*2^(-5), 6*5^(-2), 4*7^(-2)
+     ]
+   , [ (1/3)/(6^(-2)), (1/2)/(8^(-2)), (1/8)/4^(-2), (1/10)/5^(-2) -- original in negExp5
+     , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3)
+     ]
+   ]
+
+negExp4 :: [[Expr]]
+negExp4 =
+   [ [ a*b^(-2), a^(-1)*b^2, a^(-2)*b^(-3), (1/a^(-3))*(b^(-2))^2]
+   , [ (1/((a*b)^(-2)))*a*b^(-1), (2*a)^(-1)/(4*b)^(-2)
+     , (4*a*b)^(-1)*(b^2)^(-3), (5*a)^(-2) * 10*b^(-1)
+     ]
+   ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+negExp5 :: [[Expr]]
+negExp5 =
+   [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3)
+     , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3)
+     ]
+   , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7)
+     , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2)
+     ]
+   , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5)
+     , 9*a^(-7)*(2*b)^(-4), (a^5) / ((2*b)^(-2)), ((2*a)^(-3))/b^2
+     , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4)
+     ]
+   ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+brokenExp1, brokenExp1' :: [[Expr]]
+brokenExp1 =
+  [ [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5)
+    , 4*a^(2/3), 2*a^(3/4), 3*a^(2/5), 4*a^(3/5)
+    ]
+  , [ 6*a^(-(1/2)), 4*a^(-(1/3)), 2*(3*a)^(-(1/4)), (3*a)^(-(1/5))
+    , 5*a^(-(2/3)), 7*a^(-(3/4)), 6*a^(-(2/5)), 2*a^(-(3/7))
+    ]
+  , [ (1/2)*a^(1/3)*b^(-(1/2)), (1/7)*a^(-(1/4))*b^(2/3), 4*a^(1/2)*b^(-(1/5))
+    , 3*a^(-(3/5))*b^(1/3), (2*a)^(-(2/3)), (6*a)^(-(2/5))
+    , (3*a)^(-(3/5)), (2*a)^(-(4/7))
+    ]
+  ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+brokenExp1' =
+  [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7
+    , a*root (a^2) 3, a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6
+    ]
+  , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3)
+    , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3)
+    ]
+  ]
+ where
+   a = Var "a"
+
+brokenExp2 :: [[Expr]]
+brokenExp2 =
+   [ [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5
+     , sqrt (a^6), root (a^6) 3, sqrt (a^4), root (a^9) 3
+     ]
+   , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a/(1/a^2)
+     , root a 3/(1/a^5), (a^2*sqrt a)/(a*root a 3)
+     , (a^3*sqrt a)/(a^2*root (a^2) 3), (a^2*root a 5)/(a^3*root a 3)
+     , (a^4*root a 3)/(a^6*sqrt a)
+     ]
+   ]
+ where
+   a = Var "a"
+
+brokenExp3 :: [[Expr]]
+brokenExp3 =
+   [ [root x 3, 1/root x 4, sqrt (1/x), x^2/root (x^2) 5]
+   , [sqrt x/x^2, root (x/x^3) 3, x*root x 3, root x 3*root (1/x^2) 4]
+   ]
+ where
+   x = Var "x"
+
+----------------------------------------------------------
+-- VWO B applets (hoofdstuk 4)
+
+-- herleiden van wortelvormen
+normSqrt1 :: [[Expr]]
+normSqrt1 =
+   [ [ 9*sqrt 5 * 7*sqrt 3, 3*sqrt 2 * 2 * sqrt 5, 5*sqrt 2*6*sqrt 7
+     , 4*sqrt 6 * 2*sqrt 7, 6*a*sqrt 3*9*sqrt 2, 5*sqrt 5 * 2 * a * sqrt 7
+     , a*sqrt 6 * 7 * sqrt 5, 8*sqrt 7*a*sqrt 3
+     ]
+   , [ sqrt 15/(6*sqrt 3), (5*sqrt 30)/sqrt 5, (4*sqrt 10)/(5*sqrt 2)
+     , (5*sqrt 21)/(2*sqrt 7), (6*a*sqrt 35)/(3*sqrt 5), (5*a*sqrt 14)/(9*sqrt 2)
+     , (a*sqrt 6)/(7*sqrt 3), (3*a*sqrt 42)/(7*sqrt 7)
+     ]
+   , [ 5/(2*sqrt 2), 2/(5*sqrt 3), 3/(2*sqrt 5), 8/(7*sqrt 6), (2*a)/(3*sqrt 7)
+     , (6*a)/(7*sqrt 10), (5*a)/(3*sqrt 11), (6*a)/(5*sqrt 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)*sqrt 2)^2, ((1/2)*sqrt 3)^2, ((2/7)*sqrt 5)^2, ((2/3)*sqrt 7)^2
+     ]
+   ]
+ where
+   a = Var "a"
+
+normSqrt2 :: [[Expr]]
+normSqrt2 =
+   [ [ ((1/7)*a*sqrt 2)^2, ((3/5)*a*sqrt 3)^2, ((1/3)*a*sqrt 5)^2
+     , ((4/7)*a*sqrt 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
+     ]
+   ]
+ where
+   a = Var "a"
+
+normSqrt3 :: [[Expr]]
+normSqrt3 =
+   [ [ (2*sqrt 7 + 7*sqrt 3)^2, (sqrt 2+6*sqrt 3)^2, (4*sqrt 3 + 3*sqrt 2)^2
+     , (2*sqrt 5 + sqrt 7)^2, (3*sqrt 6-4*sqrt 5)^2, (5*sqrt 3 - sqrt 2)^2
+     , (4*sqrt 6 - 2*sqrt 7)^2, (sqrt 5 - 2*sqrt 3)^2
+     ]
+   , [ (2*sqrt 3 - 2)^2, (5*sqrt 2-1)^2, (3+4*sqrt 3)^2, (2+3*sqrt 6)^2
+     , (4*sqrt 2 + 3)*(4*sqrt 2 - 3), (sqrt 7+sqrt 3)*(sqrt 7-sqrt 3)
+     , (2*sqrt 2 - sqrt 5)*(2*sqrt 2 + sqrt 5), (6-3*sqrt 3)*(6+3*sqrt 3)
+     ]
+   , [ (a-sqrt 3)^2, (2*sqrt 6+a)^2, (2*a+a*sqrt 5)^2, (a*sqrt 3 - 2*a*sqrt 2)^2
+     , (a-sqrt 7)*(a+sqrt 7), (3*a+2*sqrt 3)*(3*a-2*sqrt 3)
+     , (2*a+a*sqrt 2)*(2*a-a*sqrt 2), (3*a*sqrt 5 - a)*(3*a*sqrt 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*sqrt 3 + sqrt 6), 5/(3*sqrt 2 - sqrt 3)
+     , 2 / (sqrt 11 - sqrt 2)
+     ]
+   , [ (2*sqrt 3)/(sqrt 5 + sqrt 2), (6*sqrt 5)/(sqrt 7+sqrt 3)
+     , (4*sqrt 3)/(sqrt 5 - sqrt 3), (8*sqrt 7)/(sqrt 6 - sqrt 5)
+     ]
+   ]
+ where
+   a = Var "a"
+
+-- Machten herleiden
+normPower1 :: [[Expr]]
+normPower1 =
+  [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7, 2*a^4*5*a^3
+    , 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a
+    ]
+  , [ 5*a^4*(1/a), 8*a^4*(1/(2*a^2)), 2*a^6*(6/a^4), a^2*8/a
+    , (4*a^3)/a^5, a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3)
+    ]
+  , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3, (-(a^6))^5
+    , (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4
+    ]
+  , [ 6*a^5 + 7*a^5 - 4*a^9, 8*a^2 - 4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2
+    , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7
+    , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3
+    ]
+  , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2, 6*a^7*(2*a^4)^3
+    , a^17/(a^3)^5, a^9/(a^3)^2, a^14/(a^2)^4, a^16/(a^5)^3
+    ]
+  ]
+ where
+   a = Var "a"
+
+normPower2 :: [[Expr]]
+normPower2 =
+  [ -- one level only
+    [ (3*a)^3+4*a^3, (2*a^2)^3 +(4*a^3)^2, (-2*a^6)^2+(a^2)^6
+    , (-3*a^2)^3+(4*a^3)^2, (4*a*b^2)^2, (2*a^2*b^3)^3
+    , (3*a^2*b)^2, (-3*a^2*b^2)^4
+    ]
+  ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+normPower3, normPower3' :: [[Expr]]
+normPower3 =
+  [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5, (1/a^3)/a, a/a^7, (1/a^2)/a
+    ]
+  , [ (1/a^4)/a^6, (1/a^3)/a^5, (1/a^5)/a^2, (1/a^4)/a^3, 1/a^3, 1/a^5
+    , 1/a^(-4), 1/a^(-6)
+    ]
+  , [ a^8/(1/a^2), a^4/(1/a^4), a^6/(1/a^5), a^3/(1/a^6), (1/a^3)/a^(-2)
+    , (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8)
+    ]
+  ]
+ where
+   a = Var "a"
+normPower3' = -- bereken zonder rekenmachine
+  [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5), (1/4)^(-3), (1/7)^(-2)
+    , (1/2)^(-4), (1/3)^(-4)
+    ]
+  , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1), 5*3^(-2), 7*2^(-5)
+    , 6*5^(-2), 4*7^(-2)
+    ]
+  ]
+
+normPower4, normPower4' :: [[Expr]]
+normPower4 =
+  [  -- bereken zonder rekenmachine
+    [ (1/3)/6^(-2), (1/2)/8^(-2), (1/8)/4^(-2), (1/10)/5^(-2)
+    , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3)
+    ]
+  ]
+normPower4' =    -- schrijf zonder negatieve exponenten
+  [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3)
+    , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3)
+    ]
+  , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7)
+    , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2)
+    ]
+  , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5)
+    , 9*a^(-7)*(2*b)^(-4), a^5/(2*b)^(-2), (2*a)^(-3)/b^2
+    , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4)
+    ]
+  ]
+ where
+   a = Var "a"
+   b = Var "b"
+
+normPower5, normPower5' :: [[Expr]]
+normPower5 =
+  [ -- schrijf zonder negatieve en gebroken exponent
+    [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5), (4*a)^(2/3)
+    , 2*a^(3/4), (3*a)^(2/5), 4*a^(3/5)
+    ]
+  , [ 6*a^(-1/2), 4*a^(-1/3), 2*(3*a)^(-1/4), (3*a)^(-1/5), 5*a^(-2/3)
+    , 7*a^(-3/4), 6*a^(-2/5), 2*a^(-3/7)
+    ]
+  , [ (1/2)*a^(1/3)*b^(-1/2), (1/7)*a^(-1/4)*b^(2/3), 4*a^(1/2)*b^(-1/5)
+    , 3*a^(-3/5)*b^(1/3), (2*a)^(-2/3), (6*a)^(-2/5), (3*a)^(-3/5), (2*a)^(-4/7)
+    ]
+  ]
+ where
+   a = Var "a"
+   b = Var "b"
+normPower5' =    -- schrijf als macht van a
+  [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7, a*root (a^2) 3
+    , a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6
+    ]
+  , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3)
+    , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3)
+    ]
+  ]
+ where
+   a = Var "a"
+
+normPower6 :: [[Expr]]
+normPower6 =
+  [ -- schrijf als macht van a
+    [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5, sqrt (a^6)
+    , root (a^6) 3, sqrt (a^4), root (a^9) 3
+    ]
+  , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a / (1/a^2), root a 3/(1/a^5)
+    , (a^2*sqrt a)/(a*root a 3), (a^3*sqrt a)/(a^2*root (a^2) 3)
+    , (a^2*root a 5)/(a^3*root a 3), (a^4*root a 3)/(a^6*sqrt a)
+    ]
+  ]
+ where
+   a = Var "a"
+ src/Domain/Math/Power/Exercises.hs view
@@ -0,0 +1,159 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Exercises
+   ( -- * Power exercises
+     simplifyPowerExercise
+   , powerOfExercise
+   , nonNegBrokenExpExercise
+   , calcPowerExercise
+   ) where
+
+import Prelude hiding ( (^) )
+
+import Domain.Math.Expr hiding (isPower)
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Examples
+import Domain.Math.Power.NormViews
+import Domain.Math.Power.Rules
+import Domain.Math.Power.Strategies
+import Domain.Math.Power.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils (distinct)
+
+-- Exercises
+
+powerExercise :: Exercise Expr
+powerExercise = makeExercise
+   { status        = Provisional
+   , parser        = parseExpr
+   , navigation    = navigator
+   }
+
+-- | Simplify an expression containing powers as far as possible. This
+-- exercise supports the following DWO-applets:
+--
+--  * HAVO B, hoofdstuk 7, activiteit 1
+--
+--  * VWO A/C, hoofdstuk 5, activiteit 3 t/m 6
+--
+--  * VWO B, hoofdstuk 4, activiteit 8, 9, part of 10
+simplifyPowerExercise :: Exercise Expr
+simplifyPowerExercise = powerExercise
+   { exerciseId   = describe "simplify expression (powers)" $
+                       newId "algebra.manipulation.exponents.simplify"
+   , strategy     = simplifyPowerStrategy
+   , ready        = predicate isPowerAdd
+   , suitable     = predicateView normPowerMapView
+   , equivalence  = withoutContext (viewEquivalent normPowerMapView)
+   , examples     = level Medium $ concat $
+                              simplerPowers
+                           ++ powers1 ++ powers2
+                           ++ negExp1 ++ negExp2
+                           ++ normPower1 ++ normPower2 ++ normPower3
+   , ruleOrdering = ruleOrderingWithId $ map getId
+                      [ root2power, subExponents, reciprocalVar, addExponents
+                      , mulExponents, distributePower ]
+   }
+
+-- | The @powerOfExercise@ is more strict than the 'simplifyPowerExercise'.
+-- It only allows one variable experssions. This exercise supports the
+-- following DWO-applets:
+--
+--  * HAVO B, hoofdstuk 7, activiteit 2 and 4
+--
+--  * VWO A/C, hoofdstuk 5, activiteit part of 10 and 11 and 12
+--
+--  * VWO B, hoofdstuk 4, activiteit 12 partly, and 13
+powerOfExercise :: Exercise Expr
+powerOfExercise = powerExercise
+   { exerciseId   = describe "write as a power of a" $
+                       newId "algebra.manipulation.exponents.powerof"
+   , ready        = predicate isSimplePower
+   , strategy     = simplifyPowerStrategy
+   , suitable     = predicateView normPowerView
+   , equivalence  = withoutContext (viewEquivalent normPowerNonNegRatio)
+   , examples     = level Medium $ concat $  powersOfA ++ powersOfX
+                           ++ brokenExp1' ++ brokenExp2 ++ brokenExp3
+                           ++ normPower5' ++ normPower6
+   , ruleOrdering = ruleOrderingWithId $ map getId
+                      [ root2power, addExponents, subExponents, mulExponents
+                      ,  distributePower, reciprocalVar ]
+   }
+
+-- | Rewrite power expressions so that they have any negative or broken
+-- exponents. Supported DWO-applets:
+--
+--  * HAVO B, hoofdstuk 7, activiteit 3 and 5
+--
+--  * VWO A/C, hoofdstuk 5, activiteit 8,9  and part of 10
+--
+--  * VWO B, hoofdstuk 4, activiteit 11 partly, and 12 partly
+nonNegBrokenExpExercise :: Exercise Expr
+nonNegBrokenExpExercise = powerExercise
+   { exerciseId   = describe "write with a non-negative exponent" $
+                       newId "algebra.manipulation.exponents.nonnegative"
+   , strategy     = nonNegBrokenExpStrategy
+   , ready        = predicate (isPower plainNatView)
+   , suitable     = predicateView normPowerNonNegDouble
+   , equivalence  = withoutContext (viewEquivalent normPowerNonNegDouble)
+   , examples     = level Medium $ concat $  nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5
+                           ++ brokenExp1
+                           ++ normPower4' ++ normPower5
+   , ruleOrdering = ruleOrderingWithId [ getId mulExponents
+                                       , getId reciprocalFrac
+                                       , getId reciprocalInv
+                                       , getId power2root
+                                       , getId distributePower ]
+   }
+
+-- | Calculate the integer number for the given power expression. Supported
+-- DWO-applets:
+--
+--  * VWO A/C, hoofdstuk 5, activiteit 7
+--
+--  * VWO B, hoofdstuk 4, activiteit 10 partly, 11 partly
+calcPowerExercise :: Exercise Expr
+calcPowerExercise = powerExercise
+   { exerciseId   = describe "simplify expression (powers)" $
+                       newId "arithmetic.exponents"
+   , strategy     = calcPowerStrategy
+   , ready        = predicate isPowerAdd
+   , suitable     = predicateView normPowerMapView
+   , equivalence  = withoutContext (viewEquivalent normPowerMapView)
+   , examples     = level Medium $ concat $ negExp3 ++ normPower3' ++ normPower4
+   }
+
+-- Ready checks
+
+isSimplePower :: Expr -> Bool
+isSimplePower (Sym s [Var _, y])
+                 | isPowerSymbol s = y `belongsTo` rationalView
+isSimplePower _ = False
+
+isPower :: View Expr a -> Expr -> Bool
+isPower v expr =
+  let xs = snd (from productView expr)
+      f (Nat 1 :/: a) = g a
+      f a = g a
+      g (Sym s [Var _, a]) | isPowerSymbol s = a `belongsTo` v
+      g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x
+      g (Sqrt x) = g x
+      g (Var _) = True
+      g a = a `belongsTo` rationalView
+  in distinct (concatMap vars xs) && all f xs
+
+isPowerAdd :: Expr -> Bool
+isPowerAdd expr =
+  let xs = from sumView expr
+  in all (isPower rationalView) xs && not (applicable calcPowerPlus expr)
+ src/Domain/Math/Power/NormViews.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.NormViews
+   ( -- * Normalising views
+     normPowerView, normPowerMapView, normPowerNonNegRatio
+   , normPowerNonNegDouble
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Utils
+import Ideas.Common.View
+import Prelude hiding ((^), recip)
+import qualified Data.Map as M
+import qualified Prelude
+
+type PowerMap = (M.Map String Rational, Rational)
+
+normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational)
+normPowerNonNegRatio = makeView (liftM swap . f) (g . swap)
+  where
+    f expr =
+        case expr of
+           Sym s [a,b]
+              | isPowerSymbol s -> do
+                   (r, m) <- f a
+                   if r==1
+                     then do
+                       r2 <- match rationalView b
+                       return (1, M.map (*r2) m)
+                     else do
+                       n <- match integerView b
+                       return $ if n >=0
+                         then (r Prelude.^ n, M.map (*fromIntegral n) m)
+                         else (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m)
+              | isRootSymbol s ->
+                  f (Sym powerSymbol [a, 1/b])
+           Sqrt a ->
+              f (Sym rootSymbol [a,2])
+           a :*: b -> do
+             (r1, m1) <- f a
+             (r2, m2) <- f b
+             return (r1*r2, M.unionWith (+) m1 m2)
+           a :/: b -> do
+             (r1, m1) <- f a
+             (r2, m2) <- f b
+             guard (r2 /= 0)
+             return (r1/r2, M.unionWith (+) m1 (M.map negate m2))
+           Var s -> return (1, M.singleton s 1)
+           Nat n -> return (toRational n, M.empty)
+           Negate x -> do
+             (r, m) <- f x
+             return (negate r, m)
+           _ -> do
+             r <- match rationalView expr
+             return (fromRational r, M.empty)
+    g (r, m) =
+       let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]
+       in build productView (False, fromRational r : xs)
+
+-- | AG: todo: change double to norm view for rationals
+normPowerNonNegDouble :: View Expr (Double, M.Map String Rational)
+normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g
+  where
+    roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m)
+    f expr =
+      case expr of
+        Sym s [a,b]
+          | isPowerSymbol s -> do
+            (x, m) <- f a
+            y      <- match rationalView b
+            return (x ** fromRational y, M.map (*y) m)
+          | isRootSymbol s -> f (Sym powerSymbol [a, 1/b])
+        Sqrt a -> f (Sym rootSymbol [a,2])
+        a :*: b -> do
+          (r1, m1) <- f a
+          (r2, m2) <- f b
+          return (r1*r2, M.unionWith (+) m1 m2)
+        a :/: b -> do
+          (r1, m1) <- f a
+          (r2, m2) <- f b
+          guard (r2 /= 0)
+          return (r1/r2, M.unionWith (+) m1 (M.map negate m2))
+        Var s -> return (1, M.singleton s 1)
+        Negate x -> do
+          (r, m) <- f x
+          return (negate r, m)
+        _ -> do
+          d <- match doubleView expr
+          return (d, M.empty)
+    g (r, m) =
+      let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]
+      in build productView (False, fromDouble r : xs)
+
+normPowerMapView :: View Expr [PowerMap]
+normPowerMapView = makeView (liftM h . f) g
+  where
+    f = (mapM (match normPowerNonNegRatio) =<<) . match sumView
+    g = build sumView . map (build normPowerNonNegRatio)
+    h :: [PowerMap] -> [PowerMap]
+    h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy ((==) `on` fst) . sort
+
+normPowerView :: View Expr (String, Rational)
+normPowerView = makeView f g
+ where
+   f expr =
+        case expr of
+           Sym s [x,y]
+              | isPowerSymbol s -> do
+                   (s2, r) <- f x
+                   r2 <- match rationalView y
+                   return (s2, r*r2)
+              | isRootSymbol s ->
+                   f (x^(1/y))
+           Sqrt x ->
+              f (Sym rootSymbol [x, 2])
+           Var s -> return (s, 1)
+           x :*: y -> do
+             (s1, r1) <- f x
+             (s2, r2) <- f y
+             guard (s1==s2)
+             return (s1, r1+r2)
+           Nat 1 :/: y -> do
+             (s, r) <- f y
+             return (s, -r)
+           x :/: y -> do
+             (s1, r1) <- f x
+             (s2, r2) <- f y
+             guard (s1==s2)
+             return (s1, r1-r2)
+           _ -> Nothing
+
+   g (s, r) = Var s .^. fromRational r
+ src/Domain/Math/Power/OldViews.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.OldViews
+   ( powerFactorView, powerFactorViewForWith, powerFactorViewWith
+   ) where
+
+import Control.Monad
+import Domain.Math.Expr hiding ( (^) )
+import Ideas.Common.Rewriting
+import Ideas.Common.View
+
+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]
+            | isPowerSymbol s -> do
+                 (a1, b1) <- f e1
+                 a <- match v (build v a1 ^ toInteger n)
+                 return (a, b1 * fromInteger n)
+         _ -> do
+            guard (withoutVar pv expr)
+            a <- match v expr
+            return (a, 0)
+
+   g (a, b) = build v a .*. (Var pv .^. fromIntegral b)
+ src/Domain/Math/Power/Rules.hs view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Rules
+  ( -- * Power rules
+    calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents
+  , subExponents, distributePower, distributePowerDiv, reciprocal
+  , reciprocalInv, reciprocalFrac, calcPowerRatio, simplifyPower
+  , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar
+  , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents
+    -- * Root rules
+  , power2root, root2power
+    -- * Log rules
+  , logarithm
+    -- * Common rules
+  , myFractionTimes, pushNegOut
+  ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.Power.Utils
+import Domain.Math.Power.Views
+import Ideas.Common.Library hiding (root)
+import Prelude hiding ( (^) )
+import qualified Domain.Math.Data.PrimeFactors as PF
+import qualified Prelude
+
+-- Identifier prefixes ------------------------------------------------------
+
+power, logarithmic :: String
+power       = "algebra.manipulation.exponents"
+logarithmic = "algebra.manipulation.logarithmic"
+
+-- Power rules --------------------------------------------------------------
+
+-- | n  =>  a^e  (with e /= 1)
+factorAsPower :: Rule Expr
+factorAsPower = ruleList (power, "factor-as-power") $ \ expr -> do
+  n      <- matchM myIntegerView expr
+  (a, x) <- PF.allPowers $ toInteger n
+  if n > 0
+    then return $ fromInteger a .^. fromInteger x
+    else if odd x
+      then return $ fromInteger (negate a) .^. fromInteger x
+      else fail "Could not factorise number."
+
+-- | Calculate power, e.g., 2^2 => 4
+calcPower :: Rule Expr
+calcPower = makeRule "arithmetic.operation.rational.power" $ \ expr -> do
+  (a, x) <- match (powerViewWith rationalView plainNatView) expr
+  return $ fromRational $ a Prelude.^ x
+
+-- | a^(x/y) => (a^x)^(1/y)
+calcPowerRatio :: Rule Expr
+calcPowerRatio = makeRule (power, "power-ratio") $ \ expr -> do
+  let v = powerView >>> second (rationalView >>> plainRationalView)
+  (a, (x, y)) <- match v expr
+  guard $ x /= 1 && y /= 1
+  return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y)
+
+-- | root n x
+calcPlainRoot :: Rule Expr
+calcPlainRoot = makeRule (power, "root") $ \expr -> do
+   (n, x) <- matchM (rootView >>> (integerView *** integerView)) expr
+   fmap fromInteger (takeRoot n x)
+
+-- | [root n x, ... ]
+-- BHR: not used. Better to turn this into OrList (Relation Expr)
+{-
+calcRoot :: Rule (OrList Expr)
+calcRoot = makeRule (power, "root") $
+   oneDisjunct $ \expr -> do
+      (n, x) <- match (rootView >>> (integerView *** integerView)) expr
+      y      <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x)
+      let ys | x > 0 && even n = [y, negate y]
+             | x > 0 && odd  n = [y]
+             | x < 0 && odd  n = [negate y]
+             | otherwise       = []
+      roots  <- toMaybe (not. null) ys
+      return $ toOrList roots
+-}
+
+calcPowerPlus :: Rule Expr
+calcPowerPlus =
+  makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus
+
+calcPowerMinus :: Rule Expr
+calcPowerMinus =
+   makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus
+
+addExponents :: Rule Expr
+addExponents = ruleList (power, "add-exponents") $ \ expr -> do
+  (sign, fs)     <- matchM (powerFactorView isPow) expr
+  ((x, y), fill) <- twoNonAdjacentHoles fs
+  prod           <- applyM simpleAddExponents $ x * y
+  return $ build productView (sign, fill prod)
+
+isPow :: Expr -> Expr -> Bool
+isPow x y = x `belongsTo` myIntegerView &&
+             (y `belongsTo` variableView || y `belongsTo` powerView)
+
+-- | a*x^y * b*x^q = a*b * x^(y+q)
+simpleAddExponents :: Rule Expr
+simpleAddExponents = makeRule (power, "simple-add-exponents") $ \expr -> do
+  (e1, e2)     <- match timesView expr
+  (a, (x,  y)) <- match unitPowerView e1
+  (b, (x', q)) <- match unitPowerView e2
+  guard $ x == x'
+  return $ build unitPowerView (a .*. b, (x, y .+. q))
+
+-- | a*x^y / b*x^q = a/b * x^(y-q)
+subExponents :: Rule Expr
+subExponents = makeRule (power, "sub-exponents") $ \ expr -> do
+  (e1, e2)     <- match divView expr
+  (a, (x,  y)) <- match unitPowerView e1
+  (b, (x', q)) <- match unitPowerView e2
+  guard $ x == x'
+  return $ build unitPowerView (a ./. b, (x, y .-. q))
+
+-- | (a^x)^y = a^(x*y)
+mulExponents :: Rule Expr
+mulExponents = makeRule (power, "mul-exponents") $ \ expr -> do
+  ((a, x), y) <- match (strictPowerView >>> first powerView) expr
+  return $ build powerView (a, x .*. y)
+
+-- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x
+distributePower :: Rule Expr
+distributePower = makeRule (power, "distr-power") $ \ expr -> do
+  ((sign, as), x) <- match (powerViewWith (toView productView) identity) expr
+  guard $ length as > 1
+  let y = build productView (False, map (\a -> build powerView (a, x)) as)
+  return $
+    maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x
+
+-- | (a/b)^y = (a^y / b^y)
+distributePowerDiv :: Rule Expr
+distributePowerDiv = makeRule (power, "distr-power-div") $ \ expr -> do
+  ((a, b), y) <- match (powerViewWith divView identity) expr
+  return $ build divView (build powerView (a, y), build powerView (b, y))
+
+-- | a^0 = 1
+zeroPower :: Rule Expr
+zeroPower = makeRule (power, "power-zero") $ \ expr -> do
+  (_, x) <- match powerView expr
+  guard $ x == 0
+  return 1
+
+-- a ^ 1 = a
+onePower :: Rule Expr
+onePower = makeRule (power, "power-one") $ \ expr -> do
+  (a, x) <- match powerView expr
+  guard $ x == 1
+  return a
+
+-- 1 ^ x = 1
+powerOne :: Rule Expr
+powerOne = makeRule (power, "one-power") $ \ expr -> do
+  (a, _) <- match powerView expr
+  guard $ a == 1
+  return a
+
+-- 0 ^ x = 0 with x > 0
+powerZero :: Rule Expr
+powerZero = makeRule (power, "one-power") $ \ expr -> do
+  (a, x) <- match (powerViewWith identity integerView) expr
+  guard $ x > 0 && a == 0
+  return 0
+
+-- | all of the above simplification rules
+simplifyPower :: Rule Expr
+simplifyPower = ruleList (power, "simplify") $ \ expr ->
+  mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero]
+
+-- | e/a = e*a^(-1)  where a is an variable
+reciprocalVar :: Rule Expr
+reciprocalVar = makeRule (power, "reciprocal-var") $ \ expr -> do
+  (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr
+  return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c
+
+-- | c/a^x = c*a^x^(-1)
+reciprocalPower :: Rule Expr
+reciprocalPower = makeRule (power, "reciprocal-power") $ \ expr -> do
+  (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr
+  return $ (e .*. build consPowerView (1, (a, neg x))) ./. c
+
+-- | Use with care, will match any fraction!
+reciprocal :: Rule Expr
+reciprocal = makeRule (power, "reciprocal") $ \expr -> do
+  (a, b) <- match divView expr
+  return $ a .*. build powerView (b, -1)
+
+-- | a^x = 1/a^(-x)
+reciprocalInv ::  Rule Expr
+reciprocalInv = makeRule (power, "reciprocal-inverse") $ \ expr -> do
+  guard $ hasNegExp expr
+  (a, x) <- match strictPowerView expr
+  return $ 1 ./. build strictPowerView (a, neg x)
+
+-- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r...
+reciprocalFrac :: Rule Expr
+reciprocalFrac = makeRule (power, "reciprocal-frac") $ \ expr -> do
+  (e1, e2) <- match divView expr
+  (s, xs)  <- match productView e2
+  let (ys, zs) = partition hasNegExp xs
+  guard (not $ null ys)
+  return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs)
+    where
+      f e = case match consPowerView e of
+              Just (c, (a, x)) -> build consPowerView (c, (a, neg x))
+              Nothing          -> e
+
+-- | a^x / b^x = (a/b)^x
+divBase :: Rule Expr
+divBase = describe "divide base of root" $
+  makeRule (power, "divide-base") $ \ expr -> do
+  (e1, e2)      <- match divView expr
+  (c1, (a, x))  <- match consPowerView e1
+  (c2, (b, x')) <- match consPowerView e2
+  guard $ x == x' && b /= 0
+  return $ build consPowerView (c1 .*. c2, (a ./. b, x))
+
+-- | (-a)^x = -(a^x)
+pushNegOut :: Rule Expr
+pushNegOut = makeRule (power, "push-negation-out") $ \ expr -> do
+  (a, x) <- match (powerViewWith identity integerView) expr
+  a'     <- isNegate a
+  return $ (if odd x then neg else id) $ build powerView (a', fromInteger x)
+
+-- | Root rules ----------------------------------------------------------------
+
+-- | a^(p/q) = root (a^p) q
+power2root :: Rule Expr
+power2root = makeRule (power, "write-as-root") $ \ expr -> do
+  (a, (p, q)) <- match (strictPowerView >>> second divView) expr
+  guard $ q /= 1
+  return $ root (a .^. p) q
+
+-- | root a q = a^(1/q)
+root2power :: Rule Expr
+root2power = makeRule (power, "write-as-power") $ \ expr -> do
+  (a, q) <- match strictRootView expr
+  return $ a .^. (1 ./. q)
+
+-- | Logarithmic relation rules -----------------------------------------------
+
+logarithm :: Rule (Equation Expr)
+logarithm = makeRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do
+    (b, x) <- match logView lhs
+    return $ x :==: build powerView (b, rhs)
+
+-- | Common rules --------------------------------------------------------------
+
+-- | a/b * c/d = a*c / b*d  (b or d may be one)
+myFractionTimes :: Rule Expr
+myFractionTimes = smartRule $ makeRule (power, "fraction-times") $ \ expr -> do
+  (e1, e2) <- match timesView expr
+  guard $ e1 `belongsTo` divView || e2 `belongsTo` divView
+  let f e    = fromMaybe (e, 1) (match divView e)
+      (a, b) = f e1
+      (c, d) = f e2
+  return $ build divView (a .*. c, b .*. d)
+
+-- | Help functions -----------------------------------------------------------
+
+calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr
+calcBinPowerRule opName op m =
+  makeRule (power, "calc-power", opName) $ \e -> do
+    (e1, e2)     <- m e
+    (c1, (a, x)) <- match unitPowerViewVar e1
+    (c2, (b, y)) <- match unitPowerViewVar e2
+    guard $ a == b && x == y
+    return $ build unitPowerViewVar (op c1 c2, (a, x))
+
+-- use twoNonAdHoles instead of split ???
+makeCommutative :: IsView f => f Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr
+makeCommutative view op r =
+  ruleList (getId r) $ \ expr ->
+    case match view expr of
+      Just factors -> do
+        (e, es) <- split op factors
+        case apply r e of
+          Just e' -> return $ build view (e' : es)
+          Nothing -> []
+      Nothing -> []
+
+hasNegExp :: Expr -> Bool
+hasNegExp = maybe False ((< 0) . snd . snd) . match consPowerView
+ src/Domain/Math/Power/Strategies.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Strategies
+   ( -- * Power strategies
+     simplifyPowerStrategy
+   , calcPowerStrategy
+   , nonNegBrokenExpStrategy
+   ) where
+
+import Domain.Math.Expr
+import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator)
+import Domain.Math.Power.Rules
+import Domain.Math.Power.Utils
+import Domain.Math.Simplification
+import Ideas.Common.Library hiding (simplifyWith)
+
+-- Strategies ---------------------------------------------------------------
+
+-- | Simplify an expression containing powers as far as possible
+simplifyPowerStrategy :: LabeledStrategy (Context Expr)
+simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules
+
+nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr)
+nonNegBrokenExpStrategy = cleanUpStrategy (changeInContext cleanup . applyTop cleanup) $
+   label "Write with non-negative exponent" $ exhaustiveStrategy rs
+  where
+    rs = [ addExponents, subExponents, mulExponents, reciprocalInv
+         , distributePower, distributePowerDiv, power2root, zeroPower
+         , calcPowerPlus, calcPowerMinus
+         ]
+    cleanup = applyD divisionNumerator
+            . applyD myFractionTimes
+            . mergeConstants
+            . simplifyWith simplifyConfig {withMergeAlike = False}
+
+calcPowerStrategy :: LabeledStrategy (Context Expr)
+calcPowerStrategy = cleanUpStrategy cleanup $
+   label "Calculate power" $ exhaustiveStrategy rules
+  where
+    rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules
+    cleanup = applyTop (applyD myFractionTimes)
+            . applyD (exhaustiveStrategy $ myFractionTimes : naturalRules)
+
+-- Rule collections ---------------------------------------------------------
+
+powerRules :: [Rule Expr]
+powerRules =
+  [ addExponents, subExponents, mulExponents, distributePower, zeroPower
+  , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus
+  , pushNegOut
+  ]
+
+-- | Help functions -----------------------------------------------------------
+
+cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr)
+cleanUpStrategyRules l =
+  cleanUpStrategy (changeInContext cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy
+
+cleanUp :: Expr -> Expr
+cleanUp = mergeConstants
+        . simplifyWith simplifyConfig {withMergeAlike = False}
+ src/Domain/Math/Power/Utils.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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)
+--
+-- some of these help functions may have a broader scope and could be
+-- moved to other parts of the framework (eg. Common)
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Power.Utils where
+
+import Data.Foldable (toList)
+import Data.Function (on)
+import Data.List
+import Data.Ratio
+import Domain.Math.CleanUp
+import Domain.Math.Data.OrList
+import Domain.Math.Data.Relation
+import Domain.Math.Equation.CoverUpRules
+import Domain.Math.Expr
+import Domain.Math.Numeric.Rules
+import Domain.Math.Numeric.Views
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate
+
+-- | Strategy functions -------------------------------------------------------
+
+exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a)
+exhaustiveStrategy = exhaustiveSomewhere . map liftToContext
+
+exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b)
+exhaustiveUse = exhaustiveSomewhere . map use
+
+exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a)
+exhaustiveSomewhere = repeatS . somewhere . alternatives
+
+-- | Rule functions -----------------------------------------------------------
+
+smartRule :: Rule Expr -> Rule Expr
+smartRule = doAfter f
+  where
+    f (a :*: b) = a .*. b
+    f (a :/: b) = a ./. b
+    f (Negate a) = neg a
+    f (a :+: b) = a .+. b
+    f (a :-: b) = a .-. b
+    f e = e
+
+mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr
+mergeConstantsWith p = simplifyWith f productView
+  where
+    f (sign, xs) =
+      let (cs, ys) = partition p xs
+          c = simplify rationalView $ build productView (False, cs)
+      in if maybe False (> 1) (match rationalView c)
+           then (sign, c:ys)
+           else (sign, xs)
+
+mergeConstants :: Expr -> Expr
+mergeConstants = mergeConstantsWith (`belongsTo` rationalView)
+
+-- | View functions -----------------------------------------------------------
+
+plainNatView :: View Expr Integer
+plainNatView = makeView f Nat
+  where
+    f (Nat n) = Just n
+    f _       = Nothing
+
+myIntegerView :: View Expr Integer
+myIntegerView = makeView f fromInteger
+  where
+    f (Nat n)          = Just n
+    f (Negate (Nat n)) = Just $ negate n
+    f _                = Nothing
+
+plainRationalView :: View Rational (Integer, Integer)
+plainRationalView =
+  makeView (\x -> return (numerator x, denominator x)) (uncurry (%))
+
+eqView :: View a b -> View (Equation a) (b, b)
+eqView v = eqv >>> v *** v
+  where
+    eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:))
+
+relationView :: View (Equation a) (Relation a)
+relationView = makeView f g
+ where
+   f (x :==: y) = return $ x .==. y
+   g r | relationType r == EqualTo = leftHandSide r :==: rightHandSide r
+       | otherwise                 = error "Not an equality"
+
+-- | Rule collections ---------------------------------------------------------
+
+naturalRules :: [Rule Expr]
+naturalRules =
+   [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView
+   , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView
+   , doubleNegate, negateZero , plusNegateLeft, plusNegateRight
+--   , minusNegateLeft
+   , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft
+   , divisionNegateRight
+   ]
+
+rationalRules :: [Rule Expr]
+rationalRules =
+   [ calcPlusWith "rational" rationalRelaxedForm
+   , calcMinusWith "rational" rationalRelaxedForm
+   , calcTimesWith "rational" rationalRelaxedForm
+   , calcDivisionWith "integer" integerNF
+   , doubleNegate, negateZero, divisionDenominator, divisionNumerator
+   , simplerFraction
+   ]
+
+coverUpRulesX :: [Rule (Equation Expr)]
+coverUpRulesX = map (\r -> r cfg)
+   [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith, coverUpNegateWith
+   , coverUpTimesWith, coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
+   ]
+   where
+     cfg = configCoverUp { predicateCovered = elem "x" . vars
+                         , predicateCombined = notElem "x" . vars
+                         , coverLHS = False}
+
+-- | Common functions ---------------------------------------------------------
+
+sortExpr :: Expr -> Expr
+sortExpr = transform $ simplifyWith (sort . map sortProd) sumView
+  where sortProd = simplifyWith (fmap sort) productView
+
+sortEquation :: Equation Expr -> Equation Expr
+sortEquation (x :==: y) = if x < y then eq else flipSides eq
+  where eq = sortExpr x :==: sortExpr y
+
+sortOrList :: OrList (Equation Expr) -> OrList (Equation Expr)
+sortOrList = toOrList . sort . map sortEquation . toList
+
+-- Semantic equivalence
+class SemEq a where
+    (===), (=/=) :: a -> a -> Bool
+    x =/= y = not (x === y)
+--    x === y = not (x =/= y)
+
+infix 4 ===, =/=
+
+instance SemEq a => SemEq (Equation a) where
+  (a :==: b) === (c :==: d) = a === c && b === d || a === d && b === c
+
+instance SemEq Expr where
+  (===) = on (==) cleanUpExpr
+
+instance SemEq a => SemEq (OrList a) where
+  a === b = let as = toList a ; bs = toList b
+            in length (intersectBy (===) as bs) == length as
+
+-- y = root n x
+takeRoot :: Integer -> Integer -> Maybe Integer
+takeRoot n x
+   | n >= 0 && x >0 && a Prelude.^ x == n = Just a
+   | otherwise = Nothing
+ where
+   a = round (fromInteger n ** (1/fromInteger x) :: Double)
+{-
+| n == 0    = [0]
+             | n == 1    = if x > 0 && odd x then [1] else [1, -1]
+             | n == (-1) = [-1 | x > 0 && odd x]
+             | x == 1    = [n]
+             | x > 0     = maybe [] roots $ lookup x $ map swap $ PF.allPowers (abs n)
+             | otherwise = []
+  where
+    roots r | n > 0 && even x = [r, negate r]
+            | n > 0 && odd  x = [r]
+            | n < 0 && odd  x = [negate r]
+            | otherwise       = [] -}
+
+-- prop_takeRoot n = traceShow n f
+--   where
+--     f n x | x > 0 = n `elem` (takeRoot (n Prelude.^ x) x)
+--           | otherwise = True
+
+swap :: (a, b) -> (b, a)
+swap (a, b) = (b, a)
+
+split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])]
+split op xs = f xs
+      where
+        f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys
+                 | otherwise     = []
+        f [] = []
+
+toMaybe :: (a -> Bool) -> a -> Maybe a
+toMaybe p x = if p x then Just x else Nothing
+
+joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]]
+joinBy _  [] = []
+joinBy eq xs = ys : joinBy eq (xs \\ ys)
+  where
+    ys = dropUntil eq xs
+
+dropUntil :: (a -> a -> Bool) -> [a] -> [a]
+dropUntil _ []       = []
+dropUntil _ [x]      = [x]
+dropUntil p (x:y:ys) | p x y     = x : dropUntil p (y:ys)
+                     | otherwise = [x]
+
+holes :: [a] -> [(a, [a], a -> [a])]
+holes xs = map f [0 .. length xs - 1]
+  where
+    f i = let (ys, z:zs) = splitAt i xs
+          in (z, ys ++ zs, \x -> ys ++ x:zs)
+
+twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])]
+twoNonAdjacentHoles xs = concatMap g pairs
+  where
+    pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]]
+    g (x, y) = let (ys, z:zs) = splitAt x xs
+                   (ps, q:qs) = splitAt (y - x - 1) zs
+               in if null ps
+                 then [ ((z, q), \a -> ys ++ a:ps ++ qs) ]
+                 else [ ((z, q), \a -> ys ++ a:ps ++ qs)
+                      , ((z, q), \a -> ys ++ ps ++ a:qs) ]
+ src/Domain/Math/Power/Views.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Math.Power.Views
+   ( -- * Power views
+     -- ** Simple power views
+     powerView, powerViewWith, powerViewFor, powerFactorView
+     -- ** Views for power expressions with a constant factor
+   , consPowerView
+     -- ** Power views that allow constants
+   , unitPowerView, unitPowerViewVar, strictPowerView
+     -- Root views
+   , rootView, strictRootView
+     -- * Log view
+   , logView
+     -- * Other views
+   , plainNatView, plainRationalView
+   ) where
+
+import Control.Monad
+import Domain.Math.Expr
+import Domain.Math.Power.Utils
+import Ideas.Common.Library hiding (root)
+
+-- Power views with constant factor -----------------------------------------
+
+consPowerView :: View Expr (Expr, (Expr, Expr))
+consPowerView = makeView f g
+ where
+   f (Negate a) = fmap (first Negate) (f a)
+   f (a :*: b)  = fmap ((,) a) (match powerView b)
+   f expr       = f (1 :*: expr)
+   g = build (timesView >>> second powerView)
+
+unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr))
+unitPowerViewWith v = makeView f g
+ where
+   mv = powerViewWith v identity
+   f (Negate a) = fmap (first Negate) (f a)
+   f (a :*: b)  = do
+         x <- match mv b
+         return (a, x)
+       `mplus` do
+         x <- match v b
+         return (a, (x, 1))
+   f expr = f (1 :*: expr)
+   g = build (timesView >>> second mv)
+
+unitPowerViewVar :: View Expr (Expr, (String, Expr))
+unitPowerViewVar = unitPowerViewWith variableView
+
+-- | Careful! This view will match anything, so use it wise and with care.
+unitPowerView :: View Expr (Expr, (Expr, Expr))
+unitPowerView = unitPowerViewWith identity
+
+-- | A root view
+rootView :: View Expr (Expr, Expr)
+rootView = makeView f (uncurry root)
+  where
+    f expr = do
+      (a, (x, y)) <- match (powerView >>> second divView) expr
+      guard (x `elem` [1, -1])
+      return $ if x == 1 then (a, y) else (a, negate y)
+
+-- | only matches sqrt and root
+strictRootView :: View Expr (Expr, Expr)
+strictRootView = makeView f g
+  where
+    f expr =
+      case expr of
+        Sym s [a, b] | isRootSymbol s -> return (a, b)
+        Sqrt e                       -> return (e, 2)
+        _ -> Nothing
+
+    g (a, b) = if b == 2 then Sqrt a else root a b
+
+-- Power views --------------------------------------------------------------
+
+strictPowerView :: View Expr (Expr, Expr)
+strictPowerView = makeView f (uncurry (.^.))
+  where
+    f expr =
+      case expr of
+        Sym s [a, b] | isPowerSymbol s -> return (a, b)
+        _ -> Nothing
+
+powerView :: View Expr (Expr, Expr)
+powerView = matcherView f g
+  where
+    f = matcher (strictRootView >>> second (arr (1 ./.)))
+        <+> matcher strictPowerView
+    g (a, b) =
+       case b of
+         (Nat 1 :/: b') -> build strictRootView (a, b')
+         _              -> build strictPowerView (a, b)
+
+powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b)
+powerViewWith va vb = powerView >>> (va *** vb)
+
+powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b
+powerViewForWith va vb a = makeView f ((build va a .^.) .  build vb)
+  where
+    f expr = do
+      (a', b) <- match (powerViewWith va vb) expr
+      guard $ a == a'
+      return b
+
+powerViewFor :: Expr -> View Expr Expr
+powerViewFor = powerViewForWith identity identity
+
+powerFactorView :: (Expr -> Expr -> Bool) -> Isomorphism Expr (Bool, [Expr])
+powerFactorView p = productView >>> second (f <-> id)
+  where
+    f = map (build productView . (,) False) . joinBy p
+
+-- Log views ----------------------------------------------------------------
+
+logView :: View Expr (Expr, Expr)
+logView = makeView f (uncurry logBase)
+  where
+    f expr = case expr of
+        Sym s [a, b] | isLogSymbol s -> return (a, b)
+        _ -> Nothing
+ src/Domain/Math/Safe.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Safe
+   ( -- * Safe division
+     SafeDiv(..), safeDivFractional
+   , -- * Safe power and root
+     SafePower(..)
+   ) where
+
+import Control.Monad
+import Data.Ratio
+
+-------------------------------------------------------------------
+-- Safe division
+
+class Num a => SafeDiv a where
+   safeDiv   :: a -> a -> Maybe a
+   safeRecip :: a -> Maybe a
+   -- default definitions
+   safeRecip = safeDiv 1
+
+instance SafeDiv Integer where
+   safeDiv x y
+      | y /= 0 && m == 0 = Just d
+      | otherwise        = Nothing
+    where (d, m) = x `divMod` y
+
+instance SafeDiv Double where
+   safeDiv = safeDivFractional
+
+instance Integral a => SafeDiv (Ratio a) where
+   safeDiv = safeDivFractional
+
+safeDivFractional :: (Eq a,Fractional a) => a -> a -> Maybe a
+safeDivFractional x y
+   | y /= 0    = Just (x / y)
+   | otherwise = Nothing
+
+-------------------------------------------------------------------
+-- Safe power and root
+
+class Num a => SafePower a where
+   safePower :: a -> a -> Maybe a
+   safeSqrt  :: a -> Maybe a
+   safeRoot  :: a -> a -> Maybe a
+   -- default definitions
+   safeSqrt = (`safeRoot` 2)
+
+instance SafePower Integer where
+   safeRoot x y =
+      case fmap round (safeRoot (fromInteger x :: Double) (fromInteger y)) of
+         Just a | safePower a y == Just x -> Just a
+         _ -> Nothing
+   safePower x y
+      | y >= 0    = Just (x ^ y)
+      | otherwise = Nothing
+
+instance Integral a => SafePower (Ratio a) where
+   safeRoot x y = do
+      let n = toInteger (numerator y)
+      guard (denominator y == 1)
+      a <- safeRoot (toInteger (numerator x)) n
+      b <- safeRoot (toInteger (denominator x)) n
+      safeDiv (fromInteger a) (fromInteger b)
+   safePower x y
+      | denominator y /= 1 = Nothing
+      | numerator y >= 0   = Just a
+      | otherwise          = Just (1/a)
+    where
+      a = x ^ abs (numerator y)
+
+instance SafePower Double where
+   safePower x y
+      | x==0 && y<0 = Nothing
+      | otherwise   = Just (x**y)
+   safeRoot x y
+      | x >= 0 && y >= 1 = Just (x ** (1/y))
+      | otherwise        = Nothing
+ src/Domain/Math/Simplification.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, 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(..), SimplifyConfig(..)
+   , simplifyConfig
+   , Simplified, simplified, liftS, liftS2
+   , simplifyRule
+   , collectLikeTerms, mergeAlike, distribution, constantFolding
+   , mergeAlikeSum, mergeAlikeProduct
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Typeable
+import Domain.Math.CleanUp (smart)
+import Domain.Math.Data.Relation
+import Domain.Math.Expr
+import Domain.Math.Numeric.Views
+import Domain.Math.SquareRoot.Views
+import Ideas.Common.Library hiding (simplify, simplifyWith)
+import Ideas.Common.Utils.Uniplate
+import qualified Ideas.Common.View as View
+
+data SimplifyConfig = SimplifyConfig
+  { withSmartConstructors  :: Bool
+  , withMergeAlike         :: Bool
+  , withDistribution       :: Bool
+  , withSimplifySquareRoot :: Bool
+  , withConstantFolding    :: Bool
+  }
+
+class Simplify a where
+   simplifyWith :: SimplifyConfig -> a -> a
+   simplify :: a -> a
+   simplify = simplifyWith simplifyConfig
+
+simplifyConfig :: SimplifyConfig
+simplifyConfig = SimplifyConfig True True True True True
+
+instance Simplify a => Simplify (Context a) where
+   simplifyWith cfg = changeInContext $ simplifyWith cfg
+
+instance Simplify a => Simplify (Equation a) where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify a => Simplify (Relation a) where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify a => Simplify [a] where
+   simplifyWith cfg = fmap $ simplifyWith cfg
+
+instance Simplify Expr where
+   simplifyWith cfg = let optional p f = if p then f else id in
+       optional (withSmartConstructors cfg)  (transform smart)
+     . optional (withMergeAlike cfg)         mergeAlike
+     . optional (withDistribution cfg)       distribution
+     . optional (withSimplifySquareRoot cfg) (View.simplify
+                                               (squareRootViewWith rationalView))
+     . optional (withConstantFolding cfg)    constantFolding
+
+instance Simplify a => Simplify (Rule a) where
+   simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards
+
+data Simplified a = S a deriving (Eq, Ord, Typeable)
+
+instance Show a => Show (Simplified a) where
+   show (S x) = show x
+
+instance (Read a, Simplify a) => Read (Simplified a) where
+   readsPrec n = map (mapFirst simplified) . readsPrec n
+
+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 a, IsTerm a) => IsTerm (Simplified a) where
+   toTerm (S x) = toTerm x
+   fromTerm     = liftM simplified . fromTerm
+
+instance (Reference a, Simplify a) => Reference (Simplified a)
+
+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 "simplify")
+
+-------------------------------------------------------------
+-- Distribution of constants
+
+distribution :: Expr -> Expr
+distribution = descend distribution . f
+ where
+  f expr =
+   fromMaybe expr $
+   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 -> descend constantFolding expr
+
+----------------------------------------------------------------------
+-- merge alike for sums and products
+
+-- Todo: combine with mergeAlike (subtle differences)
+collectLikeTerms :: Expr -> Expr
+collectLikeTerms = View.simplifyWith f sumView
+ where
+   f = mergeAlikeSum . map (View.simplifyWith (second mergeAlikeProduct) productView)
+
+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):ys) = e:rec ys
+   rec ((Just (r, a), e):ys) = new:rec rest
+    where
+      (js, rest) = partition (maybe False ((==a) . snd) . fst) ys
+      rs  = r:map fst (mapMaybe fst js)
+      new | null js   = e
+          | otherwise = build rationalView (sum rs) .*. a
+ src/Domain/Math/SquareRoot/Tests.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Tests (tests) where
+
+import Domain.Math.Data.SquareRoot
+import Ideas.Common.Algebra.Field
+import Ideas.Common.Algebra.FieldLaws
+import Ideas.Common.Algebra.GroupLaws
+import Ideas.Common.Algebra.Law
+import Ideas.Common.Utils.TestSuite
+
+-------------------------------------------------------------------
+-- Testing
+
+tests :: TestSuite
+tests = mapM_ f $ commutativeRingLaws ++
+                  distributiveSubtractionLaws ++
+                  map fromAdditiveLaw appendInverseLaws
+ where
+   f :: Law (SafeNum (SquareRoot Rational)) -> TestSuite
+   f p = addProperty (show p) p
+ src/Domain/Math/SquareRoot/Views.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Domain.Math.Data.SquareRoot
+import Domain.Math.Expr hiding ((^))
+import Domain.Math.Numeric.Views
+import Domain.Math.Safe
+import Ideas.Common.View
+
+squareRootView :: View Expr (SquareRoot Expr)
+squareRootView = squareRootViewWith identity
+
+squareRootViewWith :: (Eq a,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 safeDiv (f a) (f b)
+         Sqrt a   -> fmap sqrtRational (match rationalView a)
+         Sym s [a, b] | isPowerSymbol s ->
+            liftM2 power (f a) (match integerView b)
+         _ -> fmap con (match v expr)
+
+   power a n
+      | n >= 0    = a ^ n
+      | otherwise = 1 / (a ^ abs n)
+
+   g = to sumView . map h . toList
+   h (a, n)
+      | n == 0    = 0
+      | n == 1    = build v a
+      | otherwise = build v a .*. Sqrt (fromIntegral n)
+ src/Domain/RelationAlgebra.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Export) where
+
+import Domain.RelationAlgebra.Exercises as Export
+import Domain.RelationAlgebra.Formula as Export
+import Domain.RelationAlgebra.Generator as Export
+import Domain.RelationAlgebra.Parser as Export
+import Domain.RelationAlgebra.Rules as Export
+import Domain.RelationAlgebra.Strategies as Export
+-- import Domain.RelationAlgebra.Equivalence
+
+{-
+import Control.Monad
+import Data.List
+import Ideas.Common.Classes
+import Ideas.Common.Context
+import System.Random
+import Test.QuickCheck
+
+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/Exercises.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Data.Maybe
+import Domain.RelationAlgebra.Formula
+import Domain.RelationAlgebra.Generator
+import Domain.RelationAlgebra.Parser
+import Domain.RelationAlgebra.Rules
+import Domain.RelationAlgebra.Strategies
+import Ideas.Common.Library
+import Prelude hiding (repeat)
+import Test.QuickCheck
+
+cnfExercise :: Exercise RelAlg
+cnfExercise = makeExercise
+   { exerciseId     = describe "To conjunctive normal form" $
+                         newId "relationalgebra.cnf"
+   , status         = Alpha
+   , parser         = parseRelAlg
+   , prettyPrinter  = ppRelAlg
+   , equivalence    = withoutContext probablyEqual -- isEquivalent
+   , extraRules     = map liftToContext (relAlgRules ++ buggyRelAlgRules)
+   , strategy       = toCNF
+   , navigation     = navigator
+   , ready          = predicate (myReady cnfExercise)
+   , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p)
+                                 in n >= 2 && n <= 4
+                      in useGenerator ok (\_ -> templateGenerator 1)
+   , testGenerator  = Just arbitrary
+   }
+
+stepsRemaining :: Int -> RelAlg -> Maybe Int
+stepsRemaining i =
+   lengthMax i . derivationTree False toCNF . inContext cnfExercise
+
+{- cnfExerciseSimple :: Exercise RelAlg
+cnfExerciseSimple = cnfExercise
+   { identifier  = "cnf-simple"
+   , description = description cnfExercise ++ " (simple)"
+   , strategy    = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise
+   } -}
+
+myReady :: Exercise a -> a -> Bool
+myReady ex = null . applyAll (alternatives $ filter (not . isBuggy) (ruleset ex))
+         . inContext ex
+ src/Domain/RelationAlgebra/Formula.hs view
@@ -0,0 +1,212 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Data.List
+import Ideas.Common.Rewriting
+import Ideas.Common.Utils
+import Ideas.Common.Utils.Uniplate
+import System.Random (StdGen, mkStdGen, split, randomR)
+import Test.QuickCheck
+import Test.QuickCheck.Gen
+import qualified Data.Set as S
+
+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, neg, inv, univ, 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     -> neg (rec p)
+         Inv p     -> inv (rec p)
+         V         -> univ
+         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, neg, inv, univ, 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
+   neg p    = S.fromAscList [ x | x <- pairs, x `S.notMember` p ]
+   inv      = S.map (\(x, y) -> (y, x))
+   univ     = 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 :: [Int]
+   as = [0..1]
+   -- number of attemps (with different randomly generated relations)
+   makeRngs :: Int -> StdGen -> [StdGen]
+   makeRngs n g
+      | n == 0    = []
+      | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2
+   eval g =
+      let MkGen f   = arbRelations as
+          (size, a) = randomR (0, 100) g
+      in evalRelAlg (f a size) as
+
+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 _ = elements [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  -> plate (:.:)  |* s |* t
+         s :+:  t  -> plate (:+:)  |* s |* t
+         s :&&: t  -> plate (:&&:) |* s |* t
+         s :||: t  -> plate (:||:) |* s |* t
+         Not s     -> plate Not    |* s
+         Inv s     -> plate Inv    |* s
+         _         -> plate term
+
+instance Different RelAlg where
+   different = (V, I)
+
+instance IsTerm RelAlg where
+   toTerm = foldRelAlg
+      ( variable, binary compSymbol, binary addSymbol
+      , binary conjSymbol
+      , binary disjSymbol, unary notSymbol, unary invSymbol
+      , symbol universeSymbol, symbol identSymbol
+      )
+
+   fromTerm a =
+      fromTermWith f a `mplus` liftM Var (getVariable a)
+    where
+      f s []
+         | s == universeSymbol  = return V
+         | s == identSymbol     = return I
+      f s [x]
+         | s == notSymbol       = return (Not x)
+         | s == invSymbol       = return (Inv x)
+      f s [x, y]
+         | s == compSymbol      = return (x :.:  y)
+         | s == addSymbol       = return (x :+:  y)
+         | s == conjSymbol      = return (x :&&: y)
+         | s == disjSymbol      = return (x :||: y)
+      f _ _ = fail "fromTerm"
+
+compSymbol, addSymbol, conjSymbol, disjSymbol,
+   notSymbol, invSymbol, universeSymbol, identSymbol :: Symbol
+compSymbol     = relalgSymbol "comp"
+addSymbol      = relalgSymbol "add"
+conjSymbol     = relalgSymbol "conj"
+disjSymbol     = relalgSymbol "disj"
+notSymbol      = relalgSymbol "not"
+invSymbol      = relalgSymbol "inv"
+universeSymbol = relalgSymbol "universe"
+identSymbol    = relalgSymbol "ident"
+
+relalgSymbol :: String -> Symbol
+relalgSymbol a = newSymbol ["relalg", a]
+ src/Domain/RelationAlgebra/Generator.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Monad
+import Domain.RelationAlgebra.Formula
+import Test.QuickCheck
+
+instance Arbitrary RelAlg where
+   arbitrary = sized (arbRelAlg . min 8)
+
+arbRelAlg :: Int -> Gen RelAlg
+arbRelAlg 0 = frequency [(8, liftM Var (elements relAlgVars)), (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)
+
+relAlgVars :: [String]
+relAlgVars = ["q", "r", "s"]
+
+-------------------------------------------------------------------
+-- Templates
+
+template1, template2, template3, template4, template7, template8 ::
+   RelAlg -> RelAlg -> RelAlg -> RelAlg
+
+template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg
+template6 :: Maybe RelAlg -> RelAlg -> RelAlg -> Maybe RelAlg -> RelAlg
+
+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 :: (a -> b -> c -> d) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> t -> Gen d
+use3 temp f g h   n = liftM3 temp (f n) (g n) (h n)
+
+use4 :: (a -> b -> c -> d -> e) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> (t -> Gen d) -> t -> Gen e
+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 (elements relAlgVars)), (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 (elements relAlgVars)
+ src/Domain/RelationAlgebra/Parser.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Ideas.Text.Parsing
+import qualified Text.ParserCombinators.Parsec.Token as P
+
+-----------------------------------------------------------
+--- Parser
+
+parseRelAlg  :: String -> Either String RelAlg
+parseRelAlg = parseSimple relalg
+ where
+   relalg = buildExpressionParser table term
+
+   term = foldl (flip ($)) <$> atom <*> many pUn
+
+   pUn = choice
+      [ Inv <$ reservedOp "~"
+      , Not <$ reservedOp "-"
+      ]
+
+   atom = choice
+      [ V     <$  P.reserved lexer "V"
+      , empty <$  P.reserved lexer "E"
+      , I     <$  P.reserved lexer "I"
+      , Var   <$> P.identifier lexer
+      , P.parens lexer relalg
+      ]
+
+   table =
+      [ [ Infix ((:.:) <$ reservedOp ";") AssocRight -- or none-associative?
+        , Infix ((:+:) <$ reservedOp "!") AssocRight -- or none-associative?
+        ]
+      , [ Infix ((:&&:) <$ reservedOp "/\\") AssocRight ]
+      , [ Infix ((:||:) <$ reservedOp "\\/") AssocRight ]
+      ]
+
+-----------------------------------------------------------
+--- Lexer
+
+lexer :: P.TokenParser a
+lexer = P.makeTokenParser $ emptyDef
+   { reservedNames   = ["V", "E", "I"]
+   , reservedOpNames = ["~", "-", ";", "!", "\\/", "/\\"]
+   , identStart      = letter
+   , identLetter     = letter
+   , opStart         = fail ""
+   , opLetter        = fail ""
+   }
+
+reservedOp :: String -> Parser ()
+reservedOp = P.reservedOp lexer
+
+-----------------------------------------------------------
+--- Pretty-Printer
+
+ppRelAlg :: RelAlg -> String
+ppRelAlg = ppRelAlgPrio (0, "")
+
+ppRelAlgPrio :: (Int, String) -> RelAlg -> String
+ppRelAlgPrio = (\f n -> f n "") . flip (foldRelAlg alg)
+ where
+   alg = (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/"
+         , nott, inv, var "V", var "I"
+         )
+   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,318 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Ideas.Common.Library hiding (ruleList)
+import qualified Ideas.Common.Library as C
+
+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
+                   ]
+
+relalg :: IsId a => a -> Id
+relalg = ( # ) "relationalgebra"
+
+rule :: RuleBuilder f a => String -> f -> Rule a
+rule = C.rewriteRule . relalg
+
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
+ruleList = C.rewriteRules . relalg
+
+-- | 1. Alle ~ operatoren naar binnen verplaatsen
+
+ruleInvOverUnion :: Rule RelAlg
+ruleInvOverUnion = rule "InvOverUnion" $
+   \r s -> Inv (r :||: s) :~> Inv r :||: Inv s
+
+ruleInvOverIntersec :: Rule RelAlg
+ruleInvOverIntersec = rule "InvOverIntersect" $
+   \r s -> Inv (r :&&: s) :~> Inv r :&&: Inv s --- !!!!!!! ALLEEN VOOR FUNCTIES
+
+ruleInvOverComp :: Rule RelAlg
+ruleInvOverComp = rule "InvOverComp" $
+   \r s -> Inv (r :.: s) :~> Inv s :.: Inv r
+
+ruleInvOverAdd :: Rule RelAlg
+ruleInvOverAdd = rule "InvOverAdd" $
+   \r s -> Inv (r :+: s) :~> Inv s :+: Inv r
+
+ruleInvOverNot :: Rule RelAlg
+ruleInvOverNot = rule "InvOverNot" $
+   \r -> Inv (Not r) :~> Not (Inv r)
+
+ruleDoubleInv :: Rule RelAlg
+ruleDoubleInv = rule "DoubleInv" $
+   \r -> Inv (Inv r) :~> r
+
+-- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen
+
+ruleCompOverUnion :: Rule RelAlg
+ruleCompOverUnion = ruleList "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 = ruleList "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 = ruleList "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 = ruleList "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 = ruleList "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
+
+ruleDeMorganOr :: Rule RelAlg
+ruleDeMorganOr = rule "DeMorganOr" $
+   \r s -> Not (r :||: s) :~> Not r :&&: Not s
+
+ruleDeMorganAnd :: Rule RelAlg
+ruleDeMorganAnd = rule "DeMorganAnd" $
+   \r s -> Not (r :&&: s) :~> Not r :||: Not s
+
+-- | 5. Idempotency
+
+ruleIdempOr :: Rule RelAlg
+ruleIdempOr = rule "IdempotencyOr" $
+   \r -> r :||: r :~>  r
+
+ruleIdempAnd :: Rule RelAlg
+ruleIdempAnd = rule "IdempotencyAnd" $
+   \r -> r :&&: r :~>  r
+
+-- | 6. Complement
+
+ruleDoubleNegation :: Rule RelAlg
+ruleDoubleNegation = rule "DoubleNegation" $
+   \r -> Not (Not r) :~> r
+
+ruleRemCompl :: Rule RelAlg
+ruleRemCompl = ruleList "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 = rule "NotOverComp" $
+   \r s -> Not (r :.: s) :~> Not r :+: Not s
+
+ruleNotOverAdd :: Rule RelAlg
+ruleNotOverAdd = rule "NotOverAdd" $
+   \r s -> Not (r :+: s) :~> Not r :.: Not s
+
+-- | 7. Absorption complement
+
+ruleAbsorpCompl :: Rule RelAlg
+ruleAbsorpCompl = ruleList "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 = ruleList "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
+
+ruleRemRedunExprs :: Rule RelAlg
+ruleRemRedunExprs = ruleList "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 :: RuleBuilder f a => String -> [f] -> Rule a
+buggyGroup s =
+   buggy . C.rewriteRules ("relationalgebra.buggy." ++ 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 "DeMorgan"
+    [ \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 "NotOverAdd"
+     [ \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 "NotOverComp"
+     [ \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 "Parenth"
+    [ \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 "Assoc"
+    [ \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 "InvOverComp"
+   [ \r s -> Inv (r :.: s) :~> Inv r :.: Inv s
+   ]
+
+buggyRuleInvOverAdd :: Rule RelAlg
+buggyRuleInvOverAdd = buggyGroup "InvOverAdd"
+   [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s
+   ]
+
+buggyRuleCompOverIntersec :: Rule RelAlg
+buggyRuleCompOverIntersec = buggyGroup "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
+   ]
+buggyRuleAddOverUnion :: Rule RelAlg
+buggyRuleAddOverUnion = buggyGroup "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
+   ]
+
+buggyRuleRemCompl :: Rule RelAlg
+buggyRuleRemCompl = buggyGroup "RemCompl"
+   [ \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,38 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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.Formula
+import Domain.RelationAlgebra.Rules
+import Ideas.Common.Library
+import Prelude
+
+toCNF :: LabeledStrategy (Context RelAlg)
+toCNF = label "To CNF" $
+   repeatS $  label "step1" step1
+           |> label "step2" step2
+           |> label "step3" step3
+ where
+   step1 = oncetd $ useRules $
+      [ ruleRemCompl, ruleRemRedunExprs, ruleDoubleNegation
+      , ruleIdempOr, ruleIdempAnd, ruleAbsorp, ruleAbsorpCompl
+      ] ++ invRules
+   step2 = oncetd $ 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/Main.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, 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 Control.Arrow
+import Ideas.Common.Exercise
+import Ideas.Common.Id
+import Ideas.Common.Utils (Some(..))
+import Ideas.Common.Utils.TestSuite
+import Ideas.Main.Default
+import Ideas.Service.DomainReasoner
+import Ideas.Service.ServiceList
+import Ideas.Service.Types (Service)
+import qualified Domain.LinearAlgebra as LA
+import qualified Domain.LinearAlgebra.Checks as LA
+import qualified Domain.Logic as Logic
+import qualified Domain.Logic.Proofs as Logic
+import qualified Domain.Math.ExerciseList as Math
+import qualified Domain.RelationAlgebra as RA
+
+main :: IO ()
+main = defaultMain ideasMath
+
+ideasMath :: DomainReasoner
+ideasMath = describe "Domain reasoner for mathematics and logic" $
+   (newDomainReasoner "ideas.math")
+      { exercises = myExercises
+      , services  = myServices
+      , views     = Math.viewList
+      , aliases   = myAliases
+      , scripts   = myScripts
+      , testSuite = myTestSuite
+      }
+
+myExercises :: [Some Exercise]
+myExercises =
+   [ -- logic and relation-algebra
+     Some Logic.dnfExercise
+   , Some Logic.dnfUnicodeExercise
+   , Some Logic.proofExercise
+   , Some Logic.proofUnicodeExercise
+   , Some RA.cnfExercise
+     -- linear algebra
+   , Some LA.gramSchmidtExercise
+   , Some LA.linearSystemExercise
+   , Some LA.gaussianElimExercise
+   , Some LA.systemWithMatrixExercise
+     -- regular expressions
+   -- , some RE.regexpExercise
+   ] ++ Math.exerciseList
+
+myServices :: [Service]
+myServices = metaServiceList ideasMath ++ serviceList
+
+myAliases :: [(Id, Id)]
+myAliases = map (newId *** newId)
+   [ ("math.coverup",             "algebra.equations.coverup")
+   , ("math.lineq",               "algebra.equations.linear")
+   , ("math.lineq-mixed",         "algebra.equations.linear.mixed")
+   , ("math.quadreq",             "algebra.equations.quadratic")
+   , ("math.quadreq-no-abc",      "algebra.equations.quadratic.no-abc")
+   , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate")
+   , ("math.higherdegree",        "algebra.equations.polynomial")
+   , ("math.rationaleq",          "algebra.equations.rational")
+   , ("math.linineq",             "algebra.inequalities.linear")
+   , ("math.quadrineq",           "algebra.inequalities.quadratic")
+   , ("math.ineqhigherdegree",    "algebra.inequalities.polynomial")
+   , ("math.factor",              "algebra.manipulation.polynomial.factor")
+   , ("math.simplifyrational",    "algebra.manipulation.rational.simplify")
+   , ("math.simplifypower",       "algebra.manipulation.exponents.simplify")
+   , ("math.nonnegexp",           "algebra.manipulation.exponents.nonnegative")
+   , ("math.powerof",             "algebra.manipulation.exponents.powerof")
+   , ("math.derivative",          "calculus.differentiation")
+   , ("math.fraction",            "arithmetic.fractions")
+   , ("math.calcpower",           "arithmetic.exponents")
+   , ("linalg.gaussianelim",      "linearalgebra.gaussianelim")
+   , ("linalg.gramschmidt",       "linearalgebra.gramschmidt")
+   , ("linalg.linsystem",         "linearalgebra.linsystem")
+   , ("linalg.systemwithmatrix",  "linearalgebra.systemwithmatrix")
+   , ("logic.dnf",                "logic.propositional.dnf")
+   , ("logic.dnf-unicode",        "logic.propositional.dnf.unicode")
+   , ("relationalg.cnf",          "relationalgebra.cnf")
+   -- MathDox compatibility
+   , ("gaussianelimination"        , "linearalgebra.gaussianelim")
+   , ("gramschmidt"                , "linearalgebra.gramschmidt")
+   , ("solvelinearsystem"          , "linearalgebra.linsystem")
+   , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix")
+   ]
+
+myScripts :: [(Id, FilePath)]
+myScripts =
+   [ (getId Logic.dnfExercise,         "logic.txt")
+   , (getId Logic.dnfUnicodeExercise,  "logic.txt")
+   ] ++ Math.scriptList
+
+myTestSuite :: TestSuite
+myTestSuite = do
+   sequence_ Math.testSuiteList
+   LA.checks