diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/board-games.cabal b/board-games.cabal new file mode 100644 --- /dev/null +++ b/board-games.cabal @@ -0,0 +1,111 @@ +Name: board-games +Version: 0.1 +License: GPL +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://code.haskell.org/~thielema/games/ +Category: Game, Web +Synopsis: Three games for inclusion in a web server +Description: + Three games that might run as CGI script in a web server: + Connect Four, Rows&Columns, Mastermind + . + Check running versions at + and + . + . + You can build an example web server by installing with + . + > cabal install board-games -fbuildExamples + . + Then start the server with + . + > ./dist/build/board-games/board-games + . + and play the games in your browser at the URL + . + . + Currently the games use German texts. + I wanted to use gettext, but this is not thread-safe. +Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.12.3 +Cabal-Version: >=1.8 +Build-Type: Simple +Source-Repository head + type: darcs + location: http://code.haskell.org/~thielema/games/ + +Flag buildExamples + description: build example web server that runs the games + +Flag splitBase + description: Choose the new smaller, split-up base package. + +Library + Build-Depends: + html >=1.0 && <1.1, + cgi >=3001.1 && <3001.2, + utility-ht >=0.0.3 && <0.1, + transformers >=0.2.2 && <0.3 + If flag(splitBase) + Build-Depends: + containers >=0.2 && <0.5, + random >=1.0 && <1.1, + array >=0.1 && <0.4, + base >= 2 && <5 + Else + Build-Depends: base >= 1.0 && < 2 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Exposed-Modules: + Game.Tree + Game.VierGewinnt.HTML + Game.VierGewinnt.Text + Game.VierGewinnt + Game.ZeilenSpalten.HTML + Game.ZeilenSpalten + Game.Mastermind.HTML + Game.Mastermind + Game.Mastermind.CodeSet + Game.Mastermind.CodeSet.Union + Game.Mastermind.CodeSet.Tree + Other-Modules: + Game.Utility + +Executable board-games + Main-Is: Game/Server.hs + GHC-Options: -Wall + Hs-Source-Dirs: src + Other-Modules: + Game.Server.Option + If flag(buildExamples) + Build-Depends: + httpd-shed >=0.4 && <0.5, + network >=2.3 && <2.4, + html >=1.0 && <1.1, + cgi >=3001.1 && <3001.2, + utility-ht >=0.0.3 && <0.1, + transformers >=0.2.2 && <0.3, + containers >=0.2 && <0.5, + random >=1.0 && <1.1, + array >=0.1 && <0.4, + base >= 2 && <5 + Else + Buildable: False + +Test-Suite testsuite + Type: exitcode-stdio-1.0 + Main-Is: Game/Test.hs + GHC-Options: -Wall + Hs-Source-Dirs: src + Other-Modules: + Game.Test.Mastermind + Build-Depends: + QuickCheck >1.2 && <3.0, + utility-ht >=0.0.3 && <0.1, + transformers >=0.2.2 && <0.3, + containers >=0.2 && <0.5, + random >=1.0 && <1.1, + array >=0.1 && <0.4, + base >= 2 && <5 diff --git a/src/Game/Mastermind.hs b/src/Game/Mastermind.hs new file mode 100644 --- /dev/null +++ b/src/Game/Mastermind.hs @@ -0,0 +1,288 @@ +module Game.Mastermind where + +import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree +-- import qualified Game.Mastermind.CodeSet.Union as CodeSetUnion +import qualified Game.Mastermind.CodeSet as CodeSet +import Game.Mastermind.CodeSet + (flatten, intersection, (*&), (#*&), unit, empty, union, unions, cube, ) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.List.HT (partitionMaybe, partition, ) +import Data.Tuple.HT (mapPair, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (listToMaybe, ) +import Control.Monad (liftM, guard, when, replicateM, ) + +import qualified Control.Monad.Trans.State as State +import qualified Control.Monad.Trans.Class as Trans + +import qualified System.Random as Rnd +import qualified System.IO as IO + + +data Eval = Eval Int Int + deriving (Eq, Show) + +{- | +Given the code and a guess, compute the evaluation. +-} +evaluate :: (Ord a) => [a] -> [a] -> Eval +evaluate code attempt = + uncurry Eval $ + mapPair + (length, + sum . Map.elems . + uncurry (Map.intersectionWith min) . + mapPair (histogram,histogram) . unzip) $ + partitionMaybe (\(x,y) -> toMaybe (x==y) ()) $ + zip code attempt + +{- +*Game.Mastermind> filter ((Eval 2 0 ==) . evaluate "aabbb") $ replicateM 5 ['a'..'c'] +["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"] +*Game.Mastermind> flatten $ remaining (Set.fromList ['a'..'c']) "aabbb" (Eval 2 0) +["aaaaa","aaaac","aaaca","aaacc","aacaa","aacac","aacca","aaccc","acbcc","accbc","acccb","cabcc","cacbc","caccb","ccbbc","ccbcb","cccbb"] +-} + + +histogram :: (Ord a) => [a] -> Map.Map a Int +histogram = + Map.fromListWith (+) . map (\a -> (a,1)) + +selectFromHistogram :: (Ord a) => Map.Map a Int -> [(a, Map.Map a Int)] +selectFromHistogram hist = + map (\a -> (a, Map.update (\n -> toMaybe (n>1) (pred n)) a hist)) $ + Map.keys hist + +{- | +A variant of the game: +It is only possible to specify number of symbols at right places. + +The results of 'remaining' and 'remainingSimple' cannot be compared. +-} +remainingSimple :: Ord a => Set.Set a -> [a] -> Int -> [[Set.Set a]] +remainingSimple alphabet code rightPlaces = + map + (zipWith + (\symbol right -> + if right + then Set.singleton symbol + else Set.delete symbol alphabet) + code) $ + possibleRightPlaces (length code) rightPlaces + +{- | +Combinatorical \"choose k from n\". +-} +possibleRightPlaces :: Int -> Int -> [[Bool]] +possibleRightPlaces n rightPlaces = + if n < rightPlaces + then [] + else + if n==0 + then [[]] + else + (guard (rightPlaces>0) >> + (map (True:) $ + possibleRightPlaces (n-1) (rightPlaces-1))) + ++ + (map (False:) $ + possibleRightPlaces (n-1) rightPlaces) + +{- | +Given a code and an according evaluation, +compute the set of possible codes. + +The Game.Mastermind game consists of collecting pairs +of codes and their evaluations. +The searched code is in the intersection of all corresponding code sets. +-} +remaining :: + (CodeSet.C set, Ord a) => + Set.Set a -> [a] -> Eval -> set a +remaining alphabet code0 (Eval rightPlaces rightSymbols0) = + let findCodes = + foldr + (\(fixed,c) go rightSymbols floating0 -> + if fixed + then c #*& go rightSymbols floating0 + else + (if rightSymbols == 0 + then empty + else unions $ do + (src, floating1) <- selectFromHistogram floating0 + guard (c /= src) + return $ src #*& go (rightSymbols-1) floating1) + `union` + (Set.difference + (Set.delete c alphabet) + (Map.keysSet floating0) *& + go rightSymbols floating0)) + (\rightSymbols _floating -> + if rightSymbols>0 + then empty + else unit) + in unions $ + map + (\pattern -> + let patternCode = zip pattern code0 + in findCodes patternCode rightSymbols0 $ + histogram $ map snd $ filter (not . fst) patternCode) $ + possibleRightPlaces (length code0) rightPlaces + + +partitionSizes :: (Ord a) => Set.Set a -> [a] -> [(Eval, Integer)] +partitionSizes alphabet code = + map (\eval -> + (eval, + CodeSet.size $ + (id :: CodeSetTree.T a -> CodeSetTree.T a) $ + remaining alphabet code eval)) $ + possibleEvaluations (length code) + +possibleEvaluations :: Int -> [Eval] +possibleEvaluations n = do + rightPlaces <- [0..n] + rightSymbols <- [0..n-rightPlaces] + return $ Eval rightPlaces rightSymbols + + +interaction :: + (CodeSetTree.T Char -> State.StateT state Maybe [Char]) -> + state -> + Set.Set Char -> Int -> IO () +interaction select initial alphabet n = + let go state set = + case State.runStateT (select set) state of + Nothing -> putStrLn "contradicting evaluations" + Just (attempt, newState) -> do + putStr $ show attempt ++ " " ++ + show (CodeSet.size set, CodeSet.representationSize set) ++ " " + IO.hFlush IO.stdout + eval <- getLine + let evalHist = histogram eval + evalHistRem = + Map.keys $ Map.delete 'o' $ Map.delete 'x' evalHist + when (not $ null evalHistRem) + (putStrLn $ "ignoring: " ++ evalHistRem) + let rightPlaces = length (filter ('x' ==) eval) + rightSymbols = length (filter ('o' ==) eval) + if rightPlaces >= n + then putStrLn "I won!" + else go newState $ intersection set $ + remaining alphabet attempt $ + Eval rightPlaces rightSymbols + in go initial (cube alphabet n) + +mainSimple :: Set.Set Char -> Int -> IO () +mainSimple = + interaction + (Trans.lift . listToMaybe . flatten) + () + +-- candidate for random-utility, cf. module htam:Election, markov-chain +randomSelect :: + (Rnd.RandomGen g, Monad m) => + [a] -> State.StateT g m a +randomSelect items = + liftM (items!!) $ State.StateT $ return . Rnd.randomR (0, length items-1) + +{- | +minimum of maximums using alpha-beta-pruning +-} +minimax :: (Ord b) => [(a, [b])] -> a +minimax [] = error "minimax of empty list" +minimax ((a0,bs0):rest) = + fst $ + foldl + (\old@(_minA, minB) (a,bs) -> + let (ltMinB, gtMinB) = partition (minB>) bs + in if null gtMinB + then (a, maximum ltMinB) + else old) + (a0, maximum bs0) rest + +{- +Here we optimize for small set sizes. +For performance we could optimize for small set representation sizes. +However the resulting strategy looks much like the strategy +from mainSimple and needs more attempts. +-} +randomizedAttempt :: + (CodeSet.C set, Rnd.RandomGen g, Ord a) => + Int -> Set.Set a -> + set a -> State.StateT g Maybe [a] +randomizedAttempt n alphabet set = do + randomAttempts <- + replicateM 10 $ + replicateM n $ + randomSelect . Set.toList $ + CodeSet.symbols set + let possible = flatten set + somePossible = + -- take 10 possible + let size = CodeSet.size set + num = 10 + in map (CodeSet.select set) $ + Set.toList $ Set.fromList $ + take num $ + map (flip div (fromIntegral num)) $ + iterate (size+) 0 + _ <- Trans.lift $ listToMaybe possible + return $ minimax $ + map + (\attempt -> (attempt, + map (CodeSet.size . intersection set . remaining alphabet attempt) $ + possibleEvaluations n)) $ + somePossible ++ randomAttempts + +{- | +In the beginning we simply choose a random code +from the set of possible codes. +In the end, when the set becomes small, +then we compare different alternatives. +-} +mixedRandomizedAttempt :: + (CodeSet.C set, Rnd.RandomGen g, Ord a) => + Int -> Set.Set a -> + set a -> State.StateT g Maybe [a] +mixedRandomizedAttempt n alphabet set = do + case CodeSet.size set of + 0 -> Trans.lift Nothing + 1 -> return $ head $ CodeSet.flatten set + 2 -> return $ head $ CodeSet.flatten set + size -> + if size <= 100 + then randomizedAttempt n alphabet set + else + fmap (CodeSet.select set) $ + State.StateT $ return . Rnd.randomR (0, size-1) + +mainRandom :: Set.Set Char -> Int -> IO () +mainRandom alphabet n = do + g <- Rnd.getStdGen + interaction (randomizedAttempt n alphabet) g alphabet n + +main :: IO () +main = +-- mainSimple (Set.fromList ['a'..'z']) 7 + mainRandom (Set.fromList ['a'..'z']) 5 + +{- +Bug: (fixed) +*Game.Mastermind> main +"uvqcm" (11881376,130) o +"wukjv" (3889620,440) +"lmoci" (1259712,372) xo +"caoab" (94275,1765) oo +"mbadi" (6856,2091) ooo +"ombed" (327,447) x +"lqbia" (2,10) xo +contradicting evaluations +*Game.Mastermind> map (evaluate "amiga") ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] +[Eval 0 1,Eval 0 0,Eval 1 1,Eval 0 2,Eval 0 3,Eval 1 0,Eval 1 1] +*Game.Mastermind> map (\attempt -> member "amiga" $ remaining (Set.fromList $ ['a'..'z']) attempt (evaluate "amiga" attempt)) ["uvqcm","wukjv","lmoci","caoab","mbadi","ombed","lqbia"] +[True,True,True,True,False,True,False] +-} diff --git a/src/Game/Mastermind/CodeSet.hs b/src/Game/Mastermind/CodeSet.hs new file mode 100644 --- /dev/null +++ b/src/Game/Mastermind/CodeSet.hs @@ -0,0 +1,71 @@ +module Game.Mastermind.CodeSet where + +import qualified Data.Set as Set +import qualified Data.List as List +import qualified Data.List.Key as Key +import Data.Function.HT (nest, ) +import Data.Ord.HT (comparing, ) + +import Prelude hiding (null, ) + + +class C set where + empty :: set a + union, intersection :: (Ord a) => set a -> set a -> set a + unit :: set a + -- | the left operand must be non-empty + leftNonEmptyProduct :: Set.Set a -> set a -> set a + flatten :: (Ord a) => set a -> [[a]] + symbols :: (Ord a) => set a -> Set.Set a + null :: set a -> Bool + size :: set a -> Integer + select :: set a -> Integer -> [a] + representationSize :: set a -> Int + -- | simplify set representation by combining set products where possible + compress :: (Ord a) => set a -> set a + +cube :: (C set) => Set.Set a -> Int -> set a +cube alphabet n = + nest n (leftNonEmptyProduct alphabet) unit + +unions :: (C set, Ord a) => [set a] -> set a +unions = foldr union empty + + +-- simulate priority queue +insertSortedBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertSortedBy cmp x = + let recourse [] = [x] + recourse (y:ys) = + if cmp x y == GT + then y : recourse ys + else x:y:ys + in recourse + +intersections :: (C set, Ord a) => [set a] -> set a +intersections = + let go [] = error "intersections: empty list" + go [(_, set)] = set + go ((_,x):(_,y):rest) = + let sec = intersection x y + in go (insertSortedBy (comparing fst) (size sec, sec) rest) + in go . + List.sortBy (comparing fst) . + map (\set -> (size set, set)) + +intersectionsSort :: (C set, Ord a) => [set a] -> set a +intersectionsSort = + foldl1 intersection . Key.sort size + +{- | +Like 'leftNonEmptyProduct' but the left operand can be empty. +-} +(*&) :: (C set) => Set.Set a -> set a -> set a +c *& set = + if Set.null c + then empty + else leftNonEmptyProduct c set + +(#*&) :: (C set) => a -> set a -> set a +c #*& set = + leftNonEmptyProduct (Set.singleton c) set diff --git a/src/Game/Mastermind/CodeSet/Tree.hs b/src/Game/Mastermind/CodeSet/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Mastermind/CodeSet/Tree.hs @@ -0,0 +1,177 @@ +module Game.Mastermind.CodeSet.Tree where + +import qualified Game.Mastermind.CodeSet as CodeSet + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.Tuple.HT (mapFst, swap, ) + +import Control.Monad (liftM2, ) + +import Prelude hiding (null, ) + + +{- | +@Products [(a,b),(c,d)]@ +expresses a x b union c x d, +where @x@ denotes the set product. +-} +data T a = + End | Products (Map.Map (Set.Set a) (T a)) + deriving (Show) + +{- +instance (Ord a, Show a) => Show (T a) where + showsPrec n cs = + showParen (n>=10) $ + showString "CodeSet.fromLists " . shows (toLists cs) +-} + +instance CodeSet.C T where + empty = Products Map.empty + union = union + intersection = intersection + unit = End + leftNonEmptyProduct c xs = + Products $ + if null xs + then Map.empty + else Map.singleton c xs + flatten = flatten + symbols = symbols + null = null + size = size + select = select + representationSize = representationSize + compress = compress + + +flatten :: (Ord a) => T a -> [[a]] +flatten End = [[]] +flatten (Products xs) = + concatMap + (\(a,b) -> liftM2 (:) (Set.toList a) (flatten b)) + (Map.toList xs) + +symbols :: (Ord a) => T a -> Set.Set a +symbols End = Set.empty +symbols (Products xps) = + Set.unions $ + map (\(x,xs) -> Set.union x (symbols xs)) $ + Map.toList xps + + +size :: T a -> Integer +size End = 1 +size (Products xs) = + sum (map (\(a,b) -> fromIntegral (Set.size a) * size b) $ Map.toList xs) + +-- somehow inefficient, because the sizes of subsets are recomputed several times +select :: T a -> Integer -> [a] +select End n = + case compare n 0 of + LT -> error "CodeSet.select.end: index negative" + EQ -> [] + GT -> error "CodeSet.select.end: index too large" +select (Products xps) n0 = + if n0<0 + then error "CodeSet.select: negative index" + else + case dropWhile (\(_, ((n1,sz), _)) -> n1>=sz) $ + zip (Map.toList xps) $ + uncurry zip $ + mapFst (\sizes -> zip (scanl (-) n0 sizes) sizes) $ + unzip $ + map (\(x,xs) -> + let sz = size xs + in (fromIntegral (Set.size x) * sz, sz)) $ + Map.toList xps of + [] -> error "CodeSet.select: index too large" + ((x,xs), ((n1,_), xsSize)) : _ -> + let (j,k) = divMod n1 xsSize + in (Set.toList x !! fromInteger j) + : select xs k + +representationSize :: T a -> Int +representationSize End = 1 +representationSize (Products xs) = + sum (map (\(a,b) -> Set.size a + representationSize b) $ Map.toList xs) + + +{- | +We could try to merge set products. +I'll first want to see, whether this is needed in a relevant number of cases. +-} +union :: (Ord a) => T a -> T a -> T a +union End End = End +union (Products xs) (Products ys) = + Products (Map.unionWith union xs ys) +union _ _ = error "CodeSet.union: sets with different tuple size" + +intersection :: (Ord a) => T a -> T a -> T a +intersection End End = End +intersection (Products xps) (Products yps) = + Products $ Map.fromListWith union $ normalizeProducts $ + liftM2 + (\(x,xs) (y,ys) -> (Set.intersection x y, intersection xs ys)) + (Map.toList xps) + (Map.toList yps) +intersection _ _ = + error "CodeSet.intersection: sets with different tuple size" + +{- | +Remove empty set products. +-} +normalizeProducts :: + [(Set.Set a, T a)] -> [(Set.Set a, T a)] +normalizeProducts = + filter (\(x,xs) -> not (Set.null x || null xs)) + + +{- | +This allows (T a) to be a key in a Map. +I do not want an Ord (T a) instance, +since it makes no sense and it requires an Eq (T a) instance +that is either expensive (if it means set equality) +or confusing (if it means structural equality). +-} +newtype Indexable a = Indexable (T a) + +instance (Eq a) => Eq (Indexable a) where + (Indexable x) == (Indexable y) = + case (x,y) of + (End,End) -> True + (Products xs, Products ys) -> + fmap Indexable xs == fmap Indexable ys + _ -> False + +instance (Ord a) => Ord (Indexable a) where + compare (Indexable x) (Indexable y) = + case (x,y) of + (End,End) -> EQ + (End,Products _) -> LT + (Products _,End) -> GT + (Products xs, Products ys) -> + compare (fmap Indexable xs) (fmap Indexable ys) + + +compress :: (Ord a) => T a -> T a +compress End = End +compress (Products xs) = + Products $ + Map.fromListWith union $ map swap $ map (mapFst (\(Indexable set) -> set)) $ Map.toList $ + Map.fromListWith Set.union $ map (mapFst Indexable) $ map swap $ Map.toList $ + fmap compress xs + +member :: (Ord a) => [a] -> T a -> Bool +member [] End = True +member (c:cs) (Products xps) = + any (\(x,xs) -> Set.member c x && member cs xs) $ + Map.toList xps +member _ _ = + error "CodeSet.member: mismatch of tuple size and tuple size in set" + +null :: T a -> Bool +null End = False +null (Products xs) = Map.null xs diff --git a/src/Game/Mastermind/CodeSet/Union.hs b/src/Game/Mastermind/CodeSet/Union.hs new file mode 100644 --- /dev/null +++ b/src/Game/Mastermind/CodeSet/Union.hs @@ -0,0 +1,138 @@ +module Game.Mastermind.CodeSet.Union where + +import qualified Game.Mastermind.CodeSet as CodeSet + +import qualified Data.Set as Set + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import Control.Monad (liftM2, guard, ) + + +{- | +@Cons [[a,b,c,d], [e,f,g,h]]@ +expresses a x b x c x d union e x f x g x h, +where @x@ denotes the set product. +-} +newtype T a = Cons [[Set.Set a]] + +instance (Ord a, Show a) => Show (T a) where + showsPrec n cs = + showParen (n>=10) $ + showString "CodeSet.fromLists " . shows (toLists cs) + +instance CodeSet.C T where + empty = Cons [] + union = union + intersection = intersection + unit = Cons [[]] + leftNonEmptyProduct c (Cons xs) = Cons (map (c:) xs) + flatten = flatten + symbols = symbols + null (Cons xs) = null xs + size = size + select = select + representationSize = representationSize + compress = id + + +toLists :: (Ord a) => T a -> [[[a]]] +toLists (Cons xs) = + map (map Set.toList) xs + +fromLists :: (Ord a) => [[[a]]] -> T a +fromLists = + Cons . map (map Set.fromList) + +flatten :: (Ord a) => T a -> [[a]] +flatten = concatMap sequence . toLists + +symbols :: (Ord a) => T a -> Set.Set a +symbols (Cons xs) = + Set.unions $ map Set.unions xs + +cube :: Int -> Set.Set a -> T a +cube n alphabet = Cons [replicate n alphabet] + + +size :: T a -> Integer +size = sum . productSizes + +productSizes :: T a -> [Integer] +productSizes (Cons x) = + map (product . map (fromIntegral . Set.size)) $ x + +select :: T a -> Integer -> [a] +select set@(Cons xs) n0 = + let sizes = productSizes set + in if n0<0 + then error "CodeSet.select: negative index" + else + case dropWhile (\(n1,sz,_) -> n1>=sz) $ + zip3 (scanl (-) n0 sizes) sizes xs of + [] -> error "CodeSet.select: index too large" + (n1,_,prod) : _ -> + (\(n3,cs) -> + if n3==0 + then cs + else error "CodeSet.select: at the end index must be zero") $ + List.mapAccumR + (\n2 componentSet -> + let (n3,i) = divMod n2 (fromIntegral $ Set.size componentSet) + in (n3, Set.toList componentSet !! fromInteger i)) + n1 prod + +representationSize :: T a -> Int +representationSize (Cons x) = + sum . map (sum . map Set.size) $ x + + +{- | +We could try to merge set products. +I'll first want to see, whether this is needed in a relevant number of cases. +-} +union :: T a -> T a -> T a +union (Cons x) (Cons y) = Cons (x++y) + +intersection :: (Ord a) => T a -> T a -> T a +intersection (Cons x) (Cons y) = + normalize $ Cons $ liftM2 (zipWith Set.intersection) x y + +member :: (Ord a) => [a] -> T a -> Bool +member code (Cons xs) = + any (and . zipWith Set.member code) xs + +{- | +Remove empty set products. +-} +normalize :: T a -> T a +normalize (Cons x) = + Cons $ filter (all (not . Set.null)) x + + +disjointProduct :: (Ord a) => [Set.Set a] -> [Set.Set a] -> Bool +disjointProduct prod0 prod1 = + any Set.null $ zipWith Set.intersection prod0 prod1 + +{- | +for debugging: list all pairs of products, that overlap +-} +overlappingPairs :: (Ord a) => T a -> [([Set.Set a], [Set.Set a])] +overlappingPairs (Cons xs) = do + prod0:rest <- ListHT.tails xs + prod1 <- rest + guard $ not $ disjointProduct prod0 prod1 + return (prod0, prod1) + +{- | +for debugging: list all subsets, that are contained in more than one product +-} +overlapping :: (Ord a) => T a -> [([Set.Set a], [[Set.Set a]])] +overlapping (Cons xs) = do + subset <- Set.toList $ Set.fromList $ do + prod0:rest <- ListHT.tails xs + prod1 <- rest + let sec = zipWith Set.intersection prod0 prod1 + guard $ all (not . Set.null) $ sec + return sec + return (subset, filter (not . disjointProduct subset) xs) diff --git a/src/Game/Mastermind/HTML.hs b/src/Game/Mastermind/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Game/Mastermind/HTML.hs @@ -0,0 +1,263 @@ +{- | Input and output for Game.Mastermind -} +module Game.Mastermind.HTML where + +import qualified Game.Mastermind.CodeSet.Tree as CodeSetTree +import qualified Game.Mastermind.CodeSet as CodeSet +import qualified Game.Mastermind as MM +import Game.Utility (readMaybe, nullToMaybe, ) + +import Text.Html((<<), (+++), concatHtml, toHtml) +import qualified Text.Html as Html + +import qualified Network.CGI as CGI + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import qualified Data.Set as Set +import qualified Control.Monad.Trans.State as State +import Control.Monad (liftM2, replicateM, ) + +import Data.Tuple.HT (mapPair, ) +import qualified System.Random as Rnd + + +labelAnchor :: String -> Html.Html -> Html.Html +labelAnchor ref label = + Html.anchor label Html.! [Html.href ref] + +relHeight, relWidth :: Int -> Html.HtmlAttr +relHeight r = Html.strAttr "HEIGHT" (show r ++ "%") +relWidth r = Html.strAttr "WIDTH" (show r ++ "%") + + +type Move = (String, MM.Eval) +type Config = (Int, Set.Set Char, Int, Maybe [Move], Maybe String) + +evaluation :: MM.Eval -> Html.Html +evaluation (MM.Eval rightPlaces rightSymbols) = + (Html.table $ + Html.tr $ concatHtml $ + replicate rightPlaces + ((Html.td << Html.spaceHtml) Html.! [Html.bgcolor Html.black]) ++ + replicate rightSymbols + ((Html.td << Html.spaceHtml) Html.! [Html.bgcolor Html.white])) + Html.! [Html.border 2] + +state :: + Config -> + Maybe (CodeSetTree.T Char) -> + Maybe String -> + Html.Html +state (width, alphabet, seed, mMoves, mAttempt) mRemaining mCheck = + let moves = maybe [] id mMoves + select name options = + (Html.select $ concatHtml $ + map (Html.option . toHtml) options) + Html.! [Html.name name] + verify code eval = + case mCheck of + Nothing -> [] + Just check -> + let shouldBeEval = MM.evaluate check code + in [if shouldBeEval == eval + then toHtml " " + else toHtml "sollte sein:" +++ + Html.spaceHtml +++ + evaluation shouldBeEval] + won = + not (null moves) && + case last moves of + (_, MM.Eval rightPlaces _) -> rightPlaces == width + in Html.center $ + (Html.! [Html.action "Mastermind"]) $ + Html.form $ concatHtml $ + [Html.hidden "width" (show width), + Html.hidden "alphabet" (Set.toAscList alphabet), + Html.hidden "seed" (show seed), + Html.hidden "moves" (unwords $ map formatMove moves)] + ++ + maybe [] (\attempt -> [Html.hidden "attempt" attempt]) mAttempt + ++ + [(Html.table $ + concatHtml $ map Html.tr $ + zipWith (\n row -> Html.th (toHtml (show n ++ ".")) +++ row) [(0::Int)..] $ + flip map moves (\(code, eval) -> + concatHtml $ map Html.td $ + map toHtml code ++ + [evaluation eval] ++ + verify code eval) + ++ + if won || maybe False (null . CodeSet.flatten) mRemaining + then [] + else [ + maybe + (Html.td (Html.textfield "attempt" Html.! + [Html.maxlength width]) Html.! [Html.colspan width] + +++ + Html.td (Html.submit "" "abschicken")) + (\attempt -> + concatHtml $ map Html.td $ + map toHtml attempt ++ + let numbers = map show [0..width] + in [concatHtml + [select "rightplaces" numbers, + Html.spaceHtml, + select "rightsymbols" numbers, + Html.spaceHtml, + Html.submit "" "bewerten"]]) + mAttempt]) + -- Html.! [Html.border 2] + ] + ++ + (case mRemaining of + Nothing -> [] + Just remaining -> + [case CodeSet.size remaining of + 0 -> + toHtml "Die Bewertungen sind widerspr\252chlich." + +++ + Html.br + +++ + toHtml "Welchen Code meinten Sie? " + +++ + Html.textfield "check" Html.! [Html.maxlength width] + +++ + Html.submit "" "pr\252fen" + + 1 -> toHtml "Dies ist die einzige verbleibende M\246glichkeit." + n -> + toHtml + ("Es bleiben noch " ++ show n ++ + " M\246glichkeiten. Hier eine kleine Auswahl:") + +++ + (Html.ordList $ take 10 $ CodeSet.flatten remaining)]) + ++ + (if won + then [Html.br, Html.bold $ Html.toHtml "R\228tsel gel\246st!"] + else []) + + +game :: String -> Html.Html +game s = + case parseQuery s of + Just ((width, alphabet, seed, mMoves, mAttempt), mCheck) -> + case (mMoves,mAttempt) of + (Just moves, Nothing) -> + let remaining = + CodeSet.compress $ + CodeSet.intersections $ + CodeSet.cube alphabet width : + map (uncurry (MM.remaining alphabet)) moves + (attempt,newSeed) = + maybe + (Nothing, seed) + (mapPair (Just, fst . Rnd.random)) $ + State.runStateT + (MM.mixedRandomizedAttempt width alphabet remaining) + (Rnd.mkStdGen seed) + in state + (width, alphabet, newSeed, Just moves, attempt) + (Just remaining) + mCheck + _ -> + let code = + State.evalState + (replicateM width + (MM.randomSelect (Set.toList alphabet))) + (Rnd.mkStdGen seed) + in state + (width, alphabet, seed, + Just $ maybe [] id mMoves ++ + maybe [] (\attempt -> [(attempt, MM.evaluate code attempt)]) mAttempt, + Nothing) + Nothing + mCheck + Nothing -> + toHtml $ "Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen." + +start :: Int -> Html.Html +start seed = + toHtml "Es r\228t" +++ + Html.simpleTable [] [] + (map (\(alphabet,typ) -> + map (\(computerAttempts,player) -> + labelAnchor + ("Mastermind?"++ + formatQuery + (4, Set.fromList alphabet, seed, + if computerAttempts then Just [] else Nothing, Nothing)) + << ("der "++player++" "++typ++".")) + [(False,"Mensch"),(True,"Computer")]) + [(['0'..'9'], "Zahlen"),(['a'..'z'], "W\246rter")]) Html.! [Html.border 2] + + +complete :: Html.Html -> Html.Html +complete body = + Html.header (Html.thetitle << "Mastermind") +++ + Html.body body +++ + Html.br +++ labelAnchor "Mastermind" << "Noch einmal von vorne!" + +-- need Maybe String in order to distinguish between "?" and "" +generate :: Maybe String -> IO Html.Html +generate = + maybe (fmap start Rnd.randomIO) (return . game) + + +formatQuery :: Config -> String +formatQuery (width, alphabet, seed, mMoves, mAttempt) = + CGI.formEncode $ + ("width", show width) : + ("alphabet", Set.toAscList alphabet) : + ("seed", show seed) : + (case mAttempt of + Nothing -> [] + Just attempt -> [("attempt", attempt)]) ++ + (case mMoves of + Nothing -> [] + Just moves -> [("moves", unwords $ map formatMove moves)]) ++ + [] + +formatMove :: (String, MM.Eval) -> String +formatMove (code, MM.Eval rightPlaces rightSymbols) = + code ++ "-" ++ show rightPlaces ++ "-" ++ show rightSymbols + +parseQuery :: String -> Maybe (Config, Maybe String) +parseQuery query = + let pairs = CGI.formDecode query + in do width <- readMaybe =<< List.lookup "width" pairs + alphabet <- fmap Set.fromList $ List.lookup "alphabet" pairs + seed <- readMaybe =<< List.lookup "seed" pairs + mMoves <- + maybe (Just Nothing) + (fmap Just . + mapM (\moveText -> + case ListHT.chop ('-' ==) moveText of + [code,rightPlacesText,rightSymbolsText] -> + fmap ((,) code) $ + liftM2 MM.Eval + (readMaybe rightPlacesText) + (readMaybe rightSymbolsText) + _ -> Nothing) + . + words) $ + List.lookup "moves" pairs + let mAttempt0 = List.lookup "attempt" pairs + mRightPlaces = fmap readMaybe $ List.lookup "rightplaces" pairs + mRightSymbols = fmap readMaybe $ List.lookup "rightsymbols" pairs + (moves,mAttempt) <- + case mMoves of + Nothing -> Just (Nothing, Nothing) + Just moves0 -> + case liftM2 (,) mAttempt0 $ + liftM2 (,) mRightPlaces mRightSymbols of + Just (move, mEval) -> + fmap (\eval -> (Just $ moves0 ++ [(move,eval)], Nothing)) $ + uncurry (liftM2 MM.Eval) mEval + Nothing -> Just (Just moves0, mAttempt0) + return ((width, alphabet, seed, moves, mAttempt), + List.lookup "check" pairs) + + +main :: IO () +main = + putStr . Html.renderHtml . complete =<< generate . nullToMaybe =<< getLine diff --git a/src/Game/Server.hs b/src/Game/Server.hs new file mode 100644 --- /dev/null +++ b/src/Game/Server.hs @@ -0,0 +1,59 @@ +module Main where + +import qualified Game.ZeilenSpalten.HTML as ZeilenSpalten +import qualified Game.VierGewinnt.HTML as VierGewinnt +import qualified Game.Mastermind.HTML as Mastermind +import qualified Game.Server.Option as Option + +import qualified Network.Shed.Httpd as HTTPd +import Network.URI (uriQuery, uriPath, ) + +import Text.Html((<<), (+++), ) +import qualified Text.Html as Html + + +headers :: [(String, String)] +headers = + [("Content-Type", "text/html; charset=latin1")] + +withQuery :: String -> (Maybe String -> IO HTTPd.Response) -> IO HTTPd.Response +withQuery query action = + case query of + '?':str -> print str >> (action $ Just str) + [] -> action $ Nothing + _ -> return $ HTTPd.Response 400 [] $ "invalid query: " ++ query + +main :: IO () +main = do + opt <- Option.get + HTTPd.initServer (Option.port opt) $ \ req -> do + Option.printVerbose opt 1 req + let uri = HTTPd.reqURI req + Option.printVerbose opt 2 $ uriQuery uri + Option.printVerbose opt 2 $ HTTPd.queryToArguments $ uriQuery uri + case uriPath uri of + "/" -> + return $ HTTPd.Response 200 headers $ + Html.renderHtml $ + Html.header (Html.thetitle << "Web games") +++ + Html.body (Html.unordList (map + (\(path,name) -> (Html.anchor << name) Html.! [Html.href path]) $ + ("VierGewinnt", "Vier gewinnt") : + ("ZeilenSpalten", "Zeilen und Spalten") : + ("Mastermind", "Mastermind") : + [])) + "/VierGewinnt" -> + withQuery (uriQuery uri) $ \query -> + return $ HTTPd.Response 200 headers $ Html.renderHtml $ + VierGewinnt.komplett $ VierGewinnt.erzeuge query + "/ZeilenSpalten" -> + withQuery (uriQuery uri) $ \query -> + fmap (HTTPd.Response 200 headers . Html.renderHtml . + ZeilenSpalten.komplett) $ ZeilenSpalten.erzeuge query + "/Mastermind" -> + withQuery (uriQuery uri) $ \query -> + fmap (HTTPd.Response 200 headers . Html.renderHtml . + Mastermind.complete) $ Mastermind.generate query + path -> + return $ HTTPd.Response 404 [] $ "unknown game: " ++ path + return () diff --git a/src/Game/Server/Option.hs b/src/Game/Server/Option.hs new file mode 100644 --- /dev/null +++ b/src/Game/Server/Option.hs @@ -0,0 +1,92 @@ +module Game.Server.Option ( + T(..), + get, + printVerbose, + ) where + +import System.Console.GetOpt + (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, ) +import System.Environment (getArgs, getProgName, ) +import System.Exit (exitSuccess, exitFailure, ) +import qualified System.IO as IO + +import Control.Monad (when, ) + + +data T = + Cons { + verbosity :: Int, + port :: Int + } + deriving (Show) + + +deflt :: T +deflt = + Cons { + verbosity = 0, + port = 8080 + -- other options might control maximum values for some dimensions in the games + } + + +exitFailureMsg :: String -> IO a +exitFailureMsg msg = + IO.hPutStrLn IO.stderr msg >> exitFailure + +parseNumber :: + (Read a) => + String -> (a -> Bool) -> String -> String -> IO a +parseNumber name constraint constraintName str = + case reads str of + [(n, "")] -> + if constraint n + then return n + else exitFailureMsg $ name ++ " must be " ++ constraintName + _ -> + exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'" + + +printVerbose :: (Show a) => T -> Int -> a -> IO () +printVerbose opt verb a = + when (verb <= verbosity opt) $ print a + + +{- +Guide for common Linux/Unix command-line options: + http://www.faqs.org/docs/artu/ch10s05.html +-} +description :: [OptDescr (T -> IO T)] +description = + Option ['h'] ["help"] + (NoArg $ \ _flags -> do + programName <- getProgName + putStrLn + (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description) + exitSuccess) + "show options" : + Option ['v'] ["verbose"] + (flip ReqArg "LEVEL" $ \str flags -> + fmap (\verb -> flags{verbosity = fromInteger verb}) $ + parseNumber "verbosity" (\n -> 0<=n && n<=2) "from the range from 0 to 2" str) + "level of verbosity" : + Option ['p'] ["port"] + (flip ReqArg "NUMBER" $ \str flags -> + fmap (\p -> flags{port = fromInteger p}) $ + parseNumber "port" (\n -> 0>=) + (return deflt) + opts diff --git a/src/Game/Tree.hs b/src/Game/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Tree.hs @@ -0,0 +1,127 @@ +module Game.Tree where + +import Data.Maybe (fromMaybe, ) +import Data.List (maximumBy, minimumBy, sortBy, ) + +import Data.Tuple.HT (mapSnd, ) +import Data.Function.HT (compose2, ) + + +data T move state = + Cons {state :: state, + subTrees :: [(move, T move state)]} + deriving (Show, Read) + +mapTrees :: (a -> b) -> [(c,a)] -> [(c,b)] +mapTrees f = map (mapSnd f) + +mapNodesLeaves :: (state0 -> state1) -> (state0 -> state1) -> + T move state0 -> T move state1 +mapNodesLeaves _ leafFunc (Cons st []) = + Cons (leafFunc st) [] +mapNodesLeaves nodeFunc leafFunc (Cons st subs) = + Cons (nodeFunc st) (mapTrees (mapNodesLeaves nodeFunc leafFunc) subs) + +instance Functor (T move) where + fmap f (Cons st subs) = + Cons (f st) (mapTrees (fmap f) subs) + +scanChildren :: + ([(move, T move state)] -> [(move, T move state)]) -> + T move state -> T move state +scanChildren f (Cons st subs) = + Cons st (f (mapTrees (scanChildren f) subs)) + + +build :: (state -> [(move, state)]) -> state -> T move state +build nextMoves start = + Cons start (mapTrees (build nextMoves) + (nextMoves start)) + +selectSubTree :: (Eq move) => move -> T move state -> T move state +selectSubTree mv (Cons _ subs) = + fromMaybe (error "selectSubTree: illegal move") (lookup mv subs) + +selectDeepSubTree :: (Eq move) => [move] -> T move state -> T move state +selectDeepSubTree = + flip (foldl (flip selectSubTree)) + +{- prune the tree to a fixed depth -} +pruneDepth :: Int -> T move state -> T move state +pruneDepth 0 (Cons st _) = Cons st [] +pruneDepth n (Cons st subs) = + Cons st (mapTrees (pruneDepth (n-1)) subs) + +{- prune the tree roughly to a fixed volume -} +pruneVolume :: Int -> T move state -> T move state +pruneVolume 0 (Cons st _) = Cons st [] +pruneVolume n (Cons st subs) = + let subSize = div n (length subs) + in Cons st (mapTrees (pruneVolume subSize) subs) + + +maximise, minimise :: (Ord score) => T move score -> score +maximise (Cons score []) = score +maximise (Cons _ subs) = + maximum (map (minimise . snd) subs) + +minimise (Cons score []) = score +minimise (Cons _ subs) = + minimum (map (maximise . snd) subs) + + +maximumMove, minimumMove :: (Ord score) => T move score -> move +maximumMove (Cons _ subs) = + fst (maximumBy (compose2 compare snd) + (mapTrees maximise subs)) +minimumMove (Cons _ subs) = + fst (minimumBy (compose2 compare snd) + (mapTrees minimise subs)) + + +maximiseFast, minimiseFast :: (Ord score) => T move score -> [score] +maximiseFast (Cons score []) = [score] +maximiseFast (Cons _ subs) = + mapMinimum (map (minimiseFast . snd) subs) + +minimiseFast (Cons score []) = [score] +minimiseFast (Cons _ subs) = + mapMaximum (map (maximiseFast . snd) subs) + +{- it holds + maximum (map minimum xs) = maximum (mapMinimum xs) + but compared to (map minimum) those minima are omited, + which do not alter the overall maximum -} +mapMaximum, mapMinimum :: (Ord score) => [[score]] -> [score] +mapMaximum [] = error "GameTree.mapMaximum: empty list" +mapMaximum (x:xs) = + let bound = maximum x + in bound : map maximum (filter (all (<=bound)) xs) +mapMinimum [] = error "GameTree.mapMinimum: empty list" +mapMinimum (x:xs) = + let bound = minimum x + in bound : map minimum (filter (all (>=bound)) xs) + + +{- only if child notes are sorted, + then mapMaximum can prune uninteresting sub trees -} +sortChildrenAsc, sortChildrenDesc :: (Ord score) => + T move score -> T move score +-- sortChildrenAsc = scanChildren (sortBy (compose2 compare state)) +sortChildrenAsc (Cons st subs) = + Cons st (sortBy (compose2 compare (state . snd)) + (mapTrees sortChildrenDesc subs)) +sortChildrenDesc (Cons st subs) = + Cons st (sortBy (compose2 (flip compare) (state . snd)) + (mapTrees sortChildrenAsc subs)) + + +maximumMoveFast, minimumMoveFast :: (Ord score) => T move score -> move +maximumMoveFast = + fst . maximumBy (compose2 compare snd) . + mapTrees (maximum . maximiseFast) . subTrees . + sortChildrenAsc +minimumMoveFast = + fst . minimumBy (compose2 compare snd) . + mapTrees (minimum . minimiseFast) . subTrees . + sortChildrenDesc diff --git a/src/Game/Utility.hs b/src/Game/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Game/Utility.hs @@ -0,0 +1,11 @@ +module Game.Utility where + +readMaybe :: (Read a) => String -> Maybe a +readMaybe str = + case reads str of + [(a,"")] -> Just a + _ -> Nothing + +nullToMaybe :: [a] -> Maybe [a] +nullToMaybe [] = Nothing +nullToMaybe s = Just s diff --git a/src/Game/VierGewinnt.hs b/src/Game/VierGewinnt.hs new file mode 100644 --- /dev/null +++ b/src/Game/VierGewinnt.hs @@ -0,0 +1,291 @@ +module Game.VierGewinnt where +{- + +http://sim.mathematik.uni-halle.de/~helmut/Fun/Game.VierGewinnt/vierg.hs + +VIER-GEWINNT IN HASKELL + +Idee und Programmierung: Joerg Wensch und Helmut Podhaisky + {wensch,podhaisky}@mathematik.uni-halle.de +Version vom Mai 2002 + +Kopierrechte nach GPL +(GNU GENERAL PUBLIC LICENSE, siehe http://www.gnu.org/) + +-} + +import qualified Data.List.Key as Key + +import Data.Array (Array, Ix, array, range, inRange, listArray, (!), (//), ) +import Data.Maybe (isNothing, catMaybes, ) + +{- +Es gibt die Dateneinheit Spielstand. Zu ihr gehoert immer eine +Sofortwertung. Neue Zuege koennen nur mit doTheMove aus einem alten +Spielstand abgeleitet werden. So sind inkrementelle Bewertungsfunktionen +leicht implementierbar. Die Positionsbewertung erfolgt mit einem +(vorzeichenbehafteten) Integerwert. Alle Sonderfaelle lassen sich in +diesen Integerwert hineinpressen. Z.B. so: + + + posinfty >= matt in 7 => matt in 3 >= 500 Materialpunkte >= 10 + Materialpunkte >= patt in 10 >= patt in 1 >= sofortpatt >= - 10 + materialpunkte >= matt in 7 >= -neginfty + +Besonderheiten fuer Vier-Gewinnt: +Es gibt 69 Vierer. Wir werten nur diese, unabhaengig von der konkreten +Lage mit 0 1 5 oder 50 Punkten fuer 0,1,2 oder 3 Steine (und Luft +sonst). + + +Das muss ein Fehler sein: +In folgender Spielsituation tut der Computer was ganz dummes, +er verhindert nicht den Vierer. +putStr (game (Computer, [1,4,4,4,6,3,3,7,3,4,5,6,3,3,1,6,2,2,2,4,5,2])) + +-} + +type Brett = Array (Int,Int) (Maybe Spieler) +type Fuellstand = Array Int Int +type Wertung = Int +type Zug = Int +data Spieler = + Computer + | Mensch + deriving (Show,Read,Eq,Ord,Ix) + +{- +instance Ix a => Ix Maybe a where +a general Ix instance for Maybe cannot be defined, +because if the lower index bound is Nothing +then we do not know the next larger index of the form (Just i). +This is a problem e.g. for Maybe Int +-} + +data Spielstand = + S {brettVon :: Brett, + fuellstandVon :: Fuellstand, + amZug :: Spieler, + wertung :: Wertung, + anfangundzuege :: (Spieler, [Zug])} + +brettGroesse :: ((Int,Int),(Int,Int)) +brettGroesse = ((1,1),(7,6)) + +posinfty, neginfty :: Wertung +posinfty = 10000 +neginfty = -10000 + +gegner :: Spieler -> Spieler +gegner Mensch = Computer +gegner Computer = Mensch + + + +moeglicheZuege :: Spielstand -> [Int] +moeglicheZuege spielstand = + let brett = brettVon spielstand + in filter (\i -> isNothing (brett!(i,6))) [1..7] + +computerAmZug :: Spielstand -> Bool +computerAmZug spielstand = + amZug spielstand == Computer + +istMatt, istPatt :: Spielstand -> Bool +istMatt spielstand = abs (wertung spielstand) >= 5000 +istPatt spielstand = null (moeglicheZuege spielstand) + +doTheMove :: Spielstand->Zug->Spielstand +doTheMove spielstand zug = + S neuesBrett neuerFuellstand derGegner neueWertung (anfang,zuege) + where + altesBrett,neuesBrett :: Brett + altesBrett = brettVon spielstand + alterFuellstand = fuellstandVon spielstand + drann = amZug spielstand + derGegner = gegner drann + alteWertung = wertung spielstand + neueWertung = updateWertung alteWertung altesBrett neuesBrett (zug,j) + neuesBrett=altesBrett // (((zug,j),Just drann):[]) + neuerFuellstand=alterFuellstand // ((zug,j):[]) + j=alterFuellstand!zug + 1 + (anfang,altezuege)= anfangundzuege spielstand + zuege=altezuege++(zug:[]) + +fmtwertung :: Wertung -> String +fmtwertung w = + if -5000 < w && w < 5000 + then show w + else " Matt in " ++ show (6000 - abs w) + +updateWertung :: Int -> Brett-> Brett -> (Int,Int) -> Wertung +updateWertung alteWertung altesBrett neuesBrett (i,j) + = neueWertung + where + aktiv = aktiveVierer!(i,j) + alt = sum (map (werte . map (altesBrett!)) aktiv) + neu = sum (map (werte . map (neuesBrett!)) aktiv) + + neueWertung :: Wertung + neueWertung = + if abs neu >= 5000 + then maxmin neu + else maxmin (alteWertung + neu - alt) + + maxmin x = max (min x 6000) (-6000) + w :: Int -> Int + w x = [0,1,5,50,posinfty] !! x + + werte xs = + let xsm = catMaybes xs + {- effizienter? + steine = accumArray (+) 0 (Computer, Mensch) + (map (\x->(x,1)) xsm) + computerSteine = steine ! Computer + menschSteine = steine ! Mensch + -} + computerSteine = length (filter (Computer ==) xsm) + menschSteine = length (filter (Mensch ==) xsm) + in if computerSteine>0 && menschSteine>0 + then 0 + else w computerSteine - w menschSteine + + + +aktiveVierer :: Array (Int,Int) [[(Int,Int)]] +aktiveVierer = array brettGroesse + (map (\ix -> (ix, uncurry viererVon ix)) (range brettGroesse)) + +viererVon :: Int -> Int -> [[(Int, Int)]] +viererVon i j = filter (elem (i,j)) alleVierer +alleVierer :: [[(Int,Int)]] +alleVierer = [ [(i+l*ii,j+l*jj) | l<-[0..3] ] + | (i,j) <- range brettGroesse, + (ii,jj) <- inc i j ] + where + inc i j = filter (\(ii,jj) -> + inRange brettGroesse (i+3*ii,j+3*jj)) + [(0,1),(1,-1),(1,0),(1,1)] + +grundstellung :: Spieler -> Spielstand +grundstellung x = S leeresBrett leererFuellstand x 0 (x,[]) + where + leeresBrett=listArray brettGroesse (repeat Nothing) + leererFuellstand=listArray (1,7) (repeat 0) + +-- Korrektur der Matt-Vorhersage-Zuege +bewertungsKorrektur :: Wertung->Wertung +bewertungsKorrektur w + | w > 5000 = w-1 + | w < -5000 = w+1 + | otherwise = w + +{- +Wir berechnen die Stellungsbewertung zum gegebenen Brett mit einer +vorgegebenen Tiefe einschliesslich der Zuege zu dieser Stellung. + +---------------------- +Alpha-Beta-Suche: + +Ebene 0 X +Ebene 1 A B C +Ebene 2 a b c d e ... + +wert(X)=max(A,B,C) +wert(A)=min(a,b) +wert(B)=min(c,d,e) + +Wir moechten nun den Wert von B abschaetzen. D.h. wir wollen wissen, +ob wert(B)<= wert(A) ist. Das ist bereits dann der Fall, wenn +wert(c)<=wert(A) ist. Dann brauchen wir d und e gar nicht mehr +anzusehen, denn es gilt wert(X) >= max (A, min (c,d,e)). + +Auswerten mit Schranke: + +w(A) = max (-inf, min (a,b)) +wert(B) <= w(B) = max (w(A), min (c,d,e)) +w(C) = max (W(B), min (...) + +scanl (\x,y->f(x,X)) w(A) [B,C,D] = [w(a),f(w(a),B),f(f(w(a),B),C) ...] +also: f=(\x,y-> max (x,min(kinder y))) + +---------------------- + +Weil ein Matt in 5 schlechter als ein Matt in 3 ist, muss beim +Zusammensetzen der Wertung vom Tochterknoten zum Mutterknoten u.U. eine +Bewertungskorrektur durchgefuehrt werden. + +-} + +tiefe0 :: Int +tiefe0 = 0 + +search :: Int->Spielstand->(Wertung,[Zug]) +search suchTiefe spielstand = + bewerteKnoten suchTiefe tiefe0 posinfty spielstand + + +bewerteKnoten :: Int->Int->Int->Spielstand->(Wertung,[Zug]) +bewerteKnoten suchTiefe tiefe bound spielstand + | tiefe == suchTiefe = (wertung spielstand,[]) + | istMatt spielstand = (wertung spielstand,[]) + | istPatt spielstand = (0,[]) + | tiefe < suchTiefe = bestesKind + | otherwise = error "bewerteKnoten: unmoeglicher Fall" + where + zuege1 = moeglicheZuege spielstand + kinder1= map (doTheMove spielstand) zuege1 + + -- Den jeweils besten Zug zuerst ausprobieren, dann + -- fallen viele Faelle spaeter schneller weg. + (kinder,zuege) = unzip + ((if computerAmZug spielstand + then reverse + else id) + (Key.sort (wertung . fst) (zip kinder1 zuege1))) + + godown :: Int -> Spielstand -> (Wertung,[Zug]) + godown=bewerteKnoten suchTiefe (tiefe+1) + godown1 (w,_) = godown w + + wkind1=godown newbound (head kinder) + werteKinder = scanl (godown1) wkind1 (tail kinder) + + paareWertZug = zip werteKinder zuege + bestesKind = verbinden (minmax' paareWertZug) + + (minmax,newbound) = + if computerAmZug spielstand + then (maximum,neginfty) + else (minimum,posinfty) + + + worseThan bound0 = + if computerAmZug spielstand + then bound0 + 5 + else bound0 - 5 + + rel :: Ord a => a->a->Bool + rel = + if computerAmZug spielstand + then (>) + else (<) + + minmax' paareWertZug0 = + if any (\x->rel (fst (fst x)) (bewertungsKorrektur bound)) + paareWertZug0 + then ((worseThan (bewertungsKorrektur bound),[]),0) + else minmax paareWertZug0 + + verbinden ((wert,zuege0),zug)=(bewertungsKorrektur wert,zug:zuege0) +------------------------------------------------------ + +suchTiefeGesamt :: Int +suchTiefeGesamt = 6 + +berechneSpielstand :: (Spieler,[Zug]) -> Spielstand +berechneSpielstand (erster,zuege) = + let spielstand = foldl doTheMove (grundstellung erster) zuege + in if istMatt spielstand || not (computerAmZug spielstand) + then spielstand + else doTheMove spielstand + (head $ snd (search suchTiefeGesamt spielstand)) diff --git a/src/Game/VierGewinnt/HTML.hs b/src/Game/VierGewinnt/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Game/VierGewinnt/HTML.hs @@ -0,0 +1,129 @@ +{- | Ein- und Ausgabe fuer Game.VierGewinnt getrennt von Zugberechnung -} +module Game.VierGewinnt.HTML where + +import Game.VierGewinnt + (Spieler(..), Zug, Spielstand, grundstellung, brettVon, wertung, + anfangundzuege, moeglicheZuege, berechneSpielstand, istMatt, ) +import Game.Utility (readMaybe, nullToMaybe, ) + +import Text.Html((<<), (+++), noHtml, spaceHtml, concatHtml, renderHtml, toHtml, ) +import qualified Text.Html as Html +import qualified Data.List as List +import Data.Array((!)) + +import qualified Network.CGI as CGI + + +farbe :: Maybe Spieler -> String +farbe Nothing = Html.white +farbe (Just Mensch) = Html.blue +farbe (Just Computer) = Html.red + +labelAnchor :: String -> Html.Html -> Html.Html +labelAnchor ref label = + Html.anchor label Html.! [Html.href ref] + +relHeight, relWidth :: Int -> Html.HtmlAttr +relHeight r = Html.strAttr "HEIGHT" (show r ++ "%") +relWidth r = Html.strAttr "WIDTH" (show r ++ "%") + +spielstand :: Spielstand -> Html.Html +spielstand stand = concatHtml [moeglichesEnde, table] + where + brett = brettVon stand + fmtf x = Html.td spaceHtml + Html.! [relHeight 14, Html.bgcolor (farbe x)] + + table = Html.center (Html.table (concatHtml tableContents) + Html.! [relWidth 65, relHeight 65, Html.border 2]) + tableContents = + zuege: + [Html.tr (concatHtml [fmtf (brett!(i,7-j)) | i<-[1..7]]) | + j<-[1..6]] + + moeglichesEnde = + case wertung stand of + 6000 -> Html.h2 << "Du bist matt!" + (-6000) -> Html.h2 << "Du hast gewonnen!" + _ -> noHtml + + zuege = Html.tr (concatHtml (map gencell [1..7])) + + {- + fmt [] = "<h2>Unentschieden. Nochmal?</h2>" + fmt x = show x + -} + + (anfang,altezuege)= anfangundzuege stand + color :: Zug -> String + color i = + if null altezuege || i /= last altezuege + then Html.white + else Html.yellow + + gencell :: Zug -> Html.Html + gencell i = Html.td (Html.center (href (toHtml ("Spalte " ++ show i)))) + Html.! [Html.bgcolor (color i)] + where + href s = + if elem i (moeglicheZuege stand) && not (istMatt stand) + then Html.bold (labelAnchor ("VierGewinnt?" ++ erzeugeAnfrage anfang (altezuege++[i])) s) + else s + + +komplett :: Html.Html -> Html.Html +komplett body = + Html.header (Html.thetitle << "Vier gewinnt") +++ + Html.body + (Html.h1 ("Vier-Gewinnt in " +++ + labelAnchor "http://www.haskell.org/" << "Haskell" +++ + " (" +++ labelAnchor "VierGewinnt.hs" << "Quelltext" +++ ")") +++ + body +++ + labelAnchor "VierGewinnt" (Html.h2 << "Neues Spiel?") +++ + Html.hr +++ + labelAnchor "http://www.mathematik.uni-halle.de/~wensch" << "JW" +++ + ", " +++ + labelAnchor "http://www.mathematik.uni-halle.de/~podhaisky" << "HP") + + +-- Maybe String wird gebraucht um zwischen "?" und "" zu unterscheiden +erzeuge :: Maybe String -> Html.Html +erzeuge = + maybe + (concatHtml + [Html.h2 << "Wer f\228ngt an?", + (labelAnchor ("VierGewinnt?" ++ erzeugeAnfrage Computer []) << "Der Computer"), + Html.h2 << "Nein, ich. Ich nehme:", + spielstand (grundstellung Mensch)]) + (\s -> + case interpretiereAnfrage s of + Just stand -> spielstand (berechneSpielstand stand) + Nothing -> toHtml $ "Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen.") + +erzeugeAnfrage :: Spieler -> [Zug] -> String +erzeugeAnfrage spieler zuege = + CGI.formEncode $ + ("start", show spieler) : + (if null zuege then [] else [("zuege", unwords $ map show zuege)]) ++ + [] + +interpretiereAnfrage :: String -> Maybe (Spieler, [Zug]) +interpretiereAnfrage anfrage = + let paare = CGI.formDecode anfrage + in do anfangText <- List.lookup "start" paare + anfang <- readMaybe anfangText + zuege <- + case List.lookup "zuege" paare of + Nothing -> Just [] + Just zuegeText -> + mapM (\zugText -> + case zugText of + [_] -> readMaybe zugText + _ -> Nothing) $ + words zuegeText + return (anfang, zuege) + + +main :: IO () +main = + putStr . renderHtml . komplett . erzeuge . nullToMaybe =<< getLine diff --git a/src/Game/VierGewinnt/Text.hs b/src/Game/VierGewinnt/Text.hs new file mode 100644 --- /dev/null +++ b/src/Game/VierGewinnt/Text.hs @@ -0,0 +1,37 @@ +module Game.VierGewinnt.Text where + +import Game.VierGewinnt + (Spieler(..), Zug, Spielstand, brettVon, + anfangundzuege, berechneSpielstand, ) + +import Data.Array((!)) + + +symbol :: Maybe Spieler -> Char +symbol Nothing = ' ' +symbol (Just Mensch) = '@' +symbol (Just Computer) = '+' + +--- ASCII-dump +spielstand :: Spielstand -> String +spielstand stand = + show (anfangundzuege stand) ++ "\n" ++ + concatMap (++"|\n") (concat ([ + [ruler,line (7-j),nline (7-j)] | j<-[1..6] ])++[nruler]) + where + brett = brettVon stand + ruler, nruler :: String + line, nline :: Int-> String + ruler = " "++ concat (replicate 7 ("|-----")) + nruler = " "++ concatMap (\i->"|--"++show i++"--") [1..(7::Int)] + line j = " "++ concatMap (\i->"|" ++ + replicate 5 (symbol (brett!(i,j)))) [1..7] + nline j = show j ++ tail (line j) + +-- We may use a custom Spielstand datatype in order to avoid the orphan instance +instance Show Spielstand where + show = spielstand + + +spiel :: (Spieler,[Zug]) -> String +spiel = spielstand . berechneSpielstand diff --git a/src/Game/ZeilenSpalten.hs b/src/Game/ZeilenSpalten.hs new file mode 100644 --- /dev/null +++ b/src/Game/ZeilenSpalten.hs @@ -0,0 +1,180 @@ +module Game.ZeilenSpalten where + +{- + Benutzung in GHCi: + Game.ZeilenSpalten> spiel (5,5) 123 Spalte [0,1,2] +-} + +import qualified Game.Tree as GameTree + +import Data.Array (Array, Ix, range, rangeSize, bounds, listArray, (!), (//), ) +import Data.Maybe (isNothing, ) +import Data.List (intersperse, unfoldr, ) +import System.Random (mkStdGen, randomR, randomRs, ) + + +type Zahlenfeld = Array (Koordinate,Koordinate) Zahl +type Spielfeld = Array (Koordinate,Koordinate) (Maybe Spieler) +type Zahl = Int +type Punkte = Int +type Zug = Int +type Koordinate = Int + +data Spielstand = S + {punkte :: (Punkte, Punkte), + amZug :: Spieler, + koordinate :: Koordinate, + zahlenfeld :: Zahlenfeld, + spielfeld :: Spielfeld} + +data Spieler = + Spalte + | Zeile + deriving (Show,Read,Eq,Ord,Ix) + +spielfeldSymbol :: Maybe Spieler -> Char +spielfeldSymbol = maybe ' ' spielerSymbol + +spielerSymbol :: Spieler -> Char +spielerSymbol Spalte = '+' +spielerSymbol Zeile = '@' + +gegner :: Spieler -> Spieler +gegner Zeile = Spalte +gegner Spalte = Zeile + +punkteDifferenz :: Spielstand -> Punkte +punkteDifferenz s = + uncurry (-) (punkte s) + + +moeglicheZuege :: Spielstand -> [(Zug, Spielstand)] +moeglicheZuege s = + let k = koordinate s + y = spielfeld s + z = zahlenfeld s + p = punkte s + dran = amZug s + ((i0,j0),(i1,j1)) = bounds z + zuege = + case dran of + Spalte -> filter (isNothing . (y!) . (\j->(k,j))) [j0..j1] + Zeile -> filter (isNothing . (y!) . (\i->(i,k))) [i0..i1] + poss = + case dran of + Spalte -> map (\j -> (k,j)) zuege + Zeile -> map (\i -> (i,k)) zuege + pneu (pspalte,pzeile) d = + case dran of + Spalte -> (pspalte + d, pzeile) + Zeile -> (pspalte, pzeile + d) + spielstandNeu zug pos = + (zug, S (pneu p (z!pos)) (gegner dran) zug + z (y//[(pos, Just dran)])) + in zipWith spielstandNeu zuege poss + +grundstellung :: (Koordinate,Koordinate) -> Int -> Spieler -> Spielstand +grundstellung (breite,hoehe) saat beginner = + let groesse = ((0,0),(breite-1,hoehe-1)) + g = mkStdGen saat + kgrenze = case beginner of + Zeile -> hoehe + Spalte -> breite + (k,g') = randomR (0,kgrenze-1) g + in S (0,0) + beginner + k + (listArray groesse (randomRs (0,9) g')) + (listArray groesse (repeat Nothing)) + +spielstandZuText :: Spielstand -> String +spielstandZuText s = + let z = zahlenfeld s + y = spielfeld s + aktiv = koordinate s + ((i0,j0),(i1,j1)) = bounds z + symbol (i,j) = + maybe (if (case amZug s of + Spalte -> i == aktiv + Zeile -> j == aktiv) + then '?' else ' ') + spielerSymbol (y!(i,j)) + in unlines ( + concat (" " : intersperse " " (map show (range (i0,i1)))) : + concat (" +" : replicate (rangeSize (i0,i1)) "---") : + map (\j -> + show j ++ " | " ++ + unwords (map (\i -> show (z!(i,j)) ++ [symbol (i,j)]) + [i0..i1])) [j0..j1] ++ + ["Punkte (Spalter, Zeiler): " ++ show (punkte s) ++ + ", Differenz: " ++ show (punkteDifferenz s)]) + +instance Show Spielstand where + show = spielstandZuText + +{- Computer spielt begonnene Party für beide Seiten optimal zu Ende -} +optimalesSpiel :: (Koordinate,Koordinate) -> Int -> Spieler -> [Zug] -> [Zug] +optimalesSpiel groesse saat beginner zuege = + let spielbaum = + GameTree.selectDeepSubTree zuege + (GameTree.build moeglicheZuege + (grundstellung groesse saat beginner)) + in unfoldr (\s -> fmap (\zug -> (zug, GameTree.selectSubTree zug s)) + (optimalerZug s)) + spielbaum + +optimalerZug :: GameTree.T Zug Spielstand -> Maybe Zug +optimalerZug spielaktuell = + let spielstand = GameTree.state spielaktuell + besterZug = + if True -- schnell oder nicht + then case amZug spielstand of + Spalte -> GameTree.maximumMoveFast + Zeile -> GameTree.minimumMoveFast + else case amZug spielstand of + Spalte -> GameTree.maximumMove + Zeile -> GameTree.minimumMove + in if null (GameTree.subTrees spielaktuell) + then Nothing + else Just (besterZug (-- GameTree.pruneVolume 100000 + GameTree.pruneDepth 4 + {- bewerte Knoten für sofortiges Ende höher, + dadurch wird Gegner-K.O. forciert, + aber eigenes K.O. eher abgewendet. -} + (GameTree.mapNodesLeaves id (5*) + -- (GameTree.mapNodesLeaves id id + {- Wir wollen Zugfolge, die unseren Vorsprung maximiert. -} + (fmap (uncurry (-) . punkte) spielaktuell)))) + {- Wir wollen Zugfolge mit den meisten Punkten für uns. + Unter allen Folgen mit gleicher Punktzahl für uns, + gönnen wir dem Gegner die wenigsten. -} + -- (fmap ((\(ps,pz) -> (ps,-pz)) . punkte) spielaktuell)))) + + +berechneSpielstandUndZug :: + (Koordinate,Koordinate) -> Int -> Spieler -> [Zug] -> (Spielstand, Maybe Zug) +berechneSpielstandUndZug groesse saat beginner zuege = + let spielbaum = + GameTree.build moeglicheZuege + (grundstellung groesse saat beginner) + spielaktuell = + GameTree.selectDeepSubTree zuege spielbaum + spielstand = GameTree.state spielaktuell + in (spielstand, optimalerZug spielaktuell) + + +spielZuText :: (Koordinate,Koordinate) -> Int -> Spieler -> [Zug] -> String +spielZuText groesse saat beginner zuege = + let (spielstand, optZug) = + berechneSpielstandUndZug groesse saat beginner zuege + zugvorschlag = + maybe "Nix geht mehr." + (\zug -> "Zugvorschlag f\252r " ++ show (amZug spielstand) ++ "r: " ++ + show zug) + optZug + in spielstandZuText spielstand + ++ zugvorschlag ++ "\n" + +spiel :: (Koordinate,Koordinate) -> Int -> Spieler -> [Zug] -> IO () +spiel groesse saat beginner zuege = + putStr (spielZuText groesse saat beginner zuege) diff --git a/src/Game/ZeilenSpalten/HTML.hs b/src/Game/ZeilenSpalten/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Game/ZeilenSpalten/HTML.hs @@ -0,0 +1,168 @@ +{- | Ein- und Ausgabe fuer Game.ZeilenSpalten getrennt von Zugberechnung -} +module Game.ZeilenSpalten.HTML where + +import Game.ZeilenSpalten hiding (spiel) +import qualified Game.Tree as GameTree +import Game.Utility (readMaybe, nullToMaybe, ) + +import Text.Html((<<), (+++), concatHtml, toHtml) +import qualified Text.Html as Html + +import qualified Network.CGI as CGI + +import qualified Data.List as List +import Data.Array ((!), bounds, ) +import Data.Maybe (maybeToList, isNothing, ) +import Control.Monad (guard, ) +import System.Random (randomIO, ) + + +spielfeldFarbe :: Maybe Spieler -> String +spielfeldFarbe = maybe Html.white spielerFarbe + +spielerFarbe :: Spieler -> String +spielerFarbe Zeile = Html.blue +spielerFarbe Spalte = Html.red + +labelAnchor :: String -> Html.Html -> Html.Html +labelAnchor ref label = + Html.anchor label Html.! [Html.href ref] + +relHeight, relWidth :: Int -> Html.HtmlAttr +relHeight r = Html.strAttr "HEIGHT" (show r ++ "%") +relWidth r = Html.strAttr "WIDTH" (show r ++ "%") + +type Beschreibung = ((Koordinate,Koordinate), Int, Spieler, Bool, [Zug]) + +spielstand :: Beschreibung -> Spielstand -> Html.Html +spielstand (groesse, saat, beginner, _, zuege) s = + let z = zahlenfeld s + y = spielfeld s + (ps,pz) = punkte s + aktiv = koordinate s + ((i0,j0),(i1,j1)) = bounds z + aktivesFeld (i,j) = variableKoordinate (j,i) == aktiv + variableKoordinate (i,j) = + case amZug s of + Spalte -> j + Zeile -> i + anc ij = + labelAnchor ("ZeilenSpalten?" ++ + erzeugeAnfrage + (groesse, saat, beginner, True, + zuege ++ [variableKoordinate ij])) + farbe grund ij = + maybe grund spielerFarbe (y!ij) + feld = + Html.table + (concatHtml $ map (\j -> Html.tr + (concatHtml $ map (\i -> + let ij = (i,j) + af = aktivesFeld ij + fb = if af then Html.yellow else Html.white + canc = if af && isNothing (y!ij) then anc ij else id + zahl = toHtml (show (z!ij)) + in Html.td (canc zahl) + Html.! [Html.bgcolor (farbe fb ij)]) + [i0..i1])) + [j0..j1]) + Html.! [Html.border 2] + in Html.center + (Html.simpleTable [] [{-Html.valign "top"-}] + [[toHtml ("Spalter: " ++ show ps), + feld, + toHtml ("Zeiler: " ++ show pz)]]) + + +-- umständlich, weil Spielfeld zweimal aufgebaut wird +spiel' :: String -> Html.Html +spiel' s = + let (groesse, saat, beginner, macheGegenzug, zuege) = read s + (_,computerZug) = berechneSpielstandUndZug groesse saat beginner zuege + zuegeMitComputer = zuege ++ maybeToList computerZug + (stand,_) = + berechneSpielstandUndZug groesse saat beginner zuegeMitComputer + in Html.center (spielstand + (groesse, saat, beginner, macheGegenzug, zuegeMitComputer) stand) + +spiel :: String -> Html.Html +spiel s = + case interpretiereAnfrage s of + Just (groesse, saat, beginner, macheGegenzug, zuege) -> + let spielbaum = + GameTree.build moeglicheZuege + (grundstellung groesse saat beginner) + spielaktuell = + GameTree.selectDeepSubTree zuege spielbaum + optZug = optimalerZug spielaktuell + (spielunterbaum,zuegeMitComputer) = + maybe + (spielaktuell, zuege) + (\zug -> (GameTree.selectSubTree zug spielaktuell, zuege++[zug])) + (guard macheGegenzug >> optZug) + stand = GameTree.state spielunterbaum + in spielstand + (groesse, saat, beginner, macheGegenzug, zuegeMitComputer) stand + Nothing -> + toHtml $ "Mit dem Spielstand " ++ show s ++ " kann ich nichts anfangen." + +start :: Int -> Html.Html +start saat = + toHtml "Es beginnt" +++ + Html.simpleTable [] [] + (map (\orient -> + map (\(gegenzug,spieler) -> + labelAnchor + ("ZeilenSpalten?"++ + erzeugeAnfrage ((10,10),saat,orient,gegenzug,[])) + << ("der "++spieler++" auf einer "++show orient++".")) + [(False,"Mensch"),(True,"Computer")]) + [Spalte,Zeile]) Html.! [Html.border 2] + + +komplett :: Html.Html -> Html.Html +komplett body = + Html.header (Html.thetitle << "Zeilen und Spalten") +++ + Html.body body +++ + Html.br +++ labelAnchor "ZeilenSpalten" << "Nochmal von vorne!" + +-- Maybe String wird gebraucht um zwischen "?" und "" zu unterscheiden +erzeuge :: Maybe String -> IO Html.Html +erzeuge = + maybe (fmap start randomIO) (return . spiel) + + +erzeugeAnfrage :: Beschreibung -> String +erzeugeAnfrage ((breite,hoehe),saat,orient,gegenzug,zuege) = + CGI.formEncode $ + ("breite", show breite) : + ("hoehe", show hoehe) : + ("saat", show saat) : + ("orient", show orient) : + ("gegenzug", show gegenzug) : + (if null zuege then [] else [("zuege", unwords $ map show zuege)]) ++ + [] + +interpretiereAnfrage :: String -> Maybe Beschreibung +interpretiereAnfrage anfrage = + let paare = CGI.formDecode anfrage + in do breite <- readMaybe =<< List.lookup "breite" paare + hoehe <- readMaybe =<< List.lookup "hoehe" paare + saat <- readMaybe =<< List.lookup "saat" paare + orient <- readMaybe =<< List.lookup "orient" paare + gegenzug <- readMaybe =<< List.lookup "gegenzug" paare + zuege <- + case List.lookup "zuege" paare of + Nothing -> Just [] + Just zuegeText -> + mapM (\zugText -> + case zugText of + _:_:_:_ -> Nothing + _ -> readMaybe zugText) $ + words zuegeText + return ((breite,hoehe), saat, orient, gegenzug, zuege) + + +main :: IO () +main = + putStr . Html.renderHtml . komplett =<< erzeuge . nullToMaybe =<< getLine