diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 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 Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are 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. + + 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. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + 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 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 work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero 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 Affero 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 Affero 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 Affero 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 Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + 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 AGPL, see +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,19 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +import Distribution.Simple +main = defaultMain diff --git a/goatee.cabal b/goatee.cabal new file mode 100644 --- /dev/null +++ b/goatee.cabal @@ -0,0 +1,94 @@ +name: goatee +version: 0.1.0 +synopsis: A monadic take on a 2,500-year-old board game - library. +category: Game +license: AGPL-3 +license-file: LICENSE +copyright: Copyright 2014 Bryan Gardiner +author: Bryan Gardiner +maintainer: Bryan Gardiner +homepage: http://khumba.net/projects/goatee +bug-reports: https://savannah.nongnu.org/projects/goatee/ +tested-with: GHC +cabal-version: >=1.8 +build-type: Simple +data-files: LICENSE +description: + Goatee is a Go library and game editor, written in Haskell. It provides a GUI + for recording, studying, and editing game records. Underneath this is a + portable library for manipulating SGF files, to build UIs and tools. + . + Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF + spec and allowing for full customization of the game records you create. + Currently it is in an alpha stage, supporting basic game viewing and editing. + . + This package is the shared library. + +source-repository head + type: git + location: git://git.savannah.gnu.org/goatee.git + +library + build-depends: + base >= 4 && < 5, + containers >= 0.4 && < 0.6, + mtl >= 2.1 && < 2.3, + parsec >= 3.1 && < 3.2, + template-haskell >= 2.7 && < 2.9 + exposed-modules: + Game.Goatee.App + Game.Goatee.Common + Game.Goatee.Sgf.Board + Game.Goatee.Sgf.Monad + Game.Goatee.Sgf.Parser + Game.Goatee.Sgf.Property + Game.Goatee.Sgf.Property.Parser + Game.Goatee.Sgf.Renderer + Game.Goatee.Sgf.Renderer.Tree + Game.Goatee.Sgf.Tree + Game.Goatee.Sgf.Types + extensions: + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + MultiParamTypeClasses + UndecidableInstances + ghc-options: -W -fwarn-incomplete-patterns + hs-source-dirs: src + other-modules: + Game.Goatee.Sgf.Property.Base + Game.Goatee.Sgf.Property.Info + Game.Goatee.Sgf.Property.Renderer + Game.Goatee.Sgf.Property.Value + Paths_goatee + +test-suite test-goatee + build-depends: + base >= 4 && < 5, + containers >= 0.4 && < 0.6, + goatee, + HUnit >= 1.2 && < 1.3, + mtl >= 2.1 && < 2.3, + parsec >= 3.1 && < 3.2, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4 + ghc-options: -W -fwarn-incomplete-patterns + hs-source-dirs: tests + main-is: Test.hs + other-modules: + Game.Goatee.CommonTest + Game.Goatee.Sgf.BoardTest + Game.Goatee.Sgf.MonadTest + Game.Goatee.Sgf.ParserTest + Game.Goatee.Sgf.ParserTestUtils + Game.Goatee.Sgf.Property.ParserTest + Game.Goatee.Sgf.PropertyTest + Game.Goatee.Sgf.RoundTripTest + Game.Goatee.Sgf.TestInstances + Game.Goatee.Sgf.TestUtils + Game.Goatee.Sgf.TreeTest + Game.Goatee.Sgf.TypesTest + Game.Goatee.Test.Common + Test + type: exitcode-stdio-1.0 diff --git a/src/Game/Goatee/App.hs b/src/Game/Goatee/App.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/App.hs @@ -0,0 +1,40 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Properties of Goatee the application. +module Game.Goatee.App ( + applicationName, + applicationCopyright, + applicationWebsite, + applicationAuthors, + ) where + +-- | A string containing the name of this application, @\"Goatee\"@. +applicationName :: String +applicationName = "Goatee" + +-- | A user-presentable copyright message. +applicationCopyright :: String +applicationCopyright = "Copyright 2014 Bryan Gardiner" + +-- | The home page for Goatee on the web. +applicationWebsite :: String +applicationWebsite = "http://khumba.net/projects/goatee" + +-- | A list of contributors to Goatee. +applicationAuthors :: [String] +applicationAuthors = ["Bryan Gardiner "] diff --git a/src/Game/Goatee/Common.hs b/src/Game/Goatee/Common.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Common.hs @@ -0,0 +1,160 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Common utilities used throughout the project. +module Game.Goatee.Common ( + listDeleteIndex, + listReplace, + listUpdate, + fromLeft, + fromRight, + onLeft, + onRight, + andEithers, + for, + mapTuple, + whenMaybe, + cond, + if', + andM, + forIndexM_, + whileM, + whileM', + doWhileM, + Seq(..), + ) where + +import Control.Arrow ((***)) +import Control.Monad (forM_, join, when) +import Data.Either (partitionEithers) +import Data.Monoid (Monoid, mempty, mappend) + +-- | Drops the element at an index from a list. If the index is out of bounds +-- then the list is returned unmodified. +listDeleteIndex :: Int -> [a] -> [a] +listDeleteIndex index list = take index list ++ drop (index + 1) list + +-- | @listReplace old new list@ replaces all occurrences of @old@ with @new@ in +-- @list@. +listReplace :: Eq a => a -> a -> [a] -> [a] +listReplace from to = map $ replace from to + where replace from to x = if x == from then to else x + +-- | Modifies the element at a specific index in a list. +listUpdate :: Show a => (a -> a) -> Int -> [a] -> [a] +listUpdate fn ix xs = listSet' ix xs + where listSet' 0 (x':xs') = fn x':xs' + listSet' ix' (x':xs') = x':listSet' (ix' - 1) xs' + listSet' _ _ = error ("Cannot update index " ++ show ix ++ + " of list " ++ show xs ++ ".") + +-- | Extracts a left value from an 'Either'. +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "fromLeft given a Right." + +-- | Extracts a right value from an 'Either'. +fromRight :: Either a b -> b +fromRight (Right b) = b +fromRight _ = error "fromRight given a Left." + +-- | Transforms the left value of an 'Either', leaving a right value alone. +onLeft :: (a -> c) -> Either a b -> Either c b +f `onLeft` e = case e of + Left x -> Left $ f x + Right y -> Right y + +-- | Transforms the right value of an 'Either', leaving a left value alone. +-- This is just 'fmap', but looks nicer when used beside 'onLeft'. +onRight :: (b -> c) -> Either a b -> Either a c +onRight = fmap + +-- | If any item is a 'Left', then the list of 'Left's is returned, otherwise +-- the list of 'Right's is returned. +andEithers :: [Either a b] -> Either [a] [b] +andEithers xs = let (as, bs) = partitionEithers xs + in if not $ null as then Left as else Right bs + +-- | @for@ is @flip map@. +for :: [a] -> (a -> b) -> [b] +for = flip map + +-- | Transforms both values in a homogeneous tuple. +mapTuple :: (a -> b) -> (a, a) -> (b, b) +mapTuple = join (***) + +-- | Executes the monadic function if a 'Maybe' contains a value. +whenMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () +whenMaybe = flip $ maybe (return ()) + +-- | Finds the first tuple whose first element is true, and returns its second +-- element. If all of the first values are false, then the first argument to +-- @cond@ is returned instead. +cond :: a -> [(Bool, a)] -> a +cond fallback ((test, body):rest) = if test then body else cond fallback rest +cond fallback _ = fallback + +-- | A function form of @if@ that takes its test last. +if' :: a -> a -> Bool -> a +if' true false test = if test then true else false + +-- | 'and' in a monad. Executes the actions in the list in order. If any +-- action returns false then the remaining actions are skipped and the result is +-- false. Otherwise all actions returned true, and the result is true. An +-- empty list returns true. +andM :: Monad m => [m Bool] -> m Bool +andM (x:xs) = x >>= if' (andM xs) (return False) +andM _ = return True + +-- | 'forM_' that also passes in the index of each element. +forIndexM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m () +forIndexM_ list = forM_ (zip [0..] list) . uncurry + +-- | @whileM test body@ repeatedly evaluates @test@ until it returns false. +-- Every time @test@ returns true, @body@ is executed once. +whileM :: Monad m => m Bool -> m () -> m () +whileM test body = do x <- test + when x $ body >> whileM test body + +-- | @whileM' test body@ repeatedly evaluates @test@ until it returns 'Nothing'. +-- Every time it returns a 'Just', that value is passed to @body@ and the result +-- is executed. +whileM' :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +whileM' test body = do x <- test + case x of + Nothing -> return () + Just y -> body y >> whileM' test body + +-- | @doWhileM init body@ repeatedly calls @body@ with @init@. As long as +-- @body@ returns a @Right@ value, it is re-executed with the returned value. +-- When it returns a @Left@ value, the loop stops and the value is returned. +doWhileM :: Monad m => a -> (a -> m (Either b a)) -> m b +doWhileM init body = do + value <- body init + case value of + Right next -> doWhileM next body + Left end -> return end + +-- | This sequences @()@-valued monadic actions as a monoid. If @m@ is some +-- monad, then @Seq m@ is a monoid where 'mempty' does nothing and 'mappend' +-- sequences actions via '>>'. +newtype Seq m = Seq (m ()) + +instance Monad m => Monoid (Seq m) where + mempty = Seq $ return () + + (Seq x) `mappend` (Seq y) = Seq (x >> y) diff --git a/src/Game/Goatee/Sgf/Board.hs b/src/Game/Goatee/Sgf/Board.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Board.hs @@ -0,0 +1,792 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Data structures that wrap and provide a higher-level interface to the SGF +-- game tree, including a zipper that navigates the tree and provides the +-- current board state. +module Game.Goatee.Sgf.Board ( + RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode, + gameInfoToProperties, + BoardState(..), boardWidth, boardHeight, + CoordState(..), rootBoardState, boardCoordState, mapBoardCoords, + isValidMove, isCurrentValidMove, + Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren, + cursorChildCount, cursorChildPlayingAt, cursorProperties, + cursorModifyNode, + cursorVariations, + colorToMove, + ) where + +import Control.Monad (unless, when) +import Control.Monad.Writer (execWriter, tell) +import Data.List (find, intercalate, nub) +import Data.Maybe (fromMaybe, isJust, isNothing) +import qualified Data.Set as Set +import Game.Goatee.Common +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types + +-- TODO Stop using errors everywhere, they're not testable. + +-- | Properties that are specified in the root nodes of game trees. +data RootInfo = RootInfo { rootInfoWidth :: Int + , rootInfoHeight :: Int + , rootInfoVariationMode :: VariationMode + } deriving (Eq, Show) + +-- | Properties that are specified in game info nodes. +data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo + + , gameInfoBlackName :: Maybe String + , gameInfoBlackTeamName :: Maybe String + , gameInfoBlackRank :: Maybe String + + , gameInfoWhiteName :: Maybe String + , gameInfoWhiteTeamName :: Maybe String + , gameInfoWhiteRank :: Maybe String + + , gameInfoRuleset :: Maybe Ruleset + , gameInfoBasicTimeSeconds :: Maybe Rational + , gameInfoOvertime :: Maybe String + , gameInfoResult :: Maybe GameResult + + , gameInfoGameName :: Maybe String + , gameInfoGameComment :: Maybe String + , gameInfoOpeningComment :: Maybe String + + , gameInfoEvent :: Maybe String + , gameInfoRound :: Maybe String + , gameInfoPlace :: Maybe String + , gameInfoDatesPlayed :: Maybe String + , gameInfoSource :: Maybe String + , gameInfoCopyright :: Maybe String + + , gameInfoAnnotatorName :: Maybe String + , gameInfoEntererName :: Maybe String + } deriving (Show) + +-- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data. +emptyGameInfo :: RootInfo -> GameInfo +emptyGameInfo rootInfo = + GameInfo { gameInfoRootInfo = rootInfo + + , gameInfoBlackName = Nothing + , gameInfoBlackTeamName = Nothing + , gameInfoBlackRank = Nothing + + , gameInfoWhiteName = Nothing + , gameInfoWhiteTeamName = Nothing + , gameInfoWhiteRank = Nothing + + , gameInfoRuleset = Nothing + , gameInfoBasicTimeSeconds = Nothing + , gameInfoOvertime = Nothing + , gameInfoResult = Nothing + + , gameInfoGameName = Nothing + , gameInfoGameComment = Nothing + , gameInfoOpeningComment = Nothing + + , gameInfoEvent = Nothing + , gameInfoRound = Nothing + , gameInfoPlace = Nothing + , gameInfoDatesPlayed = Nothing + , gameInfoSource = Nothing + , gameInfoCopyright = Nothing + + , gameInfoAnnotatorName = Nothing + , gameInfoEntererName = Nothing + } + +-- | Returns whether a node contains any game info properties. +internalIsGameInfoNode :: Node -> Bool +internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties + +-- | Converts a 'GameInfo' into a list of 'Property's that can be used to +-- reconstruct the 'GameInfo'. +gameInfoToProperties :: GameInfo -> [Property] +gameInfoToProperties info = execWriter $ do + copy (PB . toSimpleText) gameInfoBlackName + copy (BT . toSimpleText) gameInfoBlackTeamName + copy (BR . toSimpleText) gameInfoBlackRank + + copy (PW . toSimpleText) gameInfoWhiteName + copy (WT . toSimpleText) gameInfoWhiteTeamName + copy (WR . toSimpleText) gameInfoWhiteRank + + copy RU gameInfoRuleset + copy TM gameInfoBasicTimeSeconds + copy (OT . toSimpleText) gameInfoOvertime + copy RE gameInfoResult + + copy (GN . toSimpleText) gameInfoGameName + copy (GC . toSimpleText) gameInfoGameComment + copy (ON . toSimpleText) gameInfoOpeningComment + + copy (EV . toSimpleText) gameInfoEvent + copy (RO . toSimpleText) gameInfoRound + copy (PC . toSimpleText) gameInfoPlace + copy (DT . toSimpleText) gameInfoDatesPlayed + copy (SO . toSimpleText) gameInfoSource + copy (CP . toSimpleText) gameInfoCopyright + + copy (AN . toSimpleText) gameInfoAnnotatorName + copy (US . toSimpleText) gameInfoEntererName + where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x] + +-- | An object that corresponds to a node in some game tree, and represents the +-- state of the game at that node, including board position, player turn and +-- captures, and also board annotations. +data BoardState = BoardState { + boardCoordStates :: [[CoordState]] + -- ^ The state of individual points on the board. Stored in row-major order. + -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer + -- 'boardCoordState'). + , boardHasInvisible :: Bool + -- ^ Whether any of the board's 'CoordState's are invisible. This is an + -- optimization to make it more efficient to set the board to "all visible." + , boardHasDimmed :: Bool + -- ^ Whether any of the board's 'CoordState's are dimmed. This is an + -- optimization to make it more efficient to clear all dimming from the + -- board. + , boardArrows :: ArrowList + , boardLines :: LineList + , boardLabels :: LabelList + , boardMoveNumber :: Integer + , boardPlayerTurn :: Color + , boardBlackCaptures :: Int + , boardWhiteCaptures :: Int + , boardGameInfo :: GameInfo + } + +instance Show BoardState where + show board = concat $ execWriter $ do + tell ["Board: (Move ", show (boardMoveNumber board), + ", ", show (boardPlayerTurn board), "'s turn, B:", + show (boardBlackCaptures board), ", W:", + show (boardWhiteCaptures board), ")\n"] + tell [intercalate "\n" $ flip map (boardCoordStates board) $ + \row -> unwords $ map show row] + + let arrows = boardArrows board + let lines = boardLines board + let labels = boardLabels board + unless (null arrows) $ tell ["\nArrows: ", show arrows] + unless (null lines) $ tell ["\nLines: ", show lines] + unless (null labels) $ tell ["\nLabels: ", show labels] + +-- | Returns the width of the board, in stones. +boardWidth :: BoardState -> Int +boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo + +-- | Returns the height of the board, in stones. +boardHeight :: BoardState -> Int +boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo + +-- | Used by 'BoardState' to represent the state of a single point on the board. +-- Records whether a stone is present, as well as annotations and visibility +-- properties. +data CoordState = CoordState { coordStar :: Bool + -- ^ Whether this point is a star point. + , coordStone :: Maybe Color + , coordMark :: Maybe Mark + , coordVisible :: Bool + , coordDimmed :: Bool + } + +instance Show CoordState where + show c = if not $ coordVisible c + then "--" + else let stoneChar = case coordStone c of + Nothing -> if coordStar c then '*' else '\'' + Just Black -> 'X' + Just White -> 'O' + markChar = case coordMark c of + Nothing -> ' ' + Just MarkCircle -> 'o' + Just MarkSquare -> 's' + Just MarkTriangle -> 'v' + Just MarkX -> 'x' + Just MarkSelected -> '!' + in [stoneChar, markChar] + +-- | Creates a 'BoardState' for an empty board of the given width and height. +emptyBoardState :: Int -> Int -> BoardState +emptyBoardState width height = + BoardState { boardCoordStates = coords + , boardHasInvisible = False + , boardHasDimmed = False + , boardArrows = [] + , boardLines = [] + , boardLabels = [] + , boardMoveNumber = 0 + , boardPlayerTurn = Black + , boardBlackCaptures = 0 + , boardWhiteCaptures = 0 + , boardGameInfo = emptyGameInfo rootInfo + } + where rootInfo = RootInfo { rootInfoWidth = width + , rootInfoHeight = height + , rootInfoVariationMode = defaultVariationMode + } + emptyCoord = CoordState { coordStar = False + , coordStone = Nothing + , coordMark = Nothing + , coordVisible = True + , coordDimmed = False + } + starCoord = emptyCoord { coordStar = True } + isStarPoint' = isStarPoint width height + coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord) + [0..width-1]) + [0..height-1] + +rootBoardState :: Node -> BoardState +rootBoardState rootNode = + foldr applyProperty + (emptyBoardState width height) + (nodeProperties rootNode) + where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ + findProperty propertySZ rootNode + +-- | Returns the 'CoordState' for a coordinate on a board. +boardCoordState :: Coord -> BoardState -> CoordState +boardCoordState (x, y) board = boardCoordStates board !! y !! x + +-- | Maps a function over each 'CoordState' in a 'BoardState', returning a +-- list-of-lists with the function's values. The function is called like @fn y +-- x coordState@. +mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]] +mapBoardCoords fn board = + zipWith applyRow [0..] $ boardCoordStates board + where applyRow y = zipWith (fn y) [0..] + +-- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a +-- 'BoardState'. +updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState +updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo -> + gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo } + +-- | Applies a function to update the 'GameInfo' of a 'BoardState'. +updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState +updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board } + +-- | Performs necessary updates to a 'BoardState' between nodes in the tree. +-- Clears marks. +boardChild :: BoardState -> BoardState +boardChild board = + board { boardCoordStates = map (map clearMark) $ boardCoordStates board + , boardArrows = [] + , boardLines = [] + , boardLabels = [] + } + where clearMark coord = case coordMark coord of + Nothing -> coord + Just _ -> coord { coordMark = Nothing } + +-- | Sets all points on a board to be visible (if given true) or invisible (if +-- given false). +setBoardVisible :: Bool -> BoardState -> BoardState +setBoardVisible visible board = + if visible + then if boardHasInvisible board + then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board + , boardHasInvisible = False + } + else board + else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board + , boardHasInvisible = True + } + where setVisible vis coord = coord { coordVisible = vis } + +-- | Resets all points on a board not to be dimmed. +clearBoardDimmed :: BoardState -> BoardState +clearBoardDimmed board = + if boardHasDimmed board + then board { boardCoordStates = map (map clearDim) $ boardCoordStates board + , boardHasDimmed = False + } + else board + where clearDim coord = coord { coordDimmed = False } + +-- |> isStarPoint width height x y +-- +-- Returns whether @(x, y)@ is a known star point on a board of the given width +-- and height. +isStarPoint :: Int -> Int -> Int -> Int -> Bool +isStarPoint width height + | width == 9 && height == 9 = isStarPoint9 + | width == 13 && height == 13 = isStarPoint13 + | width == 19 && height == 19 = isStarPoint19 + | otherwise = const $ const False + +isStarPoint' :: [Int] -> Int -> Int -> Bool +isStarPoint' ixs x y = x `elem` ixs && y `elem` ixs + +isStarPoint9, isStarPoint13, isStarPoint19 :: Int -> Int -> Bool +isStarPoint9 = isStarPoint' [2, 4, 6] +isStarPoint13 = isStarPoint' [3, 6, 9] +isStarPoint19 = isStarPoint' [3, 9, 15] + +-- | Applies a property to a 'BoardState'. This function covers all properties +-- that modify 'BoardState's, including making moves, adding markup, and so on. +applyProperty :: Property -> BoardState -> BoardState + +applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of + Nothing -> board -- Pass. + Just xy -> getApplyMoveResult board $ + applyMove playTheDarnMoveGoParams Black xy board +applyProperty KO board = board +applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum } +applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of + Nothing -> board -- Pass. + Just xy -> getApplyMoveResult board $ + applyMove playTheDarnMoveGoParams White xy board + +applyProperty (AB coords) board = + updateCoordStates' (\state -> state { coordStone = Just Black }) coords board +applyProperty (AW coords) board = + updateCoordStates' (\state -> state { coordStone = Just White }) coords board +applyProperty (AE coords) board = + updateCoordStates' (\state -> state { coordStone = Nothing }) coords board +applyProperty (PL color) board = board { boardPlayerTurn = color } + +applyProperty (C {}) board = board +applyProperty (DM {}) board = board +applyProperty (GB {}) board = board +applyProperty (GW {}) board = board +applyProperty (HO {}) board = board +applyProperty (N {}) board = board +applyProperty (UC {}) board = board +applyProperty (V {}) board = board + +applyProperty (BM {}) board = board +applyProperty (DO {}) board = board +applyProperty (IT {}) board = board +applyProperty (TE {}) board = board + +applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board } +applyProperty (CR coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board +applyProperty (DD coords) board = + let coords' = expandCoordList coords + board' = clearBoardDimmed board + in if null coords' + then board' + else updateCoordStates (\state -> state { coordDimmed = True }) coords' + board { boardHasDimmed = True } +applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board } +applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board } +applyProperty (MA coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board +applyProperty (SL coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board +applyProperty (SQ coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board +applyProperty (TR coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board + +applyProperty (AP {}) board = board +applyProperty (CA {}) board = board +applyProperty (FF {}) board = board +applyProperty (GM {}) board = board +applyProperty (ST variationMode) board = + updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board +applyProperty (SZ {}) board = board + +applyProperty (AN str) board = + updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just $ fromSimpleText str }) + board +applyProperty (BR str) board = + updateBoardInfo (\info -> info { gameInfoBlackRank = Just $ fromSimpleText str }) + board +applyProperty (BT str) board = + updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just $ fromSimpleText str }) + board +applyProperty (CP str) board = + updateBoardInfo (\info -> info { gameInfoCopyright = Just $ fromSimpleText str }) + board +applyProperty (DT str) board = + updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just $ fromSimpleText str }) + board +applyProperty (EV str) board = + updateBoardInfo (\info -> info { gameInfoEvent = Just $ fromSimpleText str }) + board +applyProperty (GC str) board = + updateBoardInfo (\info -> info { gameInfoGameComment = Just $ fromSimpleText str }) + board +applyProperty (GN str) board = + updateBoardInfo (\info -> info { gameInfoGameName = Just $ fromSimpleText str }) + board +applyProperty (ON str) board = + updateBoardInfo (\info -> info { gameInfoOpeningComment = Just $ fromSimpleText str }) + board +applyProperty (OT str) board = + updateBoardInfo (\info -> info { gameInfoOvertime = Just $ fromSimpleText str }) + board +applyProperty (PB str) board = + updateBoardInfo (\info -> info { gameInfoBlackName = Just $ fromSimpleText str }) + board +applyProperty (PC str) board = + updateBoardInfo (\info -> info { gameInfoPlace = Just $ fromSimpleText str }) + board +applyProperty (PW str) board = + updateBoardInfo (\info -> info { gameInfoWhiteName = Just $ fromSimpleText str }) + board +applyProperty (RE result) board = + updateBoardInfo (\info -> info { gameInfoResult = Just result }) + board +applyProperty (RO str) board = + updateBoardInfo (\info -> info { gameInfoRound = Just $ fromSimpleText str }) + board +applyProperty (RU ruleset) board = + updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset }) + board +applyProperty (SO str) board = + updateBoardInfo (\info -> info { gameInfoSource = Just $ fromSimpleText str }) + board +applyProperty (TM seconds) board = + updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds }) + board +applyProperty (US str) board = + updateBoardInfo (\info -> info { gameInfoEntererName = Just $ fromSimpleText str }) + board +applyProperty (WR str) board = + updateBoardInfo (\info -> info { gameInfoWhiteRank = Just $ fromSimpleText str }) + board +applyProperty (WT str) board = + updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just $ fromSimpleText str }) + board + +applyProperty (VW coords) board = + let coords' = expandCoordList coords + in if null coords' + then setBoardVisible True board + else updateCoordStates (\state -> state { coordVisible = True }) coords' $ + setBoardVisible False board + +applyProperty (UnknownProperty {}) board = board + +applyProperties :: Node -> BoardState -> BoardState +applyProperties node board = foldr applyProperty board (nodeProperties node) + +-- | Applies the transformation function to all of a board's coordinates +-- referred to by the 'CoordList'. +updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState +updateCoordStates fn coords board = + board { boardCoordStates = foldr applyFn (boardCoordStates board) coords } + where applyFn (x, y) = listUpdate (updateRow x) y + updateRow = listUpdate fn + +updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState +updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords) + +-- | Updates properties of a 'BoardState' given that the player of the given +-- color has just made a move. Increments the move number and updates the +-- player turn. +updateBoardForMove :: Color -> BoardState -> BoardState +updateBoardForMove movedPlayer board = + board { boardMoveNumber = boardMoveNumber board + 1 + , boardPlayerTurn = cnot movedPlayer + } + +-- | A structure that configures how 'applyMove' should handle moves that are +-- normally illegal in Go. +data ApplyMoveParams = ApplyMoveParams { allowSuicide :: Bool + -- ^ If false, suicide will cause 'applyMove' to return + -- 'ApplyMoveSuicideError'. If true, suicide will kill the + -- friendly group and give points to the opponent. + , allowOverwrite :: Bool + -- ^ If false, playing on an occupied point will cause + -- 'applyMove' to return 'ApplyMoveOverwriteError' with the + -- color of the stone occupying the point. If true, + -- playing on an occupied point will overwrite the point + -- (the previous stone vanishes), then capture rules are + -- applied as normal. + } deriving (Show) + +-- | As an argument to 'applyMove', causes illegal moves to be treated as +-- errors. +standardGoMoveParams :: ApplyMoveParams +standardGoMoveParams = ApplyMoveParams { allowSuicide = False + , allowOverwrite = False + } + +-- | As an argument to 'applyMove', causes illegal moves to be played +-- unconditionally. +playTheDarnMoveGoParams :: ApplyMoveParams +playTheDarnMoveGoParams = ApplyMoveParams { allowSuicide = True + , allowOverwrite = True + } + +-- | The possible results from 'applyMove'. +data ApplyMoveResult = ApplyMoveOk BoardState + -- ^ The move was accepted; playing it resulted in the + -- given board without capture. + | ApplyMoveCapture BoardState Color Int + -- ^ The move was accepted; playing it resulted in the + -- given board with a capture. The specified side gained + -- the number of points given. + | ApplyMoveSuicideError + -- ^ Playing the move would result in suicide, which is + -- forbidden. + | ApplyMoveOverwriteError Color + -- ^ There is already a stone of the specified color on + -- the target point, and overwriting is forbidden. + +-- | If the 'ApplyMoveResult' represents a successful move, then the resulting +-- 'BoardState' is returned, otherwise, the default 'BoardState' given is +-- returned. +getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState +getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result + +getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState +getApplyMoveResult' result = case result of + ApplyMoveOk board -> Just board + ApplyMoveCapture board color points -> Just $ case color of + Black -> board { boardBlackCaptures = boardBlackCaptures board + points } + White -> board { boardWhiteCaptures = boardWhiteCaptures board + points } + ApplyMoveSuicideError -> Nothing + ApplyMoveOverwriteError _ -> Nothing + +-- | Internal data structure, only for move application code. Represents a +-- group of stones. +data ApplyMoveGroup = ApplyMoveGroup { applyMoveGroupOrigin :: Coord + , applyMoveGroupCoords :: [Coord] + , applyMoveGroupLiberties :: Int + } deriving (Show) + +-- | Places a stone of a color at a point on a board, and runs move validation +-- and capturing logic according to the given parameters. Returns whether the +-- move was successful, and the result if so. +applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult +applyMove params color xy board = + let currentStone = coordStone $ boardCoordState xy board + in case currentStone of + Just color -> if allowOverwrite params + then moveResult + else ApplyMoveOverwriteError color + Nothing -> moveResult + where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color }) + [xy] + board + (boardWithCaptures, points) = foldr (maybeCapture $ cnot color) + (boardWithMove, 0) + (adjacentPoints boardWithMove xy) + playedGroup = computeGroup boardWithCaptures xy + moveResult + | applyMoveGroupLiberties playedGroup == 0 = + if points /= 0 + then error "Cannot commit suicide and capture at the same time." + else if allowSuicide params + then let (boardWithSuicide, suicidePoints) = + applyMoveCapture (boardWithCaptures, 0) playedGroup + in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints + else ApplyMoveSuicideError + | points /= 0 = ApplyMoveCapture boardWithCaptures color points + | otherwise = ApplyMoveOk boardWithCaptures + +-- | Capture if there is a liberty-less group of a color at a point on +-- a board. Removes captured stones from the board and accumulates +-- points for captured stones. +maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int) +maybeCapture color xy result@(board, _) = + if coordStone (boardCoordState xy board) /= Just color + then result + else let group = computeGroup board xy + in if applyMoveGroupLiberties group /= 0 + then result + else applyMoveCapture result group + +computeGroup :: BoardState -> Coord -> ApplyMoveGroup +computeGroup board xy = + if isNothing (coordStone $ boardCoordState xy board) + then error "computeGroup called on an empty point." + else let groupCoords = bucketFill board xy + in ApplyMoveGroup { applyMoveGroupOrigin = xy + , applyMoveGroupCoords = groupCoords + , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords + } + +applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int) +applyMoveCapture (board, points) group = + (updateCoordStates (\state -> state { coordStone = Nothing }) + (applyMoveGroupCoords group) + board, + points + length (applyMoveGroupCoords group)) + +-- | Returns a list of the four coordinates that are adjacent to the +-- given coordinate on the board, excluding coordinates that are out +-- of bounds. +adjacentPoints :: BoardState -> Coord -> [Coord] +adjacentPoints board (x, y) = execWriter $ do + when (x > 0) $ tell [(x - 1, y)] + when (y > 0) $ tell [(x, y - 1)] + when (x < boardWidth board - 1) $ tell [(x + 1, y)] + when (y < boardHeight board - 1) $ tell [(x, y + 1)] + +-- | Takes a list of coordinates that comprise a group (e.g. a list +-- returned from 'bucketFill') and returns the number of liberties the +-- group has. Does no error checking to ensure that the list refers +-- to a single or maximal group. +getLibertiesOfGroup :: BoardState -> [Coord] -> Int +getLibertiesOfGroup board groupCoords = + length $ nub $ concatMap findLiberties groupCoords + where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board) + (adjacentPoints board xy) + +-- | Expands a single coordinate on a board into a list of all the +-- coordinates connected to it by some continuous path of stones of +-- the same color (or empty spaces). +bucketFill :: BoardState -> Coord -> [Coord] +bucketFill board xy0 = bucketFill' Set.empty [xy0] + where bucketFill' known [] = Set.toList known + bucketFill' known (xy:xys) = + if Set.member xy known + then bucketFill' known xys + else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board) + (adjacentPoints board xy) + in bucketFill' (Set.insert xy known) (new ++ xys) + stone0 = coordStone $ boardCoordState xy0 board + +-- | Returns whether it is legal to place a stone of the given color at a point +-- on a board. Accepts out-of-bound coordinates and returns false. +isValidMove :: BoardState -> Color -> Coord -> Bool +-- TODO Should out-of-bound coordinates be accepted? +isValidMove board color coord@(x, y) = + let w = boardWidth board + h = boardHeight board + in x >= 0 && y >= 0 && x < w && y < h && + isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board) + +-- | Returns whether it is legal for the current player to place a stone at a +-- point on a board. Accepts out-of-bound coordinates and returns false. +isCurrentValidMove :: BoardState -> Coord -> Bool +isCurrentValidMove board = isValidMove board (boardPlayerTurn board) + +-- | A pointer to a node in a game tree that also holds information +-- about the current state of the game at that node. +data Cursor = Cursor { cursorParent :: Maybe Cursor + -- ^ The cursor for the node above this cursor's node in + -- the game tree. The node of the parent cursor is the + -- parent of the cursor's node. + -- + -- This is @Nothing@ iff the cursor's node has no parent. + , cursorChildIndex :: Int + -- ^ The index of this cursor's node in its parent's + -- child list. When the cursor's node has no parent, + -- the value in this field is not specified. + , cursorNode :: Node + -- ^ The game tree node about which the cursor stores + -- information. + , cursorBoard :: BoardState + -- ^ The complete board state for the current node. + } deriving (Show) -- TODO Better Show Cursor instance. + +-- | Returns a cursor for a root node. +rootCursor :: Node -> Cursor +rootCursor node = + Cursor { cursorParent = Nothing + , cursorChildIndex = -1 + , cursorNode = node + , cursorBoard = rootBoardState node + } + +cursorRoot :: Cursor -> Cursor +cursorRoot cursor = case cursorParent cursor of + Nothing -> cursor + Just parent -> cursorRoot parent + +cursorChild :: Cursor -> Int -> Cursor +cursorChild cursor index = + Cursor { cursorParent = Just cursor + , cursorChildIndex = index + , cursorNode = child + , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor + } + -- TODO Better handling or messaging for out-of-bounds: + where child = (!! index) $ nodeChildren $ cursorNode cursor + +cursorChildren :: Cursor -> [Cursor] +cursorChildren cursor = + let board = boardChild $ cursorBoard cursor + in map (\(index, child) -> Cursor { cursorParent = Just cursor + , cursorChildIndex = index + , cursorNode = child + , cursorBoard = applyProperties child board + }) + $ zip [0..] + $ nodeChildren + $ cursorNode cursor + +cursorChildCount :: Cursor -> Int +cursorChildCount = length . nodeChildren . cursorNode + +cursorChildPlayingAt :: Coord -> Cursor -> Maybe Cursor +cursorChildPlayingAt coord cursor = + let children = cursorChildren cursor + color = boardPlayerTurn $ cursorBoard cursor + hasMove = elem $ colorToMove color coord + in find (hasMove . nodeProperties . cursorNode) children + +-- | This is simply @'nodeProperties' . 'cursorNode'@. +cursorProperties :: Cursor -> [Property] +cursorProperties = nodeProperties . cursorNode + +cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor +cursorModifyNode fn cursor = + let node' = fn $ cursorNode cursor + in case cursorParent cursor of + Nothing -> rootCursor node' + Just parentCursor -> + let index = cursorChildIndex cursor + parentCursor' = cursorModifyNode + (\parentNode -> + parentNode { nodeChildren = listUpdate (const node') + index + (nodeChildren parentNode) + }) + parentCursor + in cursorChild parentCursor' index + +-- | Returns the variations to display for a cursor. The returned list contains +-- the location and color of 'B' and 'W' properties in variation nodes. +-- Variation nodes are either children of the current node, or siblings of the +-- current node, depending on the variation mode source. +cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)] +cursorVariations source cursor = + case source of + ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor + ShowCurrentVariations -> + case cursorParent cursor of + Nothing -> [] + Just parent -> collectPlays $ listDeleteIndex (cursorChildIndex cursor) $ + nodeChildren $ cursorNode parent + where collectPlays :: [Node] -> [(Coord, Color)] + collectPlays = concatMap collectPlays' + collectPlays' = concatMap collectPlays'' . nodeProperties + collectPlays'' prop = case prop of + B (Just xy) -> [(xy, Black)] + W (Just xy) -> [(xy, White)] + _ -> [] + +colorToMove :: Color -> Coord -> Property +colorToMove color coord = + case color of + Black -> B $ Just coord + White -> W $ Just coord diff --git a/src/Game/Goatee/Sgf/Monad.hs b/src/Game/Goatee/Sgf/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Monad.hs @@ -0,0 +1,690 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | A monad for working with game trees. +module Game.Goatee.Sgf.Monad ( + -- * The Go monad + GoT, GoM, + runGoT, runGo, + evalGoT, evalGo, + execGoT, execGo, + getCursor, getCoordState, + -- * Navigation + Step(..), goUp, goDown, goToRoot, goToGameInfoNode, + -- * Remembering positions + pushPosition, popPosition, dropPosition, + -- * Properties + getProperties, + modifyProperties, + getProperty, + getPropertyValue, + putProperty, + deleteProperty, + modifyProperty, + modifyPropertyValue, + modifyPropertyString, + modifyPropertyCoords, + modifyGameInfo, + modifyVariationMode, + getMark, + modifyMark, + -- * Children + addChild, + -- * Event handling + Event, on, fire, + -- * Events + childAddedEvent, ChildAddedHandler, + gameInfoChangedEvent, GameInfoChangedHandler, + navigationEvent, NavigationHandler, + propertiesModifiedEvent, PropertiesModifiedHandler, + variationModeChangedEvent, VariationModeChangedHandler, + ) where + +import Control.Applicative ((<$>), Applicative ((<*>), pure)) +import Control.Monad (ap, liftM, when) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer) +import qualified Control.Monad.State as State +import Control.Monad.State (StateT) +import Data.List (delete, find, mapAccumL, nub) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Game.Goatee.Common +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree hiding (addChild) +import Game.Goatee.Sgf.Types + +-- | The internal state of a Go monad transformer. @go@ is the type of +-- Go monad or transformer (instance of 'GoMonad'). +data GoState go = GoState { stateCursor :: Cursor + -- ^ The current position in the game tree. + , statePathStack :: PathStack + -- ^ The current path stack. + + -- Event handlers. + , stateChildAddedHandlers :: [ChildAddedHandler go] + -- ^ Handlers for 'childAddedEvent'. + , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go] + -- ^ Handlers for 'gameInfoChangedEvent'. + , stateNavigationHandlers :: [NavigationHandler go] + -- ^ Handlers for 'navigationEvent'. + , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go] + -- ^ Handlers for 'propertiesModifiedEvent'. + , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go] + -- ^ Handlers for 'variationModeChangedEvent'. + } + +-- | A path stack is a record of previous places visited in a game tree. It is +-- encoded a list of paths (steps) to each previous memorized position. +-- +-- The positions saved in calls to 'pushPosition' correspond to entries in the +-- outer list here, with the first sublist representing the last call. The +-- sublist contains the steps in order that will trace the path back to the +-- saved position. +type PathStack = [[Step]] + +-- | A simplified constructor function for 'GoState'. +initialState :: Cursor -> GoState m +initialState cursor = GoState { stateCursor = cursor + , statePathStack = [] + , stateChildAddedHandlers = [] + , stateGameInfoChangedHandlers = [] + , stateNavigationHandlers = [] + , statePropertiesModifiedHandlers = [] + , stateVariationModeChangedHandlers = [] + } + +-- | A single step along a game tree. Either up or down. +data Step = GoUp Int + -- ^ Represents a step up from a child with the given index. + | GoDown Int + -- ^ Represents a step down to the child with the given index. + deriving (Eq, Show) + +-- | Reverses a step, such that taking a step then it's reverse will leave you +-- where you started. +reverseStep :: Step -> Step +reverseStep step = case step of + GoUp index -> GoDown index + GoDown index -> GoUp index + +-- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'. +takeStep :: Step -> Cursor -> Cursor +takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $ + cursorParent cursor +takeStep (GoDown index) cursor = cursorChild cursor index + +-- | Internal function. Takes a 'Step' in the Go monad. Updates the path stack +-- accordingly. +takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m () +takeStepM step = case step of + GoUp _ -> goUp' + GoDown index -> goDown' index + +-- | A monad (transformer) for navigating and mutating 'Cursor's, and +-- remembering previous locations. See 'GoT' and 'GoM'. +-- +-- The monad supports handlers for events raised during actions it takes, such +-- as navigating through the tree and modifying nodes. +class Monad go => MonadGo go where + -- | Returns the current cursor. + getCursor :: go Cursor + + -- | Returns the 'CoordState' at the given point. + getCoordState :: Coord -> go CoordState + getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor + + -- | Navigates up the tree. It must be valid to do so, otherwise 'fail' is + -- called. Fires a 'navigationEvent' after moving. + goUp :: go () + + -- | Navigates down the tree to the child with the given index. The child + -- must exist. Fires a 'navigationEvent' after moving. + goDown :: Int -> go () + + -- | Navigates up to the root of the tree. Fires 'navigationEvent's for each + -- step. + goToRoot :: go () + + -- | Navigates up the tree to the node containing game info properties, if + -- any. Returns true if a game info node was found. + goToGameInfoNode :: Bool + -- ^ When no node with game info is found, then if false, + -- return to the original node, otherwise finish at the + -- root node. + -> go Bool + + -- | Pushes the current location in the game tree onto an internal position + -- stack, such that 'popPosition' is capable of navigating back to the same + -- position, even if the game tree has been modified (though the old position + -- must still exist in the tree to return to it). + pushPosition :: go () + + -- | Returns to the last position pushed onto the internal position stack via + -- 'pushPosition'. This action must be balanced by a 'pushPosition'. + popPosition :: go () + + -- | Drops the last position pushed onto the internal stack by 'pushPosition' + -- off of the stack. This action must be balanced by a 'pushPosition'. + dropPosition :: go () + + -- | Returns the set of properties on the current node. + getProperties :: go [Property] + getProperties = liftM cursorProperties getCursor + + -- | Modifies the set of properties on the current node. + -- + -- The given function must end on the same node on which it started. + modifyProperties :: ([Property] -> go [Property]) -> go () + + -- | Searches for a property on the current node, returning it if found. + getProperty :: Descriptor d => d -> go (Maybe Property) + + -- | Searches for a valued property on the current node, returning its value + -- if found. + getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v) + getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor + + -- | Sets a property on the current node, replacing an existing property with + -- the same name, if one exists. + putProperty :: Property -> go () + putProperty property = modifyProperty (propertyInfo property) $ const $ Just property + + -- | Deletes a property from the current node, if it's set. + -- + -- Note that although a 'Property' is a 'Descriptor', giving a valued + -- @Property@ here will not cause deletion to match on the value of the + -- property. That is, the following code will result in 'Nothing', because + -- the deletion only cares about the name of the property. + -- + -- > do putProperty $ PL Black + -- > deleteProperty $ PL White + -- > getPropertyValue propertyPL + deleteProperty :: Descriptor d => d -> go () + deleteProperty descriptor = modifyProperty descriptor $ const Nothing + + -- | Calls the given function to modify the state of the given property + -- (descriptor) on the current node. 'Nothing' represents the property not + -- existing on the node, and a 'Just' marks the property's presence. This + -- function does not do any validation to check that the resulting tree state + -- is valid. + modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go () + + -- | Calls the given function to modify the state of the given valued property + -- (descriptor) on the current node. 'Nothing' represents the property not + -- existing on the node, and a 'Just' with the property's value marks the + -- property's presence. This function does not do any validation to check + -- that the resulting tree state is valid. + modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go () + modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old -> + propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old) + + -- | Mutates the string-valued property attached to the current node according + -- to the given function. The input string will be empty if the current node + -- either has the property with an empty value, or doesn't have the property. + -- Returning an empty string removes the property from the node, if it was + -- set. + modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go () + modifyPropertyString descriptor fn = + modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of + "" -> Nothing + str -> let sgf = stringToSgf str + -- Because stringToSgf might do processing, we have to check + -- the conversion back to a string for emptiness. + in if null $ sgfToString sgf then Nothing else Just sgf + + -- | Mutates the 'CoordList'-valued property attached to the current node + -- according to the given function. Conversion between @CoordList@ and + -- @[Coord]@ is performed automatically. The input list will be empty if the + -- current node either has the property with an empty value, or doesn't have + -- the property. Returning an empty list removes the property from the node, + -- if it was set. + -- + -- Importantly, this might not be specific enough for properties such as 'DD' + -- and 'VW' where a present, empty list has different semantics from the + -- property not being present. In that case, 'modifyPropertyValue' is better. + modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go () + modifyPropertyCoords descriptor fn = + modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of + [] -> Nothing + coords -> Just $ buildCoordList coords + + -- | Mutates the game info for the current path, returning the new info. If + -- the current node or one of its ancestors has game info properties, then + -- that node is modified. Otherwise, properties are inserted on the root + -- node. + modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo + + -- | Sets the game's 'VariationMode' via the 'ST' property on the root node, + -- then fires a 'variationModeChangedEvent' if the variation mode has changed. + modifyVariationMode :: (VariationMode -> VariationMode) -> go () + + -- | Returns the 'Mark' at a point on the current node. + getMark :: Coord -> go (Maybe Mark) + getMark = liftM coordMark . getCoordState + + -- | Calls the given function to modify the presence of a 'Mark' on the + -- current node. + modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go () + modifyMark fn coord = do + maybeOldMark <- getMark coord + case (maybeOldMark, fn maybeOldMark) of + (Just oldMark, Nothing) -> remove oldMark + (Nothing, Just newMark) -> add newMark + (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark + (Just _, Just _) -> return () + (Nothing, Nothing) -> return () + where remove mark = modifyPropertyCoords (markProperty mark) (delete coord) + add mark = modifyPropertyCoords (markProperty mark) (coord:) + + -- | Adds a child node to the current node at the given index, shifting all + -- existing children at and after the index to the right. The index must in + -- the range @[0, numberOfChildren]@. Fires a 'childAddedEvent' after the + -- child is added. + addChild :: Int -> Node -> go () + + -- | Registers a new event handler for a given event type. + on :: Event go h -> h -> go () + +-- | The regular monad transformer for 'MonadGo'. +newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a } + +-- | The regular monad for 'MonadGo'. +type GoM = GoT Identity + +instance Monad m => Functor (GoT m) where + fmap = liftM + +instance Monad m => Applicative (GoT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (GoT m) where + return x = GoT $ return x + m >>= f = GoT $ goState . f =<< goState m + fail = lift . fail + +instance MonadTrans GoT where + lift = GoT . lift + +instance MonadIO m => MonadIO (GoT m) where + liftIO = lift . liftIO + +instance MonadWriter w m => MonadWriter w (GoT m) where + writer = lift . writer + tell = lift . tell + listen = GoT . listen . goState + pass = GoT . pass . goState + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad a tuple that contains the resulting value and the final cursor. +runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor) +runGoT go cursor = do + (value, state) <- State.runStateT (goState go) (initialState cursor) + return (value, stateCursor state) + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad the value in the transformer. +evalGoT :: Monad m => GoT m a -> Cursor -> m a +evalGoT go cursor = liftM fst $ runGoT go cursor + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad the final cursor. +execGoT :: Monad m => GoT m a -> Cursor -> m Cursor +execGoT go cursor = liftM snd $ runGoT go cursor + +-- | Runs a Go monad on a cursor. See 'runGoT'. +runGo :: GoM a -> Cursor -> (a, Cursor) +runGo go = runIdentity . runGoT go + +-- | Runs a Go monad on a cursor and returns the value in the monad. +evalGo :: GoM a -> Cursor -> a +evalGo m cursor = fst $ runGo m cursor + +-- | Runs a Go monad on a cursor and returns the final cursor. +execGo :: GoM a -> Cursor -> Cursor +execGo m cursor = snd $ runGo m cursor + +getState :: Monad m => GoT m (GoState (GoT m)) +getState = GoT State.get + +putState :: Monad m => GoState (GoT m) -> GoT m () +putState = GoT . State.put + +modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m () +modifyState = GoT . State.modify + +instance Monad m => MonadGo (GoT m) where + getCursor = liftM stateCursor getState + + goUp = do + index <- liftM cursorChildIndex getCursor + goUp' $ \pathStack -> case pathStack of + [] -> pathStack + path:paths -> (GoDown index:path):paths + + goDown index = goDown' index $ \pathStack -> case pathStack of + [] -> pathStack + path:paths -> (GoUp index:path):paths + + goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp + + goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode + where findGameInfoNode = do + cursor <- getCursor + if hasGameInfo cursor + then dropPosition >> return True + else if isNothing $ cursorParent cursor + then do if goToRootIfNotFound then dropPosition else popPosition + return False + else goUp >> findGameInfoNode + hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor + + pushPosition = modifyState $ \state -> + state { statePathStack = []:statePathStack state } + + popPosition = do + getPathStack >>= \stack -> when (null stack) $ + fail "popPosition: No position to pop from the stack." + + -- Drop each step in the top list of the path stack one at a time, until the + -- top list is empty. + whileM' (do path:_ <- getPathStack + return $ if null path then Nothing else Just $ head path) $ + flip takeStepM $ \((_:steps):paths) -> steps:paths + + -- Finally, drop the empty top of the path stack. + modifyState $ \state -> case statePathStack state of + []:rest -> state { statePathStack = rest } + _ -> error "popPosition: Internal failure, top of path stack is not empty." + + dropPosition = do + state <- getState + -- If there are >=2 positions on the path stack, then we can't simply drop + -- the moves that will return us to the top-of-stack position, because they + -- may still be needed to return to the second-on-stack position by a + -- following popPosition. + case statePathStack state of + x:y:xs -> putState $ state { statePathStack = (x ++ y):xs } + _:[] -> putState $ state { statePathStack = [] } + [] -> fail "dropPosition: No position to drop from the stack." + + modifyProperties fn = do + oldCursor <- getCursor + let oldProperties = cursorProperties oldCursor + newProperties <- fn oldProperties + modifyState $ \state -> + state { stateCursor = cursorModifyNode + (\node -> node { nodeProperties = newProperties }) + oldCursor + } + fire propertiesModifiedEvent (\f -> f oldProperties newProperties) + + -- The current game info changes when modifying game info properties on the + -- current node. I think comparing game info properties should be faster + -- than comparing 'GameInfo's. + let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType) + oldGameInfo = filterToGameInfo oldProperties + newGameInfo = filterToGameInfo newProperties + when (newGameInfo /= oldGameInfo) $ do + newCursor <- getCursor + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor) + (boardGameInfo $ cursorBoard newCursor)) + + getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties + + modifyProperty descriptor fn = do + cursor <- getCursor + let node = cursorNode cursor + old = findProperty descriptor node + new = fn old + when (maybe False (not . propertyPredicate descriptor) new) $ + fail $ "modifyProperty: May not change property type: " ++ + show old ++ " -> " ++ show new ++ "." + case (old, new) of + (Just _, Nothing) -> modifyProperties $ return . remove descriptor + (Nothing, Just value') -> modifyProperties $ return . add value' + (Just value, Just value') | value /= value' -> + modifyProperties $ return . add value' . remove descriptor + _ -> return () + where remove descriptor = filter (not . propertyPredicate descriptor) + add value = (value:) + + modifyGameInfo fn = do + cursor <- getCursor + let info = boardGameInfo $ cursorBoard cursor + info' = fn info + when (gameInfoRootInfo info /= gameInfoRootInfo info') $ + fail "Illegal modification of root info in modifyGameInfo." + pushPosition + goToGameInfoNode True + modifyProperties $ \props -> + return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props + popPosition + return info' + + modifyVariationMode fn = do + pushPosition + goToRoot + modifyPropertyValue propertyST $ \maybeOld -> + -- If the new variation mode is equal to the old effective variation mode + -- (effective applying the default if the property isn't present), then + -- leave the property unchanged. Otherwise, apply the new variation mode, + -- deleting the property if the default variation mode is selected. We + -- don't delete the property if @maybeOld == Just new == Just + -- defaultVariationMode@, because we don't want to trigger dirtyness + -- unnecessarily. + let old = fromMaybe defaultVariationMode maybeOld + new = fn old + in if new == old + then maybeOld + else if new == defaultVariationMode + then Nothing + else Just new + popPosition + + addChild index node = do + cursor <- getCursor + let childCount = cursorChildCount cursor + when (index < 0 || index > childCount) $ fail $ + "Monad.addChild: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]." + let cursor' = cursorModifyNode (addChildAt index node) cursor + modifyState $ \state -> + state { stateCursor = cursor' + , statePathStack = updatePathStackCurrentNode + (\step -> case step of + GoUp n -> GoUp $ if n < index then n else n + 1 + down@(GoDown _) -> down) + (\step -> case step of + up@(GoUp _) -> up + GoDown n -> GoDown $ if n < index then n else n + 1) + cursor' + (statePathStack state) + } + fire childAddedEvent (\f -> f index (cursorChild cursor' index)) + + on event handler = modifyState $ addHandler event handler + +-- | Takes a step up the game tree, updates the path stack according to the +-- given function, then fires navigation and game info changed events as +-- appropriate. +goUp' :: Monad m => (PathStack -> PathStack) -> GoT m () +goUp' pathStackFn = do + state@(GoState { stateCursor = cursor + , statePathStack = pathStack + }) <- getState + case cursorParent cursor of + Nothing -> fail $ "goUp': Can't go up from a root cursor: " ++ show cursor + Just parent -> do + let index = cursorChildIndex cursor + putState state { stateCursor = parent + , statePathStack = pathStackFn pathStack + } + fire navigationEvent ($ GoUp index) + + -- The current game info changes when navigating up from a node that has + -- game info properties. + when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $ + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) + (boardGameInfo $ cursorBoard parent)) + +-- | Takes a step down the game tree, updates the path stack according to the +-- given function, then fires navigation and game info changed events as +-- appropriate. +goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m () +goDown' index pathStackFn = do + state@(GoState { stateCursor = cursor + , statePathStack = pathStack + }) <- getState + case drop index $ cursorChildren cursor of + [] -> fail $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor + child:_ -> do + putState state { stateCursor = child + , statePathStack = pathStackFn pathStack + } + fire navigationEvent ($ GoDown index) + + -- The current game info changes when navigating down to a node that has + -- game info properties. + when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $ + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) + (boardGameInfo $ cursorBoard child)) + +-- | Returns the current path stack. +getPathStack :: Monad m => GoT m PathStack +getPathStack = liftM statePathStack getState + +-- | Maps over a path stack, updating with the given functions all steps that +-- enter and leave the cursor's current node. +updatePathStackCurrentNode :: (Step -> Step) + -> (Step -> Step) + -> Cursor + -> PathStack + -> PathStack +updatePathStackCurrentNode _ _ _ [] = [] +updatePathStackCurrentNode onEnter onExit cursor0 paths = + snd $ mapAccumL updatePath (cursor0, []) paths + where updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [Step]) + updatePath = mapAccumL updateStep + updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), Step) + updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step) + updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step = + let pathToInitial' = if stepToInitial == step + then restToInitial + else reverseStep step:pathToInitial + in ((takeStep step cursor, pathToInitial'), + if null pathToInitial' then onEnter step else step) + +-- | Fires all of the handlers for the given event, using the given function to +-- create a Go action from each of the handlers (normally themselves functions +-- that create Go actions, if they're not just Go actions directly, depending on +-- the event). +fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m () +fire event handlerGenerator = do + state <- getState + mapM_ handlerGenerator $ eventStateGetter event state + +-- | A type of event in the Go monad transformer that can be handled by +-- executing an action. @go@ is the type of the type of the Go +-- monad/transformer. @h@ is the type of monad or monadic function which will +-- be used by Go actions that can trigger the event. For example, a navigation +-- event is characterized by a 'Step' that cannot easily be recovered from the +-- regular monad state, and comparing before-and-after states would be a pain. +-- So @h@ for navigation events is @'Step' -> go ()@; a handler takes a 'Step' +-- and returns a Go action to run as a result. +data Event go h = Event { eventName :: String + , eventStateGetter :: GoState go -> [h] + , eventStateSetter :: [h] -> GoState go -> GoState go + } + +instance Show (Event go h) where + show = eventName + +addHandler :: Event go h -> h -> GoState go -> GoState go +addHandler event handler state = + eventStateSetter event (eventStateGetter event state ++ [handler]) state + +-- | An event corresponding to a child node being added to the current node. +childAddedEvent :: Event go (ChildAddedHandler go) +childAddedEvent = Event { + eventName = "childAddedEvent" + , eventStateGetter = stateChildAddedHandlers + , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers } + } + +-- | A handler for 'childAddedEvent's. +type ChildAddedHandler go = Int -> Cursor -> go () + +-- | An event that is fired when the current game info changes, either by +-- navigating past a node with game info properties, or by modifying the current +-- game info properties. +gameInfoChangedEvent :: Event go (GameInfoChangedHandler go) +gameInfoChangedEvent = Event { + eventName = "gameInfoChangedEvent" + , eventStateGetter = stateGameInfoChangedHandlers + , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers } + } + +-- | A handler for 'gameInfoChangedEvent's. It is called with the old game info +-- then the new game info. +type GameInfoChangedHandler go = GameInfo -> GameInfo -> go () + +-- | An event that is fired when a single step up or down in a game tree is +-- made. +navigationEvent :: Event go (NavigationHandler go) +navigationEvent = Event { + eventName = "navigationEvent" + , eventStateGetter = stateNavigationHandlers + , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers } + } + +-- | A handler for 'navigationEvent's. +-- +-- A navigation handler may navigate further, but beware infinite recursion. A +-- navigation handler must end on the same node on which it started. +type NavigationHandler go = Step -> go () + +-- | An event corresponding to a modification to the properties list of the +-- current node. +propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go) +propertiesModifiedEvent = Event { + eventName = "propertiesModifiedEvent" + , eventStateGetter = statePropertiesModifiedHandlers + , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers } + } + +-- | A handler for 'propertiesModifiedEvent's. It is called with the old +-- property list then the new property list. +type PropertiesModifiedHandler go = [Property] -> [Property] -> go () + +-- | An event corresponding to a change in the active 'VariationMode'. This can +-- happen when modifying the 'ST' property, and also when navigating between +-- collections (as they have different root nodes). +variationModeChangedEvent :: Event go (VariationModeChangedHandler go) +variationModeChangedEvent = Event { + eventName = "variationModeChangedEvent" + , eventStateGetter = stateVariationModeChangedHandlers + , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers } + } +-- TODO Test that this is fired when moving between root nodes in a collection. +-- For now, since we don't support multiple trees in a collection, we don't need +-- to worry about checking for active variation mode change on navigation. + +-- | A handler for 'variationModeChangedEvent's. It is called with the old +-- variation mode then the new variation mode. +type VariationModeChangedHandler go = VariationMode -> VariationMode -> go () diff --git a/src/Game/Goatee/Sgf/Parser.hs b/src/Game/Goatee/Sgf/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Parser.hs @@ -0,0 +1,113 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | A parser for reading SGF files. +module Game.Goatee.Sgf.Parser ( + parseString, + parseFile, + ) where + +import Control.Applicative ((<*), (*>)) +import Data.Maybe (fromMaybe) +import Game.Goatee.Common +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Text.ParserCombinators.Parsec ( + (), Parser, char, eof, many, many1, parse, spaces, upper, + ) + +-- | Parses a string in SGF format. Returns an error string if parsing fails. +parseString :: String -> Either String Collection +parseString str = case parse collection "" str of + Left err -> Left $ show err + Right (Collection roots) -> onLeft concatErrors $ + onRight Collection $ + andEithers $ + map processRoot roots + where processRoot :: Node -> Either String Node + processRoot = checkFormatVersion . ttToPass + + -- Ensures that we are parsing an SGF version that we understand. + -- TODO Try to proceed, if it makes sense. + checkFormatVersion :: Node -> Either String Node + checkFormatVersion root = + let version = case findProperty propertyFF root of + Nothing -> defaultFormatVersion + Just (FF x) -> x + x -> error $ "Expected FF or nothing, received " ++ show x ++ "." + in if version `elem` supportedFormatVersions + then Right root + else Left $ + "Unsupported SGF version " ++ show version ++ ". Only versions " ++ + show supportedFormatVersions ++ " are supported." + + -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19. + -- Convert any passes from this format to B[] and W[] in a root node and + -- its descendents. + ttToPass :: Node -> Node + ttToPass root = + let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ + findProperty propertySZ root + in if width <= 19 && height <= 19 + then ttToPass' width height root + else root + + -- Convert a node and its descendents. + ttToPass' width height node = + node { nodeProperties = map ttToPass'' $ nodeProperties node + , nodeChildren = map (ttToPass' width height) $ nodeChildren node + } + + -- Convert a property. + ttToPass'' prop = case prop of + B (Just (19, 19)) -> B Nothing + W (Just (19, 19)) -> W Nothing + _ -> prop + + concatErrors errs = "The following errors occurred while parsing:" ++ + concatMap ("\n-> " ++) errs + +-- | Parses a file in SGF format. Returns an error string if parsing fails. +parseFile :: String -> IO (Either String Collection) +parseFile = fmap parseString . readFile + +collection :: Parser Collection +collection = fmap Collection (spaces *> many (gameTree <* spaces) <* eof) + "collection" + +gameTree :: Parser Node +gameTree = do + char '(' + nodes <- spaces *> many1 (node <* spaces) "sequence" + subtrees <- many (gameTree <* spaces) "subtrees" + char ')' + let (sequence, [final]) = splitAt (length nodes - 1) nodes + return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] }) + (final { nodeChildren = subtrees }) + sequence + +node :: Parser Node +node = fmap (\props -> emptyNode { nodeProperties = props }) + (char ';' *> spaces *> many (property <* spaces) + "node") + +property :: Parser Property +property = do + name <- many1 upper + spaces + propertyValueParser $ descriptorForName name diff --git a/src/Game/Goatee/Sgf/Property.hs b/src/Game/Goatee/Sgf/Property.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property.hs @@ -0,0 +1,27 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Structures and functions for working with SGF node properties. +module Game.Goatee.Sgf.Property ( + module Game.Goatee.Sgf.Property.Base, + module Game.Goatee.Sgf.Property.Info, + PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, + ) where + +import Game.Goatee.Sgf.Property.Base +import Game.Goatee.Sgf.Property.Info +import Game.Goatee.Sgf.Property.Value diff --git a/src/Game/Goatee/Sgf/Property/Base.hs b/src/Game/Goatee/Sgf/Property/Base.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property/Base.hs @@ -0,0 +1,314 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Core property-related data types, and some Template Haskell declarations +-- for defining property metadata. +-- +-- Import "Game.Goatee.Sgf.Property" rather than importing this module. +module Game.Goatee.Sgf.Property.Base ( + -- * Properties + Property (..), + -- * Property metadata + PropertyType (..), + Descriptor (..), + SomeDescriptor (..), + ValuedDescriptor (..), + PropertyInfo, + ValuedPropertyInfo (ValuedPropertyInfo), + -- * Property declaration + defProperty, defValuedProperty, + ) where + +import Control.Applicative ((<$)) +import Game.Goatee.Sgf.Property.Value (PropertyValueType(..), nonePvt) +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Types +import Language.Haskell.TH ( + Info (DataConI), DecsQ, Name, Type (AppT), + appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName, + normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP, + ) +import Text.ParserCombinators.Parsec (Parser) + +-- | An SGF property that gives a node meaning. +data Property = + -- Move properties. + B (Maybe Coord) -- ^ Black move (nothing iff pass). + | KO -- ^ Execute move unconditionally (even if illegal). + | MN Integer -- ^ Assign move number. + | W (Maybe Coord) -- ^ White move (nothing iff pass). + + -- Setup properties. + | AB CoordList -- ^ Assign black stones. + | AE CoordList -- ^ Assign empty stones. + | AW CoordList -- ^ Assign white stones. + | PL Color -- ^ Player to play. + + -- Node annotation properties. + | C Text -- ^ Comment. + | DM DoubleValue -- ^ Even position. + | GB DoubleValue -- ^ Good for black. + | GW DoubleValue -- ^ Good for white. + | HO DoubleValue -- ^ Hotspot. + | N SimpleText -- ^ Node name. + | UC DoubleValue -- ^ Unclear position. + | V RealValue -- ^ Node value. + + -- Move annotation properties. + | BM DoubleValue -- ^ Bad move. + | DO -- ^ Doubtful move. + | IT -- ^ Interesting move. + | TE DoubleValue -- ^ Tesuji. + + -- Markup properties. + | AR ArrowList -- ^ Arrows. + | CR CoordList -- ^ Mark points with circles. + | DD CoordList -- ^ Dim points. + | LB LabelList -- ^ Label points with text. + | LN LineList -- ^ Lines. + | MA CoordList -- ^ Mark points with 'X's. + | SL CoordList -- ^ Mark points as selected. + | SQ CoordList -- ^ Mark points with squares. + | TR CoordList -- ^ Mark points with trianges. + + -- Root properties. + | AP SimpleText SimpleText -- ^ Application info. + | CA SimpleText -- ^ Charset for SimpleText and Text. + | FF Int -- ^ File format version. + | GM Int -- ^ Game (must be 1 = Go). + | ST VariationMode -- ^ Variation display format. + | SZ Int Int -- ^ Board size, columns then rows. + + -- Game info properties. + | AN SimpleText -- ^ Name of annotator. + | BR SimpleText -- ^ Rank of black player. + | BT SimpleText -- ^ Name of black team. + | CP SimpleText -- ^ Copyright info. + | DT SimpleText -- ^ Dates played. + | EV SimpleText -- ^ Event name. + | GC SimpleText -- ^ Game comment, or background, or summary. + | GN SimpleText -- ^ Game name. + | ON SimpleText -- ^ Information about the opening. + | OT SimpleText -- ^ The method used for overtime. + | PB SimpleText -- ^ Name of black player. + | PC SimpleText -- ^ Where the game was played. + | PW SimpleText -- ^ Name of white player. + | RE GameResult -- ^ Result of the game. + | RO SimpleText -- ^ Round info. + | RU Ruleset -- ^ Ruleset used. + | SO SimpleText -- ^ Source of the game. + | TM RealValue -- ^ Time limit, in seconds. + | US SimpleText -- ^ Name of user or program who entered the game. + | WR SimpleText -- ^ Rank of white player. + | WT SimpleText -- ^ Name of white team. + + -- Miscellaneous properties. + | VW CoordList -- ^ Set viewing region. + + | UnknownProperty String UnknownPropertyValue + + -- TODO Game info, timing, and miscellaneous properties. + -- Also in functions below. + deriving (Eq, Show) + +-- | The property types that SGF uses to group properties. +data PropertyType = MoveProperty -- ^ Cannot mix with setup nodes. + | SetupProperty -- ^ Cannot mix with move nodes. + | RootProperty -- ^ May only appear in root nodes. + | GameInfoProperty -- ^ At most one on any path. + | GeneralProperty -- ^ May appear anywhere in the game tree. + deriving (Eq, Show) + +-- | A class for types that contain metadata about a 'Property'. +class Descriptor a where + -- | Returns the name of the property, as used in SGF files. + propertyName :: a -> String + + -- | Returns the type of the property, as specified by the SGF spec. + propertyType :: a -> PropertyType + + -- | Returns whether the value of the given property is inherited from the + -- lowest ancestor specifying the property, when the property is not set on a + -- node itself. + propertyInherited :: a -> Bool + + -- | Returns whether the given property has the type of a descriptor. + propertyPredicate :: a -> Property -> Bool + + -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property + -- that takes a point). + propertyValueParser :: a -> Parser Property + + -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders + -- to @"[ab]"@). + propertyValueRenderer :: a -> Property -> Render () + + -- | A renderer for displaying property values in a UI. Displays the value in + -- a human-readable format. + propertyValueRendererPretty :: a -> Property -> Render () + +data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a + +instance Descriptor SomeDescriptor where + propertyName (SomeDescriptor d) = propertyName d + propertyType (SomeDescriptor d) = propertyType d + propertyInherited (SomeDescriptor d) = propertyInherited d + propertyPredicate (SomeDescriptor d) = propertyPredicate d + propertyValueParser (SomeDescriptor d) = propertyValueParser d + propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d + propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d + +-- | A class for 'Descriptor's of 'Property's that also contain values. +class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where + -- | Extracts the value from a property of the given type. Behaviour is + -- undefined if the property is not of the given type. + propertyValue :: a -> Property -> v + + -- | Builds a property from a given value. + propertyBuilder :: a -> v -> Property + +-- | Metadata for a property that does not contain a value. Corresponds to a +-- single nullary data constructor of 'Property'. +data PropertyInfo = PropertyInfo { + propertyInfoName :: String + -- ^ The SGF textual name for the property. + , propertyInfoInstance :: Property + -- ^ The single instance of the property. + , propertyInfoType :: PropertyType + -- ^ The SGF property type. + , propertyInfoInherited :: Bool + -- ^ Whether the property is inherited. + } + +instance Descriptor PropertyInfo where + propertyName = propertyInfoName + propertyType = propertyInfoType + propertyInherited = propertyInfoInherited + propertyPredicate = (==) . propertyInfoInstance + propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt + propertyValueRenderer _ _ = pvtRenderer nonePvt () + propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt () + +-- | Metadata for a property that contains a value. Corresponds to a single +-- unary data constructor of 'Property'. +data ValuedPropertyInfo v = ValuedPropertyInfo { + valuedPropertyInfoName :: String + -- ^ The SGF textual name for the property (also the name of the data + -- constructor). + , valuedPropertyInfoType :: PropertyType + -- ^ The SGF property type. + , valuedPropertyInfoInherited :: Bool + -- ^ Whether the property is inherited. + , valuedPropertyInfoPredicate :: Property -> Bool + -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo' + -- applies. + , valuedPropertyInfoValueType :: PropertyValueType v + -- ^ Metadata about the type of the property's value. + , valuedPropertyInfoValue :: Property -> v + -- ^ A function that extracts values from properties to which this + -- 'ValuedPropertyInfo' applies. It is invalid to call this function with a + -- different type of property. + , valuedPropertyInfoBuilder :: v -> Property + -- ^ A function that builds a property containing a value. + } + +instance Descriptor (ValuedPropertyInfo v) where + propertyName = valuedPropertyInfoName + propertyType = valuedPropertyInfoType + propertyInherited = valuedPropertyInfoInherited + propertyPredicate = valuedPropertyInfoPredicate + propertyValueParser descriptor = + fmap (valuedPropertyInfoBuilder descriptor) $ + pvtParser $ + valuedPropertyInfoValueType descriptor + propertyValueRenderer descriptor property = + pvtRenderer (valuedPropertyInfoValueType descriptor) $ + valuedPropertyInfoValue descriptor property + propertyValueRendererPretty descriptor property = + pvtRendererPretty (valuedPropertyInfoValueType descriptor) $ + valuedPropertyInfoValue descriptor property + +instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where + propertyValue = valuedPropertyInfoValue + propertyBuilder = valuedPropertyInfoBuilder + +-- | Template Haskell function to declare a property that does not contain a +-- value. +-- +-- > $(defProperty "KO" 'MoveProperty False) +-- +-- This example declares a @propertyKO :: 'PropertyInfo'@ that is a +-- 'MoveProperty' and is not inherited. +defProperty :: String + -- ^ The SGF textual name of the property. + -> Name + -- ^ The name of the 'PropertyType'. + -> Bool + -- ^ Whether the property is inherited. + -> DecsQ +defProperty name propType inherited = do + let propName = mkName name + varName = mkName $ "property" ++ name + foo <- newName "foo" + sequence [ + sigD varName $ conT $ mkName "PropertyInfo", + valD (varP varName) + (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |]) + [] + ] + +-- | Template Haskell function to declare a property that contains a value. +-- +-- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter) +-- +-- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@ +-- that is a 'MoveProperty' and is not inherited. The value type is +-- automatically inferred. +defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ +defValuedProperty name propType inherited valueType = do + let propName = mkName name + varName = mkName $ "property" ++ name + foo <- newName "foo" + bar <- newName "bar" + DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName + sequence [ + sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType, + valD (varP varName) + (normalB [| ValuedPropertyInfo + name + $(conE propType) + inherited + $(lam1E (varP foo) $ caseE (varE foo) + [match (recP propName []) + (normalB $ conE $ mkName "True") + [], + match wildP (normalB $ conE $ mkName "False") []]) + $(varE valueType) + $(lam1E (varP foo) $ caseE (varE foo) + [match (conP propName [varP bar]) (normalB $ varE bar) [], + match wildP + (normalB + [| error $ "Property value getter for " ++ $(stringE name) ++ + " applied to " ++ show $(varE foo) ++ "." |]) + []]) + $(lam1E (varP foo) $ appE (conE propName) (varE foo)) + |]) + [] + ] diff --git a/src/Game/Goatee/Sgf/Property/Info.hs b/src/Game/Goatee/Sgf/Property/Info.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property/Info.hs @@ -0,0 +1,288 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Property metadata declarations. +-- +-- Import "Game.Goatee.Sgf.Property" rather than importing this module. +module Game.Goatee.Sgf.Property.Info where + +import Control.Arrow ((&&&)) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Game.Goatee.Sgf.Property.Base +import Game.Goatee.Sgf.Property.Value +import Game.Goatee.Sgf.Types + +-- Move properties. +$(defValuedProperty "B" 'MoveProperty False 'movePvt) +$(defProperty "KO" 'MoveProperty False) +$(defValuedProperty "MN" 'MoveProperty False 'integralPvt) +$(defValuedProperty "W" 'MoveProperty False 'movePvt) + +-- Setup properties. +$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "PL" 'SetupProperty False 'colorPvt) + +-- Node annotation properties. +$(defValuedProperty "C" 'GeneralProperty False 'textPvt) +$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt) +$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "V" 'GeneralProperty False 'realPvt) + +-- Move annotation properties. +$(defValuedProperty "BM" 'MoveProperty False 'doublePvt) +$(defProperty "DO" 'MoveProperty False) +$(defProperty "IT" 'MoveProperty False) +$(defValuedProperty "TE" 'MoveProperty False 'doublePvt) + +-- Markup properties. +$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt) +$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt) +$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt) +$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt) +$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt) + +-- Root properties. +propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText) +propertyAP = ValuedPropertyInfo "AP" RootProperty False + (\x -> case x of { AP {} -> True; _ -> False }) + simpleTextPairPvt + (\(AP x y) -> (x, y)) + (uncurry AP) +$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt) +$(defValuedProperty "FF" 'RootProperty False 'integralPvt) -- TODO Add parser validation. +$(defValuedProperty "GM" 'RootProperty False 'integralPvt) -- TODO Add parser validation. +$(defValuedProperty "ST" 'RootProperty False 'variationModePvt) +propertySZ :: ValuedPropertyInfo (Int, Int) +propertySZ = ValuedPropertyInfo "SZ" RootProperty False + (\x -> case x of { SZ {} -> True; _ -> False }) + sizePvt + (\(SZ x y) -> (x, y)) + (uncurry SZ) + +-- Game info properties. +$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "GC" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt) +$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt) +$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt) +$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt) + +-- Miscellaneous properties. +$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt) + +propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue +propertyUnknown name = + ValuedPropertyInfo name GeneralProperty False + (\x -> case x of + UnknownProperty name' _ | name' == name -> True + _ -> False) + unknownPropertyPvt + (\(UnknownProperty _ value) -> value) + (UnknownProperty name) + +allDescriptors :: [SomeDescriptor] +allDescriptors = [ + SomeDescriptor propertyB + , SomeDescriptor propertyKO + , SomeDescriptor propertyMN + , SomeDescriptor propertyW + + , SomeDescriptor propertyAB + , SomeDescriptor propertyAE + , SomeDescriptor propertyAW + , SomeDescriptor propertyPL + + , SomeDescriptor propertyC + , SomeDescriptor propertyDM + , SomeDescriptor propertyGB + , SomeDescriptor propertyGW + , SomeDescriptor propertyHO + , SomeDescriptor propertyN + , SomeDescriptor propertyUC + , SomeDescriptor propertyV + + , SomeDescriptor propertyBM + , SomeDescriptor propertyDO + , SomeDescriptor propertyIT + , SomeDescriptor propertyTE + + , SomeDescriptor propertyAR + , SomeDescriptor propertyCR + , SomeDescriptor propertyDD + , SomeDescriptor propertyLB + , SomeDescriptor propertyLN + , SomeDescriptor propertyMA + , SomeDescriptor propertySL + , SomeDescriptor propertySQ + , SomeDescriptor propertyTR + + , SomeDescriptor propertyAP + , SomeDescriptor propertyCA + , SomeDescriptor propertyFF + , SomeDescriptor propertyGM + , SomeDescriptor propertyST + , SomeDescriptor propertySZ + + , SomeDescriptor propertyAN + , SomeDescriptor propertyBR + , SomeDescriptor propertyBT + , SomeDescriptor propertyCP + , SomeDescriptor propertyDT + , SomeDescriptor propertyEV + , SomeDescriptor propertyGC + , SomeDescriptor propertyGN + , SomeDescriptor propertyON + , SomeDescriptor propertyOT + , SomeDescriptor propertyPB + , SomeDescriptor propertyPC + , SomeDescriptor propertyPW + , SomeDescriptor propertyRE + , SomeDescriptor propertyRO + , SomeDescriptor propertyRU + , SomeDescriptor propertySO + , SomeDescriptor propertyTM + , SomeDescriptor propertyUS + , SomeDescriptor propertyWR + , SomeDescriptor propertyWT + + , SomeDescriptor propertyVW + ] + +propertyInfo :: Property -> SomeDescriptor +propertyInfo property = case property of + B {} -> SomeDescriptor propertyB + KO {} -> SomeDescriptor propertyKO + MN {} -> SomeDescriptor propertyMN + W {} -> SomeDescriptor propertyW + + AB {} -> SomeDescriptor propertyAB + AE {} -> SomeDescriptor propertyAE + AW {} -> SomeDescriptor propertyAW + PL {} -> SomeDescriptor propertyPL + + C {} -> SomeDescriptor propertyC + DM {} -> SomeDescriptor propertyDM + GB {} -> SomeDescriptor propertyGB + GW {} -> SomeDescriptor propertyGW + HO {} -> SomeDescriptor propertyHO + N {} -> SomeDescriptor propertyN + UC {} -> SomeDescriptor propertyUC + V {} -> SomeDescriptor propertyV + + BM {} -> SomeDescriptor propertyBM + DO {} -> SomeDescriptor propertyDO + IT {} -> SomeDescriptor propertyIT + TE {} -> SomeDescriptor propertyTE + + AR {} -> SomeDescriptor propertyAR + CR {} -> SomeDescriptor propertyCR + DD {} -> SomeDescriptor propertyDD + LB {} -> SomeDescriptor propertyLB + LN {} -> SomeDescriptor propertyLN + MA {} -> SomeDescriptor propertyMA + SL {} -> SomeDescriptor propertySL + SQ {} -> SomeDescriptor propertySQ + TR {} -> SomeDescriptor propertyTR + + AP {} -> SomeDescriptor propertyAP + CA {} -> SomeDescriptor propertyCA + FF {} -> SomeDescriptor propertyFF + GM {} -> SomeDescriptor propertyGM + ST {} -> SomeDescriptor propertyST + SZ {} -> SomeDescriptor propertySZ + + AN {} -> SomeDescriptor propertyAN + BR {} -> SomeDescriptor propertyBR + BT {} -> SomeDescriptor propertyBT + CP {} -> SomeDescriptor propertyCP + DT {} -> SomeDescriptor propertyDT + EV {} -> SomeDescriptor propertyEV + GC {} -> SomeDescriptor propertyGC + GN {} -> SomeDescriptor propertyGN + ON {} -> SomeDescriptor propertyON + OT {} -> SomeDescriptor propertyOT + PB {} -> SomeDescriptor propertyPB + PC {} -> SomeDescriptor propertyPC + PW {} -> SomeDescriptor propertyPW + RE {} -> SomeDescriptor propertyRE + RO {} -> SomeDescriptor propertyRO + RU {} -> SomeDescriptor propertyRU + SO {} -> SomeDescriptor propertySO + TM {} -> SomeDescriptor propertyTM + US {} -> SomeDescriptor propertyUS + WR {} -> SomeDescriptor propertyWR + WT {} -> SomeDescriptor propertyWT + + VW {} -> SomeDescriptor propertyVW + + UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name + +instance Descriptor Property where + propertyName = propertyName . propertyInfo + propertyType = propertyType . propertyInfo + propertyInherited = propertyInherited . propertyInfo + propertyPredicate = propertyPredicate . propertyInfo + propertyValueParser = propertyValueParser . propertyInfo + propertyValueRenderer = propertyValueRenderer . propertyInfo + propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo + +descriptorsByName :: Map String SomeDescriptor +descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors + +descriptorForName :: String -> SomeDescriptor +descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name + +descriptorForName' :: String -> Maybe SomeDescriptor +descriptorForName' = flip Map.lookup descriptorsByName + +-- | Returns the descriptor for a mark. +markProperty :: Mark -> ValuedPropertyInfo CoordList +markProperty MarkCircle = propertyCR +markProperty MarkSelected = propertySL +markProperty MarkSquare = propertySQ +markProperty MarkTriangle = propertyTR +markProperty MarkX = propertyMA diff --git a/src/Game/Goatee/Sgf/Property/Parser.hs b/src/Game/Goatee/Sgf/Property/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property/Parser.hs @@ -0,0 +1,275 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Parsers of property values. +-- +-- Import "Game.Goatee.Sgf.Property" rather than importing this module. +module Game.Goatee.Sgf.Property.Parser ( + colorParser, + coordElistParser, + coordListParser, + coordPairListParser, + doubleParser, + gameResultParser, + labelListParser, + moveParser, + noneParser, + integralParser, + realParser, + rulesetParser, + simpleTextPairParser, + simpleTextParser, + sizeParser, + textParser, + unknownPropertyParser, + variationModeParser, + -- * Exposed for testing + compose, + line, + simpleText, + text, + ) where + +import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>)) +import Control.Monad (when) +import Data.Char (isUpper, ord) +import Data.Maybe (catMaybes) +import Data.Monoid (Monoid, mappend, mconcat, mempty) +import Game.Goatee.Sgf.Types +import Text.ParserCombinators.Parsec ( + (), (<|>), Parser, + anyChar, char, choice, digit, eof, many, many1, + noneOf, oneOf, option, parse, space, spaces, string, + try, unexpected, + ) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +-- Internal parser builders not corresponding to any particular value type. + +-- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing. +-- The monoid does simple concatenation of the single and rectangle lists, so it +-- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal +-- between two @CoordList@s. +newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList } + +instance Monoid CoordListMonoid where + mempty = CoordListMonoid emptyCoordList + + mappend (CoordListMonoid x) (CoordListMonoid y) = + CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y) + (coordListRects x ++ coordListRects y) + +single :: Parser a -> Parser a +single valueParser = char '[' *> valueParser <* char ']' + +compose :: Parser a -> Parser b -> Parser (a, b) +compose first second = do + x <- first + char ':' + y <- second + return (x, y) + +line :: Parser Int +line = toLine <$> line' "line" + where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z'] + toLine c = if isUpper c + then ord c - ord 'A' + 26 + else ord c - ord 'a' + +listOf :: Parser a -> Parser [a] +listOf valueParser = many1 (single valueParser <* spaces) + +number :: Parser (String, Bool) +number = do + sign <- "-" <$ char '-' <|> + "" <$ char '+' <|> + return "" + digits <- many1 digit + return (sign ++ digits, not $ null sign) + +-- Public parsers. + +colorParser :: Parser Color +colorParser = single color "color" + +color :: Parser Color +color = choice [Black <$ char 'B', + White <$ char 'W'] + +coord :: Parser Coord +coord = (,) <$> line <*> line + +coordElistParser :: Parser CoordList +coordElistParser = + try (emptyCoordList <$ string "[]") <|> + coordListParser + "list of points or empty" + +coordListParser :: Parser CoordList +coordListParser = + runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry + "list of points" + where coordListEntry = do x0 <- line + y0 <- line + choice [do char ':' + x1 <- line + y1 <- line + return $ coordR ((x0, y0), (x1, y1)), + return $ coord1 (x0, y0)] + coordR rect = coords' [] [rect] + +coordPairListParser :: Parser [(Coord, Coord)] +coordPairListParser = listOf coordPair "list of point pairs" + where coordPair = do + x0 <- line + y0 <- line + char ':' + x1 <- line + y1 <- line + return ((x0, y0), (x1, y1)) + +doubleParser :: Parser DoubleValue +doubleParser = + single (Double1 <$ char '1' <|> + Double2 <$ char '2') + "double" + +gameResultParser :: Parser GameResult +gameResultParser = single (parseGameResult <$> simpleText False) "game result" + where parseGameResult text = case fromSimpleText text of + "0" -> GameResultDraw + "Draw" -> GameResultDraw + "Void" -> GameResultVoid + "?" -> GameResultUnknown + rawText -> case parse gameResultWin "" rawText of + Left _ -> GameResultOther text + Right win -> win + +gameResultWin :: Parser GameResult +gameResultWin = GameResultWin <$> color <* char '+' <*> winReason <* eof + +winReason :: Parser WinReason +winReason = + WinByScore <$> try real <|> + WinByResignation <$ try (string "Resign") <|> + WinByResignation <$ try (string "R") <|> + WinByTime <$ try (string "Time") <|> + WinByTime <$ try (string "T") <|> + WinByForfeit <$ try (string "Forfeit") <|> + WinByForfeit <$ try (string "F") + +labelListParser :: Parser [(Coord, SimpleText)] +labelListParser = + listOf (compose coord $ simpleText True) "list of points and labels" + +moveParser :: Parser (Maybe Coord) +moveParser = + char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') + "move (point or pass)" + +noneParser :: Parser () +noneParser = () <$ string "[]" "none" + +-- This is what the SGF spec calls the Number type, i.e. a signed integer. +integralParser :: (Integral a, Read a) => Parser a +integralParser = single integral "integer" + +integral :: (Integral a, Read a) => Parser a +integral = read . fst <$> number + +realParser :: Parser RealValue +realParser = single real "real" + +real :: Parser RealValue +real = do + (whole, isNegative) <- number + let wholePart = toRational (read whole :: Integer) + -- Try to read a fractional part of the number. + -- If we fail, just return the whole part. + option wholePart $ try $ do + fractionalStr <- char '.' *> many1 digit + let fractionalPart = toRational (read fractionalStr) / 10 ^ length fractionalStr + return $ (if isNegative then (-) else (+)) wholePart fractionalPart + +rulesetParser :: Parser Ruleset +rulesetParser = + single (toRuleset . fromSimpleText <$> simpleText False) "ruleset" + +simpleTextPairParser :: Parser (SimpleText, SimpleText) +simpleTextPairParser = single (compose composedText composedText) "pair of simple texts" + where composedText = simpleText True + +-- | A parser for SGF SimpleText property values. +simpleTextParser :: Parser SimpleText +simpleTextParser = single (simpleText False) "simple text" + +simpleText :: Bool -> Parser SimpleText +simpleText isComposed = toSimpleText <$> text isComposed + +sizeParser :: Parser (Int, Int) +sizeParser = + (do char '[' + width <- integral + height <- choice [width <$ char ']', + do char ':' + height <- integral + char ']' + -- TODO We should warn here rather than aborting. + when (width == height) $ + fail $ show width ++ "x" ++ show height ++ " square board " ++ + " dimensions should be specified with a single number." + return height] + when (width < 1 || width > boardSizeMax || + height < 1 || height > boardSizeMax) $ + fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid. " ++ + "Each dimension must be between 1 and 52 inclusive." + return (width, height)) + "board size (width or width:height)" + +textParser :: Parser Text +textParser = single (toText <$> text False) "text" + +-- | A parser for SGF text property values. Its argument should be true if the +-- text is inside of a composed property value, so @\':\'@ should terminate the +-- value in addition to @']'@. +text :: Bool -> Parser String +text isComposed = catMaybes <$> many textChar' + where textChar' = textChar (if isComposed then ":]\\" else "]\\") + +textChar :: String -> Parser (Maybe Char) +textChar specialChars = + choice [Just <$> char '\n', + Just ' ' <$ space, + try (char '\\' *> (Nothing <$ char '\n' <|> + Just <$> anyChar)), + Just <$> noneOf specialChars] + +unknownPropertyParser :: Parser UnknownPropertyValue +unknownPropertyParser = + single (toUnknownPropertyValue <$> text False) + "unknown property value" + +variationModeParser :: Parser VariationMode +variationModeParser = single variationMode "variation mode" + +variationMode :: Parser VariationMode +variationMode = do + value <- integral + case toVariationMode value of + Just mode -> return mode + Nothing -> unexpected $ "variation mode " ++ show value diff --git a/src/Game/Goatee/Sgf/Property/Renderer.hs b/src/Game/Goatee/Sgf/Property/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property/Renderer.hs @@ -0,0 +1,326 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Renderers of property values. +-- +-- Import "Game.Goatee.Sgf.Property" rather than importing this module. +module Game.Goatee.Sgf.Property.Renderer ( + renderColorBracketed, + renderColorPretty, + renderCoordElistBracketed, + renderCoordElistPretty, + renderCoordListBracketed, + renderCoordListPretty, + renderCoordPairListBracketed, + renderCoordPairListPretty, + renderDoubleBracketed, + renderDoublePretty, + renderGameResultBracketed, + renderGameResultPretty, + renderIntegralBracketed, + renderIntegralPretty, + renderLabelListBracketed, + renderLabelListPretty, + renderMoveBracketed, + renderMovePretty, + renderNoneBracketed, + renderNonePretty, + renderRealBracketed, + renderRealPretty, + renderRulesetBracketed, + renderRulesetPretty, + renderSimpleTextBracketed, + renderSimpleTextPairBracketed, + renderSimpleTextPairPretty, + renderSimpleTextPretty, + renderSizeBracketed, + renderSizePretty, + renderTextBracketed, + renderTextPretty, + renderUnknownPropertyBracketed, + renderUnknownPropertyPretty, + renderVariationModeBracketed, + renderVariationModePretty, + ) where + +import Control.Monad (forM_, when) +#if MIN_VERSION_base(4,6,0) +import Control.Monad.Except (throwError) +#else +import Control.Monad.Error (throwError) +#endif +import Control.Monad.Writer (tell) +import Data.Char (chr, ord) +import Data.List (intersperse) +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Types + +{-# ANN module "HLint: ignore Use <$>" #-} + +-- Internal renderers not corresponding to any particular value type. + +bracketed :: Render () -> Render () +bracketed x = tell "[" >> x >> tell "]" + +renderLine :: Int -> Render () +renderLine = rendererOf "line" $ \x -> + if x >= 0 && x < 52 + then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)] + else throwError $ "renderLine: Index not in [0, 52): " ++ show x + +renderCoord :: Coord -> Render () +renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y + +renderCoordBracketed :: Coord -> Render () +renderCoordBracketed = fmap bracketed renderCoord + +renderCoordPretty :: Coord -> Render () +renderCoordPretty = rendererOf "coord pretty" $ \(x, y) -> + mapM_ tell ["(", show x, ", ", show y, ")"] + +renderCoordPairPretty :: (Coord, Coord) -> Render () +renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do + renderCoordPretty a + tell "-" + renderCoordPretty b + +renderCoordPair :: (Coord, Coord) -> Render () +renderCoordPair = rendererOf "coord pair" $ \(a, b) -> + renderCoord a >> tell ":" >> renderCoord b + +renderCoordPairBracketed :: (Coord, Coord) -> Render () +renderCoordPairBracketed = fmap bracketed renderCoordPair + +renderShowable :: Show a => a -> Render () +renderShowable = tell . show + +renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render () +renderStringlike isComposed = + rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str -> + tell $ escape $ sgfToString str + where escape [] = [] + escape (first:rest) | first `elem` specialChars = '\\':first:escape rest + | otherwise = first:escape rest + -- TODO Deduplicate these characters with the parser: + specialChars = if isComposed then ":]\\" else "]\\" + +-- Note that unlike the serialized SGF version, we don't care about escaping +-- characters in composed strings. +renderStringlikePretty :: (Show a, Stringlike a) => a -> Render () +renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString + +-- Public renderers. + +renderColorBracketed :: Color -> Render () +renderColorBracketed color = bracketed $ tell $ case color of + Black -> "[B]" + White -> "[W]" + +renderColorPretty :: Color -> Render () +renderColorPretty Black = tell "Black" +renderColorPretty White = tell "White" + +renderCoordElistBracketed :: CoordList -> Render () +renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list -> + if null $ expandCoordList list + then tell "[]" + else renderCoordListNonempty list + +renderCoordElistPretty :: CoordList -> Render () +renderCoordElistPretty = rendererOf "coord elist pretty" $ \list -> + if null $ expandCoordList list + then tell "empty" + else renderCoordListNonemptyPretty list + +renderCoordListBracketed :: CoordList -> Render () +renderCoordListBracketed = rendererOf "coord list bracketed" $ \list -> + if null $ expandCoordList list + then throwError "renderCoordListBracketed: Unexpected empty CoordList." + else renderCoordListNonempty list + +renderCoordListPretty :: CoordList -> Render () +renderCoordListPretty = rendererOf "coord list pretty" $ \list -> + if null $ expandCoordList list + then throwError "renderCoordListPretty: Unexpected empty CoordList." + else renderCoordListNonemptyPretty list + +renderCoordListNonempty :: CoordList -> Render () +renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do + mapM_ renderCoordPairBracketed $ coordListRects list + mapM_ renderCoordBracketed $ coordListSingles list + +renderCoordListNonemptyPretty :: CoordList -> Render () +renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list -> + sequence_ $ intersperse (tell ", ") $ + map renderCoordPairPretty (coordListRects list) ++ + map renderCoordPretty (coordListSingles list) + +renderCoordPairListBracketed :: [(Coord, Coord)] -> Render () +renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list -> + if null list + then throwError "renderCoordPairListBracketed: Unexpected empty list." + else mapM_ renderCoordPairBracketed list + +renderCoordPairListPretty :: [(Coord, Coord)] -> Render () +renderCoordPairListPretty list = + if null list + then throwError "renderCoordPairListPretty: Unexpected empty list." + else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list + +renderDoubleBracketed :: DoubleValue -> Render () +renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of + Double1 -> "1" + Double2 -> "2" + +renderDoublePretty :: DoubleValue -> Render () +renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of + Double1 -> "1" + Double2 -> "2" + +renderGameResultBracketed :: GameResult -> Render () +renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of + GameResultWin color reason -> + tell $ + (case color of { Black -> 'B'; White -> 'W' }) : '+' : + (case reason of + WinByScore diff -> show diff + WinByResignation -> "R" + WinByTime -> "T" + WinByForfeit -> "F") + GameResultDraw -> tell "0" + GameResultVoid -> tell "Void" + GameResultUnknown -> tell "?" + GameResultOther text -> renderStringlike False text + +renderGameResultPretty :: GameResult -> Render () +renderGameResultPretty = rendererOf "game result pretty" $ \result -> case result of + GameResultWin color reason -> + tell $ + (case color of { Black -> 'B'; White -> 'W' }) : '+' : + (case reason of + WinByScore diff -> show diff + WinByResignation -> "Resign" + WinByTime -> "Time" + WinByForfeit -> "Forfeit") + GameResultDraw -> tell "Draw" + GameResultVoid -> tell "Void" + GameResultUnknown -> tell "Unknown" + GameResultOther text -> renderStringlikePretty text + +renderIntegralBracketed :: (Integral a, Show a) => a -> Render () +renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable + +renderIntegralPretty :: (Integral a, Show a) => a -> Render () +renderIntegralPretty = rendererOf "integral pretty" renderShowable + +renderLabelListBracketed :: [(Coord, SimpleText)] -> Render () +renderLabelListBracketed = rendererOf "label list" $ \list -> + if null list + then throwError "renderLabelListBracketed: Unexpected empty list." + else forM_ list $ bracketed . \(coord, text) -> do + renderCoord coord + tell ":" + renderStringlike True text + +renderLabelListPretty :: [(Coord, SimpleText)] -> Render () +renderLabelListPretty = rendererOf "label list pretty" $ \list -> + if null list + then throwError "renderLabelListPretty: Unexpected empty list." + else sequence_ $ intersperse (tell ", ") $ + map (\(coord, text) -> do + renderCoordPretty coord + tell ":" + renderStringlikePretty text) + list + +renderMoveBracketed :: Maybe Coord -> Render () +renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed + +renderMovePretty :: Maybe Coord -> Render () +renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty + +renderNoneBracketed :: () -> Render () +renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]" + +renderNonePretty :: () -> Render () +renderNonePretty = rendererOf "none pretty" $ tell . const "" + +renderRealBracketed :: RealValue -> Render () +renderRealBracketed = fmap bracketed $ rendererOf "real" $ renderShowable . fromRational + +renderRealPretty :: RealValue -> Render () +renderRealPretty = rendererOf "real pretty" renderShowable + +renderRulesetBracketed :: Ruleset -> Render () +renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset + +renderRulesetPretty :: Ruleset -> Render () +renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset + +renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render () +renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do + renderStringlike True a + tell ":" + renderStringlike True b + +renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render () +renderSimpleTextPairPretty = fmap bracketed $ rendererOf "simple text pair pretty" $ \(a, b) -> do + renderStringlike True a + tell " " + renderStringlike True b + +renderSimpleTextBracketed :: SimpleText -> Render () +renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False + +renderSimpleTextPretty :: SimpleText -> Render () +renderSimpleTextPretty = fmap bracketed $ rendererOf "simple text pretty" $ tell . fromSimpleText + +renderSizeBracketed :: (Int, Int) -> Render () +renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do + tell $ show x + when (x /= y) $ tell $ ':' : show y + +renderSizePretty :: (Int, Int) -> Render () +renderSizePretty = rendererOf "size pretty" renderCoordPretty + +renderTextBracketed :: Text -> Render () +renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False + +renderTextPretty :: Text -> Render () +renderTextPretty = fmap bracketed $ rendererOf "text pretty" $ tell . fromText + +renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render () +renderUnknownPropertyBracketed = + fmap bracketed $ rendererOf "unknown property" $ renderStringlike False + +renderUnknownPropertyPretty :: UnknownPropertyValue -> Render () +renderUnknownPropertyPretty = + rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue + +renderVariationModeBracketed :: VariationMode -> Render () +renderVariationModeBracketed = + fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode + +renderVariationModePretty :: VariationMode -> Render () +renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) -> + tell $ + (case source of + ShowChildVariations -> "Children" + ShowCurrentVariations -> "Current") ++ " " ++ + (if markup then "Shown" else "Hidden") diff --git a/src/Game/Goatee/Sgf/Property/Value.hs b/src/Game/Goatee/Sgf/Property/Value.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Property/Value.hs @@ -0,0 +1,179 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Metadata about the types of property values. +-- +-- Import "Game.Goatee.Sgf.Property" rather than importing this module. +module Game.Goatee.Sgf.Property.Value ( + PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, + colorPvt, + coordElistPvt, + coordListPvt, + coordPairListPvt, + doublePvt, + gameResultPvt, + integralPvt, + labelListPvt, + movePvt, + nonePvt, + realPvt, + rulesetPvt, + simpleTextPairPvt, + simpleTextPvt, + sizePvt, + textPvt, + unknownPropertyPvt, + variationModePvt, + ) where + +import qualified Game.Goatee.Sgf.Property.Parser as P +import qualified Game.Goatee.Sgf.Property.Renderer as R +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Types +import Text.ParserCombinators.Parsec (Parser) + +data PropertyValueType a = PropertyValueType { + pvtParser :: Parser a + , pvtRenderer :: a -> Render () + , pvtRendererPretty :: a -> Render () + } + +colorPvt :: PropertyValueType Color +colorPvt = PropertyValueType { + pvtParser = P.colorParser + , pvtRenderer = R.renderColorBracketed + , pvtRendererPretty = R.renderColorPretty + } + +coordElistPvt :: PropertyValueType CoordList +coordElistPvt = PropertyValueType { + pvtParser = P.coordElistParser + , pvtRenderer = R.renderCoordElistBracketed + , pvtRendererPretty = R.renderCoordElistPretty + } + +coordListPvt :: PropertyValueType CoordList +coordListPvt = PropertyValueType { + pvtParser = P.coordListParser + , pvtRenderer = R.renderCoordListBracketed + , pvtRendererPretty = R.renderCoordListPretty + } + +coordPairListPvt :: PropertyValueType [(Coord, Coord)] +coordPairListPvt = PropertyValueType { + pvtParser = P.coordPairListParser + , pvtRenderer = R.renderCoordPairListBracketed + , pvtRendererPretty = R.renderCoordPairListPretty + } + +doublePvt :: PropertyValueType DoubleValue +doublePvt = PropertyValueType { + pvtParser = P.doubleParser + , pvtRenderer = R.renderDoubleBracketed + , pvtRendererPretty = R.renderDoublePretty + } + +gameResultPvt :: PropertyValueType GameResult +gameResultPvt = PropertyValueType { + pvtParser = P.gameResultParser + , pvtRenderer = R.renderGameResultBracketed + , pvtRendererPretty = R.renderGameResultPretty + } + +integralPvt :: (Integral a, Read a, Show a) => PropertyValueType a +integralPvt = PropertyValueType { + pvtParser = P.integralParser + , pvtRenderer = R.renderIntegralBracketed + , pvtRendererPretty = R.renderIntegralPretty + } + +labelListPvt :: PropertyValueType [(Coord, SimpleText)] +labelListPvt = PropertyValueType { + pvtParser = P.labelListParser + , pvtRenderer = R.renderLabelListBracketed + , pvtRendererPretty = R.renderLabelListPretty + } + +movePvt :: PropertyValueType (Maybe Coord) +movePvt = PropertyValueType { + pvtParser = P.moveParser + , pvtRenderer = R.renderMoveBracketed + , pvtRendererPretty = R.renderMovePretty + } + +nonePvt :: PropertyValueType () +nonePvt = PropertyValueType { + pvtParser = P.noneParser + , pvtRenderer = R.renderNoneBracketed + , pvtRendererPretty = R.renderNonePretty + } + +realPvt :: PropertyValueType RealValue +realPvt = PropertyValueType { + pvtParser = P.realParser + , pvtRenderer = R.renderRealBracketed + , pvtRendererPretty = R.renderRealPretty + } + +rulesetPvt :: PropertyValueType Ruleset +rulesetPvt = PropertyValueType { + pvtParser = P.rulesetParser + , pvtRenderer = R.renderRulesetBracketed + , pvtRendererPretty = R.renderRulesetPretty + } + +simpleTextPairPvt :: PropertyValueType (SimpleText, SimpleText) +simpleTextPairPvt = PropertyValueType { + pvtParser = P.simpleTextPairParser + , pvtRenderer = R.renderSimpleTextPairBracketed + , pvtRendererPretty = R.renderSimpleTextPairPretty + } + +simpleTextPvt :: PropertyValueType SimpleText +simpleTextPvt = PropertyValueType { + pvtParser = P.simpleTextParser + , pvtRenderer = R.renderSimpleTextBracketed + , pvtRendererPretty = R.renderSimpleTextPretty + } + +sizePvt :: PropertyValueType (Int, Int) +sizePvt = PropertyValueType { + pvtParser = P.sizeParser + , pvtRenderer = R.renderSizeBracketed + , pvtRendererPretty = R.renderSizePretty + } + +textPvt :: PropertyValueType Text +textPvt = PropertyValueType { + pvtParser = P.textParser + , pvtRenderer = R.renderTextBracketed + , pvtRendererPretty = R.renderTextPretty + } + +unknownPropertyPvt :: PropertyValueType UnknownPropertyValue +unknownPropertyPvt = PropertyValueType { + pvtParser = P.unknownPropertyParser + , pvtRenderer = R.renderUnknownPropertyBracketed + , pvtRendererPretty = R.renderUnknownPropertyPretty + } + +variationModePvt :: PropertyValueType VariationMode +variationModePvt = PropertyValueType { + pvtParser = P.variationModeParser + , pvtRenderer = R.renderVariationModeBracketed + , pvtRendererPretty = R.renderVariationModePretty + } diff --git a/src/Game/Goatee/Sgf/Renderer.hs b/src/Game/Goatee/Sgf/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Renderer.hs @@ -0,0 +1,56 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +{-# LANGUAGE CPP #-} + +-- | Common definitions for a renderer that supports failure. +module Game.Goatee.Sgf.Renderer ( + Render, + runRender, + rendererOf, + ) where + +#if MIN_VERSION_base(4,6,0) +import Control.Monad.Except (Except, catchError, runExcept, throwError) +#else +import Control.Monad.Error (catchError, throwError) +#endif +import Control.Monad.Writer (WriterT, execWriterT) + +-- | A monad for accumulating string output with the possibility of failure. +#if MIN_VERSION_base(4,6,0) +type Render = WriterT String (Except String) +#else +type Render = WriterT String (Either String) +#endif + +-- | Returns either the rendered result on the right, or a message describing a +-- failure on the left. +runRender :: Render a -> Either String String +#if MIN_VERSION_base(4,6,0) +runRender = runExcept . execWriterT +#else +runRender = execWriterT +#endif + +-- | Wraps a renderer in an exception handler that, when the renderer or +-- something it calls fails, will add context about this renderer's invocation +-- to the failure message. +rendererOf :: Show a => String -> (a -> Render ()) -> a -> Render () +rendererOf description renderer value = catchError (renderer value) $ \message -> + throwError $ + message ++ "\n while trying to render " ++ description ++ " from " ++ show value ++ "." diff --git a/src/Game/Goatee/Sgf/Renderer/Tree.hs b/src/Game/Goatee/Sgf/Renderer/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Renderer/Tree.hs @@ -0,0 +1,56 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Functions for serializing SGF trees. +module Game.Goatee.Sgf.Renderer.Tree ( + renderCollection, + ) where + +import Control.Monad (forM_) +import Control.Monad.Writer (tell) +import Game.Goatee.Common +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Tree + +-- | Renders an SGF 'Collection' to a string. +renderCollection :: Collection -> Render () +renderCollection collection = do + mapM_ renderGameTree $ collectionTrees collection + tell "\n" + +-- | Recursively renders an SGF GameTree (as defined in the spec) rooted at the +-- given node. +renderGameTree :: Node -> Render () +renderGameTree node = do + tell "(" + doWhileM node + (\node' -> do renderNode node' + case nodeChildren node' of + [] -> return $ Left Nothing + child:[] -> return $ Right child + children -> return $ Left $ Just children) + >>= maybe (return ()) (mapM_ renderGameTree) + tell ")" + +-- | Renders a node and its properties without recurring to its children. +renderNode :: Node -> Render () +renderNode node = do + tell "\n;" + forM_ (nodeProperties node) $ \property -> do + tell $ propertyName property + propertyValueRenderer property property diff --git a/src/Game/Goatee/Sgf/Tree.hs b/src/Game/Goatee/Sgf/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Tree.hs @@ -0,0 +1,175 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | SGF data structures modelling the hierarchical game tree. +module Game.Goatee.Sgf.Tree ( + Collection(..), CollectionWithDeepEquality(..), + Node(..), NodeWithDeepEquality(..), + emptyNode, rootNode, + findProperty, findProperty', findPropertyValue, findPropertyValue', + addProperty, addChild, addChildAt, + validateNode, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_, unless, when) +import Control.Monad.Writer (Writer, execWriter, tell) +import Data.Function (on) +import Data.List (find, groupBy, intercalate, nub, sortBy) +import Data.Version (showVersion) +import Game.Goatee.App (applicationName) +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Types +import Paths_goatee (version) + +-- | An SGF collection of game trees. +data Collection = Collection { collectionTrees :: [Node] + } deriving (Show) + +-- | See 'NodeWithDeepEquality'. +newtype CollectionWithDeepEquality = CollectionWithDeepEquality { + collectionWithDeepEquality :: Collection + } deriving (Show) + +instance Eq CollectionWithDeepEquality where + (==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality + +-- | An SGF game tree node. Unlike in the SGF spec, we represent a game tree +-- with nodes uniformly, rather than having the separation between sequences and +-- nodes. +data Node = Node { nodeProperties :: [Property] + , nodeChildren :: [Node] + } deriving (Show) + +-- | A wrapper around 'Node' with an 'Eq' instance that considers two nodes +-- equal iff they contain the same properties (not necessarily in the same +-- order), and if they contain children (in the same order) whose nodes are +-- recursively equal. +-- +-- This instance is not on 'Node' directly because it is not the only obvious +-- sense of equality (only comparing properties would be another one), and it's +-- also potentially expensive. +newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node } + +instance Eq NodeWithDeepEquality where + node1 == node2 = + let n1 = nodeWithDeepEquality node1 + n2 = nodeWithDeepEquality node2 + in propertiesSorted n1 == propertiesSorted n2 && + deepChildren n1 == deepChildren n2 + where propertiesSorted = sortBy (compare `on` show) . nodeProperties + deepChildren = map NodeWithDeepEquality . nodeChildren + +-- | A node with no properties and no children. +emptyNode :: Node +emptyNode = Node { nodeProperties = [], nodeChildren = [] } + +-- | Returns a fresh root 'Node' with 'AP' set to Goatee and optionally with a +-- board size set via 'SZ'. +rootNode :: Maybe (Int, Int) -> Node +rootNode maybeSize = + let props = FF 4 : + GM 1 : + AP (toSimpleText applicationName) + (toSimpleText $ showVersion version) : + maybe [] ((:[]) . uncurry SZ) maybeSize + in Node { nodeProperties = props + , nodeChildren = [] + } + +-- | Searches for a matching property in a node's property list. +findProperty :: Descriptor a => a -> Node -> Maybe Property +findProperty descriptor node = findProperty' descriptor $ nodeProperties node + +-- | Searches for a matching property in a property list. +findProperty' :: Descriptor a => a -> [Property] -> Maybe Property +findProperty' = find . propertyPredicate + +-- | Retrieves the value of a property in a node's property list. +findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v +findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node + +-- | Retrieves the value of a property in a property list. +findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v +findPropertyValue' descriptor properties = + propertyValue descriptor <$> findProperty' descriptor properties + +-- | Appends a property to a node's property list. +addProperty :: Property -> Node -> Node +addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] } + +-- | @addChild child parent@ appends a child node to a node's child list. +addChild :: Node -> Node -> Node +addChild child node = node { nodeChildren = nodeChildren node ++ [child] } + +-- | @addChildAt index child parent@ inserts a child node into a node's child +-- list at the given index, shifting all nodes at or after the given index to +-- the right. The index must be in the range @[0, numberOfChildren]@. +addChildAt :: Int -> Node -> Node -> Node +addChildAt index child node = + let (before, after) = splitAt index $ nodeChildren node + in node { nodeChildren = before ++ child:after } + +-- | Returns a list of validation errors for the current node, an +-- empty list if no errors are detected. +validateNode :: Bool -> Bool -> Node -> [String] +validateNode isRoot _{-seenGameNode-} node = execWriter $ do + let props = nodeProperties node + let propTypes = nub $ map propertyType $ nodeProperties node + + -- Check for move and setup properties in a single node. + when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $ + tell ["Node contains move and setup properties."] + + -- Check for root properties in non-root nodes. + let rootProps = filter ((RootProperty ==) . propertyType) props + when (not isRoot && not (null rootProps)) $ + tell $ map (\p -> "Root property found on non-root node: " ++ + show p ++ ".") + rootProps + + -- TODO Check for game-info properties. + + -- Check for coordinates marked multiple times. + validateNodeDuplicates props getMarkedCoords $ \group -> + tell ["Coordinate " ++ show (fst $ head group) ++ + " is specified multiple times in properties " ++ + intercalate ", " (map snd group) ++ "."] + + -- TODO Validate recursively. + + where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR" + getMarkedCoords (MA cs) = tagMarkedCoords cs "MA" + getMarkedCoords (SL cs) = tagMarkedCoords cs "SL" + getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ" + getMarkedCoords (TR cs) = tagMarkedCoords cs "TR" + getMarkedCoords _ = [] + + tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs + +validateNodeDuplicates :: (Eq v, Ord v) + => [Property] + -> (Property -> [(v, t)]) + -> ([(v, t)] -> Writer [String] ()) + -> Writer [String] () +validateNodeDuplicates props getTaggedElts errAction = + let groups = groupBy ((==) `on` fst) $ + sortBy (compare `on` fst) $ + concatMap getTaggedElts props + in forM_ groups $ \group -> + unless (null $ tail group) $ + errAction group diff --git a/src/Game/Goatee/Sgf/Types.hs b/src/Game/Goatee/Sgf/Types.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Sgf/Types.hs @@ -0,0 +1,389 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Constants and data types for property values used in SGF game trees. +module Game.Goatee.Sgf.Types ( + supportedFormatVersions, defaultFormatVersion, supportedGameTypes, + boardSizeDefault, boardSizeMin, boardSizeMax, + Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords', + emptyCoordList, expandCoordList, buildCoordList, + RealValue, + Stringlike (..), + Text, fromText, toText, + SimpleText, fromSimpleText, toSimpleText, + UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue, + DoubleValue (..), + Color (..), cnot, + VariationMode (..), VariationModeSource (..), defaultVariationMode, + toVariationMode, fromVariationMode, + ArrowList, LineList, LabelList, Mark (..), + GameResult (..), + WinReason (..), + Ruleset (..), RulesetType (..), fromRuleset, toRuleset, + ) where + +import Data.Char (isSpace) +import Data.Function (on) +import Data.List (delete, groupBy, partition, sort) + +-- TODO Support FF versions 1-4. +supportedFormatVersions :: [Int] +supportedFormatVersions = [4] + +-- | The default SGF version to use when @FF[]@ is not specified in a root node. +-- +-- This value is actually INCORRECT: SGF defines it to be 1, but because we +-- don't support version 1 yet, for the sake of ignoring this issue (for now!) +-- in tests, we fix the default to be 4. +-- +-- TODO Fix the default version to be 1 as SGF mandates. +defaultFormatVersion :: Int +defaultFormatVersion = 4 + +supportedGameTypes :: [Int] +supportedGameTypes = [1 {- Go -}] + +-- | The default size of the board. The FF[4] SGF spec says that the default Go +-- board is 19x19 square. +boardSizeDefault :: Int +boardSizeDefault = 19 + +-- | The minimum board size allowed by FF[4], 1. +boardSizeMin :: Int +boardSizeMin = 1 + +-- | The maximum board size allowed by FF[4], 52. +boardSizeMax :: Int +boardSizeMax = 52 + +-- | A coordinate on a Go board. @(0, 0)@ refers to the upper-left corner of +-- the board. The first component is the horizontal position; the second +-- component is the vertical position. +type Coord = (Int, Int) + +-- | A structure for compact representation of a list of coordinates. Contains +-- a list of individual points, as well as a list of rectangles of points +-- denoted by an ordered pair of the upper-left point and the lower-right point. +-- The union of the single points and points contained within rectangles make up +-- all of the points a @CoordList@ represents. There is no rule saying that +-- adjacent points have to be grouped into rectangles; it's perfectly valid +-- (although possibly inefficient) to never use rectangles. +-- +-- For any @CoordList@, all of the following hold: +-- +-- 1. Any point may be specified at most once, either in the singles list or in +-- a single rectangle. +-- +-- 2. For a rectangle @((x0,y0), (x1,y1))@, @x0 <= x1@ and @y0 <= y1@ and +-- @(x0,y0) /= (x1,y1)@ (otherwise the point belongs in the singles list). +data CoordList = CoordList { + coordListSingles :: [Coord] + -- ^ Returns the single points in a 'CoordList'. + , coordListRects :: [(Coord, Coord)] + -- ^ Returns the rectangles in a 'CoordList'. + } deriving (Show) + +-- | Equality is based on unordered, set equality of the underlying points. +instance Eq CoordList where + (==) = (==) `on` sort . expandCoordList + +-- | Constructs a 'CoordList' containing a single point. +coord1 :: Coord -> CoordList +coord1 xy = CoordList { coordListSingles = [xy] + , coordListRects = [] + } + +-- | Constructs a 'CoordList' containing the given single points. For rectangle +-- detection, use 'buildCoordList'. +coords :: [Coord] -> CoordList +coords singles = CoordList { coordListSingles = singles + , coordListRects = [] + } + +-- | Constructs a 'CoordList' containing the given single points and rectangles. +coords' :: [Coord] -> [(Coord, Coord)] -> CoordList +coords' singles rects = CoordList { coordListSingles = singles + , coordListRects = rects + } + +-- | A 'CoordList' that contains no points. +emptyCoordList :: CoordList +emptyCoordList = CoordList { coordListSingles = [] + , coordListRects = [] + } + +-- | Converts a compact 'CoordList' to a list of coordinates. +expandCoordList :: CoordList -> [Coord] +expandCoordList cl = coordListSingles cl ++ + foldr (\r@((x0, y0), (x1, y1)) rest -> + if x0 > x1 || y0 > y1 + then error ("Invalid coord. rectangle: " ++ show r) + else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest) + [] + (coordListRects cl) + +-- | Constructs a 'CoordList' from a list of 'Coord's, doing some +-- not-completely-stupid rectangle detection. The order of data in the result +-- is unspecified. +buildCoordList :: [Coord] -> CoordList +-- This algorithm doesn't generate the smallest result. For the following +-- input: +-- +-- F F T T +-- T T T T +-- T T F F +-- +-- It will return [ca:da][ab:db][ac:bc] rather than the shorter [ca:db][ab:bc]. +buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid + where -- | Constructs a row-major grid of booleans where an coordinate is true + -- iff it is in the given list. + toGrid :: [Coord] -> [[Bool]] + toGrid [] = [] + toGrid coords = let x1 = maximum $ map fst coords + y1 = maximum $ map snd coords + in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]] + + -- | For each row, converts a list of booleans into a list of pairs + -- where each pair represents a consecutive run of true values. The + -- pair indicates the indices of the first and last boolean in each run. + buildTruePairs :: [[Bool]] -> [[(Int, Int)]] + buildTruePairs = map $ + concatMap extractTrueGroups . + groupBy ((==) `on` snd) . + zip [0..] + + -- | Given a run of indexed booleans with the same boolean value within + -- a row, returns @[(startIndex, endIndex)]@ if the value is true, and + -- @[]@ if the value is false. + extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)] + extractTrueGroups list@((start, True):_) = [(start, fst (last list))] + extractTrueGroups _ = [] + + -- | Converts the lists of true pairs for all rows into a list of + -- @(Coord, Coord)@ rectangles. We repeatedly grab the first span in + -- the first row, and see how many leading rows contain that exact span. + -- Then we build a (maybe multi-row) rectangle for the span, remove the + -- span from all leading rows, and repeat. When the first row becomes + -- empty, we drop it and increment a counter that keeps track of our + -- first row's y-position. + generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)] + generateRects _ acc [] = acc + generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows + generateRects topRowOffset acc rows@((span:_):_) = + let rowsWithSpan = matchRowsWithSpan span rows + rowsWithSpanCount = length rowsWithSpan + in generateRects topRowOffset + (((fst span, topRowOffset), + (snd span, topRowOffset + rowsWithSpanCount - 1)) : acc) + (rowsWithSpan ++ drop rowsWithSpanCount rows) + + -- | Determines how many leading rows contain the given span. A list of + -- all the matching rows is returned, with the span deleted from each. + matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]] + matchRowsWithSpan span (row:rows) + | span `elem` row = delete span row : matchRowsWithSpan span rows + | otherwise = [] + matchRowsWithSpan _ [] = [] + + -- | Builds a 'CoordList' from simple @(Coord, Coord)@ rectangles. + toCoordList :: [(Coord, Coord)] -> CoordList + toCoordList rects = + let (singles, properRects) = partition (uncurry (==)) rects + in coords' (map fst singles) properRects + +-- | An SGF real value. +type RealValue = Rational + +-- | A class for SGF data types that are coercable to and from strings. +-- +-- The construction of an SGF value with 'stringToSgf' may process the input, +-- such that the resulting stringlike value does not represent the same string +-- as the input. In other words, the following does *not* necessarily hold: +-- +-- > sgfToString . stringToSgf = id (does not necessarily hold!) +-- +-- The following does hold, however: +-- +-- > stringToSgf . sgfToString = id +class Stringlike a where + -- | Extracts the string value from an SGF value. + sgfToString :: a -> String + + -- | Creates an SGF value from a string value. + stringToSgf :: String -> a + +-- | An SGF text value. +newtype Text = Text { fromText :: String + -- ^ Converts an SGF 'Text' to a string. + } + deriving (Eq, Show) + +instance Stringlike Text where + sgfToString = fromText + stringToSgf = toText + +-- | Converts a string to an SGF 'Text'. +toText :: String -> Text +toText = Text + +-- | An SGF SimpleText value. +newtype SimpleText = SimpleText { fromSimpleText :: String + -- ^ Converts an SGF 'SimpleText' to a string. + } + deriving (Eq, Show) + +instance Stringlike SimpleText where + sgfToString = fromSimpleText + stringToSgf = toSimpleText + +sanitizeSimpleText :: String -> String +sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c) + +-- | Converts a string to an SGF 'SimpleText', replacing all whitespaces +-- (including newlines) with spaces. +toSimpleText :: String -> SimpleText +toSimpleText = SimpleText . sanitizeSimpleText + +-- | The value type for an 'UnknownProperty'. Currently represented as a +-- string. +data UnknownPropertyValue = UnknownPropertyValue { + fromUnknownPropertyValue :: String + -- ^ Returns the string contained within the 'UnknownProperty' this value is + -- from. + } deriving (Eq, Show) + +instance Stringlike UnknownPropertyValue where + sgfToString = fromUnknownPropertyValue + stringToSgf = toUnknownPropertyValue + +-- | Constructs a value for a 'UnknownProperty'. +toUnknownPropertyValue :: String -> UnknownPropertyValue +toUnknownPropertyValue = UnknownPropertyValue + +-- | An SGF double value: either 1 or 2, nothing else. +data DoubleValue = Double1 + | Double2 + deriving (Eq, Show) + +-- | Stone color: black or white. +data Color = Black + | White + deriving (Eq, Show) + +-- | Returns the logical negation of a stone color, yang for yin and +-- yin for yang. +cnot :: Color -> Color +cnot Black = White +cnot White = Black + +-- | SGF flags that control how move variations are to be presented while +-- displaying the game. +data VariationMode = VariationMode { + variationModeSource :: VariationModeSource + -- ^ Which moves to display as variations. + , variationModeBoardMarkup :: Bool + -- ^ Whether to overlay variations on the board. + } deriving (Eq, Show) + +-- | An enumeration that describes which variations are shown. +data VariationModeSource = + ShowChildVariations + -- ^ Show children of the current move. + | ShowCurrentVariations + -- ^ Show alternatives to the current move. + deriving (Bounded, Enum, Eq, Show) + +-- | The default variation mode as defined by the SGF spec is @VariationMode +-- ShowChildVariations True@. +defaultVariationMode :: VariationMode +defaultVariationMode = VariationMode ShowChildVariations True + +-- | Parses a numeric variation mode, returning nothing if the number is +-- invalid. +toVariationMode :: Int -> Maybe VariationMode +toVariationMode n = case n of + 0 -> Just $ VariationMode ShowChildVariations True + 1 -> Just $ VariationMode ShowCurrentVariations True + 2 -> Just $ VariationMode ShowChildVariations False + 3 -> Just $ VariationMode ShowCurrentVariations False + _ -> Nothing + +-- | Returns the integer value for a variation mode. +fromVariationMode :: VariationMode -> Int +fromVariationMode mode = case mode of + VariationMode ShowChildVariations True -> 0 + VariationMode ShowCurrentVariations True -> 1 + VariationMode ShowChildVariations False -> 2 + VariationMode ShowCurrentVariations False -> 3 + +-- | A list of arrows, each specified as @(startCoord, endCoord)@. +type ArrowList = [(Coord, Coord)] + +-- | A list of lines, each specified as @(startCoord, endCoord)@. +type LineList = [(Coord, Coord)] + +-- | A list of labels, each specified with a string and a coordinate about which +-- to center the string. +type LabelList = [(Coord, SimpleText)] + +-- | The markings that SGF supports annotating coordinates with. +data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected + deriving (Bounded, Enum, Eq, Show) + +data GameResult = GameResultWin Color WinReason + | GameResultDraw + | GameResultVoid + | GameResultUnknown + | GameResultOther SimpleText + deriving (Eq, Show) + +data WinReason = WinByScore RealValue + | WinByResignation + | WinByTime + | WinByForfeit + deriving (Eq, Show) + +-- | A ruleset used for a Go game. Can be one of the rulesets defined by the +-- SGF specification, or a custom string. +data Ruleset = KnownRuleset RulesetType + | UnknownRuleset String + deriving (Eq, Show) + +-- | The rulesets defined by the SGF specification, for use with 'Ruleset'. +data RulesetType = RulesetAga + | RulesetIng + | RulesetJapanese + | RulesetNewZealand + deriving (Bounded, Enum, Eq, Show) + +-- | Returns the string representation for a ruleset. +fromRuleset :: Ruleset -> String +fromRuleset ruleset = case ruleset of + KnownRuleset RulesetAga -> "AGA" + KnownRuleset RulesetIng -> "Goe" + KnownRuleset RulesetJapanese -> "Japanese" + KnownRuleset RulesetNewZealand -> "NZ" + UnknownRuleset str -> str + +-- | Parses a string representation of a ruleset. +toRuleset :: String -> Ruleset +toRuleset str = case str of + "AGA" -> KnownRuleset RulesetAga + "Goe" -> KnownRuleset RulesetIng + "Japanese" -> KnownRuleset RulesetJapanese + "NZ" -> KnownRuleset RulesetNewZealand + _ -> UnknownRuleset str diff --git a/tests/Game/Goatee/CommonTest.hs b/tests/Game/Goatee/CommonTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/CommonTest.hs @@ -0,0 +1,271 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.CommonTest (tests) where + +import qualified Control.Monad.State as State +import Control.Monad.Identity (runIdentity) +import Control.Monad.State (StateT, get, put, runStateT) +import Control.Monad.Writer (execWriter, tell) +import Data.IORef (modifyIORef, newIORef, readIORef) +import Data.Monoid (mappend, mempty) +import Game.Goatee.Common +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), assertFailure) + +{-# ANN module "HLint: ignore Use camelCase" #-} + +tests = testGroup "Game.Goatee.Common" [ + listDeleteIndexTests, + listReplaceTests, + onLeftTests, + onRightTests, + andEithersTests, + forTests, + mapTupleTests, + whenMaybeTests, + condTests, + if'Tests, + andMTests, + forIndexM_Tests, + whileMTests, + whileM'Tests, + doWhileMTests, + seqTests + ] + +listDeleteIndexTests = testGroup "listDeleteIndex" [ + testCase "deletes nothing from an empty list" $ do + [] @=? listDeleteIndex (-1) ([] :: [()]) + [] @=? listDeleteIndex 0 ([] :: [()]) + [] @=? listDeleteIndex 1 ([] :: [()]), + + testCase "deletes the only item from a singleton list" $ + [] @=? listDeleteIndex 0 [()], + + testCase "deletes the head of a list" $ + [False] @=? listDeleteIndex 0 [True, False], + + testCase "deletes the tail of a list" $ + [Just 0, Nothing] @=? listDeleteIndex 2 [Just 0, Nothing, Just 1], + + testCase "deletes an inner item from a list" $ + [Just 0, Just 1] @=? listDeleteIndex 1 [Just 0, Nothing, Just 1], + + testCase "ignores a negative index" $ do + [1, 2, 3] @=? listDeleteIndex (-1) [1, 2, 3] + [1, 2, 3] @=? listDeleteIndex (-2) [1, 2, 3], + + testCase "ignores an index too large" $ do + [1, 2, 3] @=? listDeleteIndex 3 [1, 2, 3] + [1, 2, 3] @=? listDeleteIndex 4 [1, 2, 3] + ] + +listReplaceTests = testGroup "listReplace" [ + testCase "accepts an empty list" $ + [] @=? listReplace False True [], + + testCase "replaces the first element" $ + [100, 2, 3] @=? listReplace 1 100 [1, 2, 3], + + testCase "replaces the last element" $ + [1, 2, 300] @=? listReplace 3 300 [1, 2, 3], + + testCase "replaces an interior element" $ + [1, 200, 3] @=? listReplace 2 200 [1, 2, 3], + + testCase "replaces multiple elements" $ do + [1, 0, 3, 4, 0, 0, 3] @=? listReplace 2 0 [1, 2, 3, 4, 2, 2, 3] + replicate 10 True @=? listReplace False True (replicate 10 False) + ] + +onLeftTests = testGroup "onLeft" [ + testCase "changes a Left" $ + Left 10 @=? onLeft (* 2) (Left 5 :: Either Int ()), + + testCase "doesn't change a Right" $ + Right False @=? onLeft (* 2) (Right False) + ] + +onRightTests = testGroup "onRight" [ + testCase "doesn't change a Left" $ + Left False @=? onRight (* 2) (Left False), + + testCase "changes a Right" $ + Right 10 @=? onRight (* 2) (Right 5 :: Either () Int) + ] + +andEithersTests = testGroup "andEithers" [ + testCase "returns Right for an empty list" $ + Right [] @=? andEithers ([] :: [Either () ()]), + + testCase "returns Right when given all Rights" $ do + Right [1] @=? andEithers [Right 1 :: Either () Int] + Right [1, 2] @=? andEithers [Right 1, Right 2 :: Either () Int] + Right [1, 2, 3] @=? andEithers [Right 1, Right 2, Right 3 :: Either () Int], + + testCase "returns Left when there is a single Left" $ do + Left [1] @=? andEithers [Left 1 :: Either Int ()] + Left [1] @=? andEithers [Left 1, Right 2] + Left [2] @=? andEithers [Right 1, Left 2] + Left [2] @=? andEithers [Right 1, Left 2, Right 3] + Left [3] @=? andEithers [Right 1, Right 2, Left 3], + + testCase "returns Left when there are many Lefts" $ do + Left [1, 2] @=? andEithers [Left 1, Left 2, Right 3] + Left [1, 3] @=? andEithers [Left 1, Right 2, Left 3] + Left [2, 3] @=? andEithers [Right 1, Left 2, Left 3] + Left [1, 2, 3] @=? andEithers [Left 1, Left 2, Left 3 :: Either Int ()] + ] + +forTests = testGroup "for" [ + testCase "passes an empty list through" $ + ([] @=?) =<< sequence (for [] $ const $ assertFailure "Nope."), + + testCase "operates on each element of a list" $ + [2, 2, 4, 6, 10] @=? for [1, 1, 2, 3, 5] (* 2) + ] + +mapTupleTests = testGroup "mapTuple" [ + testCase "updates both values" $ + (9, 16) @=? mapTuple (^ 2) (3, 4) + ] + +whenMaybeTests = testGroup "whenMaybeTests" [ + testCase "doesn't invoke its function when given Nothing" $ + 0 @=? State.execState (whenMaybe Nothing $ \x -> State.put (x * 2)) 0, + + testCase "invokes its function when given a Just" $ + 6 @=? State.execState (whenMaybe (Just 3) $ \x -> State.put (x * 2)) 0 + ] + +condTests = testGroup "cond" [ + testCase "accepts an empty list of cases" $ + True @=? cond True [], + + testCase "returns the default when all cases are false" $ do + 0 @=? cond 0 [(False, 1)] + 0 @=? cond 0 [(False, 1), (False, 2)] + 0 @=? cond 0 [(False, 1), (False, 2), (False, 3)], + + testCase "returns a single true case" $ do + 3 @=? cond 0 [(False, 1), (False, 2), (True, 3)] + 2 @=? cond 0 [(False, 1), (True, 2), (False, 3)] + 1 @=? cond 0 [(True, 1), (False, 2), (False, 3)], + + testCase "returns the first true case" $ do + 3 @=? cond 0 [(False, 1), (False, 2), (True, 3)] + 2 @=? cond 0 [(False, 1), (True, 2), (True, 3)] + 1 @=? cond 0 [(True, 1), (True, 2), (True, 3)] + ] + +if'Tests = testGroup "if'" [ + testCase "detects true" $ "yes" @=? if' "yes" "no" True, + + testCase "detects false" $ "no" @=? if' "yes" "no" False + ] + +andMTests = testGroup "andM" [ + testCase "empty list returns true" $ True @=? runIdentity (andM []), + + testCase "aborts after an immediate true" $ do + ref <- newIORef 0 + result <- andM [addToRef ref 1 >> return False, + addToRef ref 2 >> return True] + False @=? result + (1 @=?) =<< readIORef ref, + + testCase "aborts on a false after trues" $ do + ref <- newIORef 0 + result <- andM [addToRef ref 1 >> return True, + addToRef ref 2 >> return True, + addToRef ref 4 >> return False, + addToRef ref 8 >> return False, + addToRef ref 16 >> return False] + False @=? result + (7 @=?) =<< readIORef ref, + + testCase "executes all trues" $ do + ref <- newIORef 0 + result <- andM [addToRef ref 1 >> return True, + addToRef ref 2 >> return True, + addToRef ref 4 >> return True, + addToRef ref 8 >> return True] + True @=? result + (15 @=?) =<< readIORef ref + ] + where addToRef ref num = modifyIORef ref (+ num) + +forIndexM_Tests = testGroup "forIndexM_" [ + testCase "does nothing with an empty list" $ + "" @=? execWriter (forIndexM_ [] $ \_ _ -> tell "x"), + + testCase "iterates over all elements in order" $ + "(0,'a')(1,'b')(2,'c')" @=? + execWriter (forIndexM_ "abc" $ \index value -> tell $ show (index, value)) + ] + +whileMTests = testGroup "whileM" [ + testCase "never executes the body if the first test returns false" $ + "" @=? execWriter (whileM (return False) (tell "x")), + + testCase "executes repeatedly as expected" $ + let test = do n <- get + tell $ show n + if n > 0 + then put (n - 1) >> return True + else return False + body = tell "x" + in "3x2x1x0" @=? execWriter (runStateT (whileM test body) 3) + ] + +whileM'Tests = testGroup "whileM'" [ + testCase "never executes the body if the first test returns Nothing" $ + "" @=? execWriter (whileM' (return Nothing) (const $ tell "x")), + + testCase "executes repeatedly as expected" $ + let test = get >>= \n -> return $ if n > 0 then Just n else Nothing + body n = do tell $ show n + put (n - 1) + in "321" @=? execWriter (runStateT (whileM' test body) 3) + ] + +doWhileMTests = testGroup "doWhileM" [ + testCase "executes a constantly-Left body once" $ do + countVar <- newIORef 0 + result <- doWhileM () (const $ do modifyIORef countVar (+ 1) + return $ Left "done") + count <- readIORef countVar + (1, "done") @=? (count, result), + + testCase "executes until a Left is returned" $ + execWriter (doWhileM 9 $ \n -> do + tell $ show n + return $ if n == 0 then Left () else Right $ n - 1) + @=? "9876543210" + ] + +seqTests = testGroup "Seq" [ + testCase "mempty does nothing" $ + let Seq action = mempty + in "" @=? execWriter action, + + testCase "mappend works" $ + let Seq action = Seq (tell "a") `mappend` Seq (tell "b") + in "ab" @=? execWriter action + ] diff --git a/tests/Game/Goatee/Sgf/BoardTest.hs b/tests/Game/Goatee/Sgf/BoardTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/BoardTest.hs @@ -0,0 +1,195 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.BoardTest (tests) where + +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.TestInstances () +import Game.Goatee.Sgf.TestUtils +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), (@?=)) + +tests = testGroup "Game.Goatee.Sgf.Board" [ + boardCoordStateTests, + moveNumberTests, + markupPropertiesTests, + visibilityPropertyTests, + cursorModifyNodeTests, + colorToMoveTests + ] + +boardCoordStateTests = testGroup "boardCoordState" [ + testCase "works for a 1x1 board" $ do + let state = boardCoordState (0,0) $ rootBoardState $ + node [SZ 1 1, CR $ coord1 (0,0)] + coordStone state @?= Nothing + coordMark state @?= Just MarkCircle, + + testCase "works for a 2x2 board" $ do + let board = rootBoardState $ + node [SZ 2 2, B $ Just (0,0), TR $ coord1 (0,0), MA $ coord1 (1,1)] + coordStone (boardCoordState (0,0) board) @?= Just Black + coordMark (boardCoordState (0,0) board) @?= Just MarkTriangle + coordStone (boardCoordState (1,0) board) @?= Nothing + coordMark (boardCoordState (1,0) board) @?= Nothing + coordStone (boardCoordState (1,1) board) @?= Nothing + coordMark (boardCoordState (1,1) board) @?= Just MarkX + ] + + +moveNumberTests = testGroup "move number" [ + testCase "starts at zero" $ + 0 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [] $ node [B Nothing]), + + testCase "advances for nodes with moves" $ do + 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [] $ node [B Nothing]) + 1 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [B Nothing] $ node []) + 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [B Nothing] $ node []) + 2 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [B Nothing] $ node [W Nothing]) + 2 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ + node1 [B Nothing] $ node1 [W Nothing] $ node []) + 3 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ + node1 [B Nothing] $ node1 [W Nothing] $ node [B Nothing]), + + testCase "doesn't advance for non-move nodes" $ do + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [PL White] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [AB $ coords [(0,0)]] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [IT, TE Double2, GN $ toSimpleText "Title"] $ node []) + ] + +markupPropertiesTests = testGroup "markup properties" [ + testGroup "adds marks to a BoardState" [ + testCase "CR" $ Just MarkCircle @=? getMark 0 0 (rootCursor $ node [CR $ coords [(0,0)]]), + testCase "MA" $ Just MarkX @=? getMark 0 0 (rootCursor $ node [MA $ coords [(0,0)]]), + testCase "SL" $ Just MarkSelected @=? getMark 0 0 (rootCursor $ node [SL $ coords [(0,0)]]), + testCase "SQ" $ Just MarkSquare @=? getMark 0 0 (rootCursor $ node [SQ $ coords [(0,0)]]), + testCase "TR" $ Just MarkTriangle @=? getMark 0 0 (rootCursor $ node [TR $ coords [(0,0)]]), + testCase "multiple at once" $ do + let cursor = rootCursor $ node [SZ 2 2, + CR $ coords [(0,0), (1,1)], + TR $ coords [(1,0)]] + [[Just MarkCircle, Just MarkTriangle], + [Nothing, Just MarkCircle]] + @=? map (map coordMark) (boardCoordStates $ cursorBoard cursor) + ], + + testGroup "adds more complex annotations to a BoardState" [ + testCase "AR" $ [((0,0), (1,1))] @=? boardArrows (rootCoord $ node [AR [((0,0), (1,1))]]), + testCase "LB" $ [((0,0), st "Hi")] @=? boardLabels (rootCoord $ node [LB [((0,0), st "Hi")]]), + testCase "LN" $ [((0,0), (1,1))] @=? boardLines (rootCoord $ node [LN [((0,0), (1,1))]]) + ], + + testCase "clears annotations when moving to a child node" $ do + let root = node1 [SZ 3 2, + CR $ coords [(0,0)], + MA $ coords [(1,0)], + SL $ coords [(2,0)], + SQ $ coords [(0,1)], + TR $ coords [(1,1)], + AR [((0,0), (2,1))], + LB [((2,1), st "Empty")], + LN [((1,1), (2,0))]] $ + node [] + board = cursorBoard $ child 0 $ rootCursor root + mapM_ (mapM_ ((Nothing @=?) . coordMark)) $ boardCoordStates board + [] @=? boardArrows board + [] @=? boardLines board + [] @=? boardLabels board + ] + where rootCoord = cursorBoard . rootCursor + st = toSimpleText + + getMark :: Int -> Int -> Cursor -> Maybe Mark + getMark x y cursor = coordMark $ boardCoordStates (cursorBoard cursor) !! y !! x + +visibilityPropertyTests = testGroup "visibility properties" [ + testCase "boards start with all points undimmed" $ + replicate 9 (replicate 9 False) @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]), + + testCase "DD selectively dims points" $ + let root = node [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] + in [[True, True, False, True, False], + [True, True, False, False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor root), + + testCase "dimming is inherited" $ + let root = node1 [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] $ node [] + in [[True, True, False, True, False], + [True, True, False, False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), + + testCase "DD[] clears dimming" $ + let root = node1 [SZ 2 1, DD $ coords [(0,0)]] $ node [DD $ coords []] + in [[False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), + + testCase "boards start with all points visible" $ + replicate 9 (replicate 9 True) @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]), + + testCase "VW selectively makes points visible" $ + let root = node [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] + in [[False, True, True, True, True], + [True, False, True, True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor root), + + testCase "visibility is inherited" $ + let root = node1 [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] $ node [] + in [[False, True, True, True, True], + [True, False, True, True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), + + testCase "VW[] clears dimming" $ + let root = node1 [SZ 2 1, VW $ coords [(0,0)]] $ node [VW $ coords []] + in [[True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) + ] + +cursorModifyNodeTests = testGroup "cursorModifyNode" [ + testCase "updates the BoardState" $ + let cursor = child 0 $ rootCursor $ + node1 [SZ 3 1, B $ Just (0,0)] $ + node [W $ Just (1,0)] + modifyProperty prop = case prop of + W (Just (1,0)) -> W $ Just (2,0) + _ -> prop + modifyNode node = node { nodeProperties = map modifyProperty $ nodeProperties node } + result = cursorModifyNode modifyNode cursor + in map (map coordStone) (boardCoordStates $ cursorBoard result) @?= + [[Just Black, Nothing, Just White]] + ] + +colorToMoveTests = testGroup "colorToMove" [ + testCase "creates Black moves" $ do + B (Just (3,2)) @=? colorToMove Black (3,2) + B (Just (0,0)) @=? colorToMove Black (0,0), + + testCase "creates White moves" $ do + W (Just (18,18)) @=? colorToMove White (18,18) + W (Just (15,16)) @=? colorToMove White (15,16) + ] diff --git a/tests/Game/Goatee/Sgf/MonadTest.hs b/tests/Game/Goatee/Sgf/MonadTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/MonadTest.hs @@ -0,0 +1,736 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.MonadTest (tests) where + +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Control.Monad (forM_, liftM, replicateM_, void) +import Control.Monad.Writer (Writer, execWriter, runWriter, tell) +import Data.List (unfoldr) +import Data.Maybe (fromJust, maybeToList) +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Monad +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.TestInstances () +import Game.Goatee.Sgf.TestUtils +import Game.Goatee.Sgf.Types +import Game.Goatee.Test.Common +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), (@?=)) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +type LoggedGoM = GoT (Writer [String]) + +runLoggedGo :: LoggedGoM a -> Cursor -> (a, Cursor, [String]) +runLoggedGo go cursor = + let ((value, cursor'), log) = runWriter $ runGoT go cursor + in (value, cursor', log) + +tests = testGroup "Game.Goatee.Sgf.Monad" [ + monadTests, + navigationTests, + positionStackTests, + propertiesTests, + getPropertyTests, + getPropertyValueTests, + putPropertyTests, + deletePropertyTests, + modifyPropertyTests, + modifyPropertyValueTests, + modifyPropertyStringTests, + modifyPropertyCoordsTests, + modifyGameInfoTests, + modifyVariationModeTests, + getMarkTests, + modifyMarkTests, + addChildTests, + gameInfoChangedTests + ] + +monadTests = testGroup "monad properties" [ + testCase "returns a value it's given" $ + let cursor = rootCursor $ node [] + (value, cursor') = runGo (return 3) cursor + in (value, cursorNode cursor') @?= (3, cursorNode cursor), + + testCase "getCursor works" $ do + let cursor = rootCursor nodeA + nodeA = node1 [SZ 3 3, B $ Just (0,0)] nodeB + nodeB = node1 [W $ Just (1,1)] nodeC + nodeC = node [B $ Just (2,2)] + nodeA @=? evalGo (liftM cursorNode getCursor) cursor + nodeB @=? evalGo (goDown 0 >> liftM cursorNode getCursor) cursor + nodeC @=? evalGo (goDown 0 >> goDown 0 >> liftM cursorNode getCursor) cursor, + + testCase "getCoordState works" $ do + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [SZ 2 2, B $ Just (0,0)] $ + node1 [W $ Just (1,0), TR $ coord1 (0,0)] $ + node [B $ Just (0,1), CR $ coord1 (1,0)] + action = mapM getCoordState [(0,0), (1,0), (0,1), (1,1)] + states = evalGo action cursor + map coordStone states @?= [Just Black, Just White, Just Black, Nothing] + map coordMark states @?= [Nothing, Just MarkCircle, Nothing, Nothing] + ] + +navigationTests = testGroup "navigation" [ + testCase "navigates down a tree" $ + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] [node [B $ Just (2,2)], + node [B Nothing]] + action = goDown 0 >> goDown 1 + (_, cursor') = runGo action cursor + in cursorProperties cursor' @?= [B Nothing], + + testCase "navigates up a tree" $ + let cursor = child 1 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] [node [B $ Just (2,2)], + node [B Nothing]] + action = goUp >> goUp + (_, cursor') = runGo action cursor + in cursorProperties cursor' @?= [B $ Just (0,0)], + + testCase "invokes handlers when navigating" $ + let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] + action = do on navigationEvent $ \step -> case step of + GoUp index -> tell ["Up " ++ show index] + _ -> return () + on navigationEvent $ \step -> case step of + GoDown index -> tell ["Down " ++ show index] + _ -> return () + goDown 0 + goUp + (_, _, log) = runLoggedGo action cursor + in log @?= ["Down 0", "Up 0"], + + testCase "navigates to the root of a tree, invoking handlers" $ do + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = do on navigationEvent $ \step -> tell [show step] + goToRoot + (_, cursor', log) = runLoggedGo action cursor + cursorProperties cursor' @?= [B $ Just (0,0)] + log @?= ["GoUp 0", "GoUp 0"], + + testGroup "goToGameInfoNode" [ + testCase "can navigate up to find game info" $ + let props = [PB (toSimpleText ""), B Nothing] + cursor = child 0 $ rootCursor $ node1 props $ node [W Nothing] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= props, + + testCase "can find game info at the current node" $ + let props = [PB (toSimpleText ""), W Nothing] + cursor = child 0 $ rootCursor $ node1 [B Nothing] $ node props + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= props, + + testCase "doesn't find game info from a subnode" $ + let cursor = child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [PB (toSimpleText ""), B Nothing] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= [W $ Just (1,1)], + + testCase "can return to the initial node when no game info is found" $ + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= [B $ Just (2,2)], + + testCase "can finish at the root node when no game info is found" $ + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = void $ goToGameInfoNode True + in cursorProperties (execGo action cursor) @?= [B $ Just (0,0)] + ] + ] + +positionStackTests = testGroup "position stack" [ + testCase "should push, pop, and drop with no navigation" $ do + let cursor = rootCursor $ node [] + actions = [pushPosition >> popPosition, + pushPosition >> pushPosition >> popPosition >> popPosition, + pushPosition >> dropPosition, + pushPosition >> pushPosition >> dropPosition >> popPosition, + pushPosition >> pushPosition >> popPosition >> dropPosition] + forM_ actions $ \action -> cursorProperties (execGo action cursor) @?= [], + + testCase "should backtrack up and down the tree" $ do + let cursor = child 0 $ child 1 $ rootCursor $ + node' [B $ Just (0,0)] + [node1 [W $ Just (1,1)] $ node [B $ Just (2,2)], + node1 [W Nothing] $ node [B Nothing]] + action = pushPosition >> goUp >> goUp >> goDown 0 >> goDown 0 + cursorProperties (execGo (action >> popPosition) cursor) @?= [B Nothing] + cursorProperties (execGo (action >> dropPosition) cursor) @?= [B $ Just (2,2)], + + testCase "should pop multiple stacks" $ do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> popPosition + log >> popPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"], + + testCase "should drop then pop" $ do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> dropPosition + log >> popPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"], + + testCase "should drop twice" $ do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> dropPosition + log >> dropPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"], + + testCase "should fire navigation handlers while popping" $ do + let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] + action = do pushPosition + goDown 0 + goUp + on navigationEvent $ \step -> tell [step] + popPosition + execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0] + ] + where commonCursor = rootCursor $ + node' [B $ Just (0,0)] + [node' [W $ Just (1,1)] + [node [B $ Just (2,2)], + node [B $ Just (3,3)]], + node1 [W $ Just (4,4)] $ node [B $ Just (5,5)]] + log = getCursor >>= \cursor -> case cursorProperties cursor of + [B (Just x)] -> tell ["B " ++ show x] + [W (Just x)] -> tell ["W " ++ show x] + xs -> error $ "Unexpected properties: " ++ show xs + navigate = do log >> pushPosition + goUp >> goDown 1 + log >> pushPosition + goUp >> goUp >> goDown 1 >> goDown 0 + +propertiesTests = testGroup "properties" [ + testGroup "getProperties" [ + testCase "returns an empty list" $ + let cursor = rootCursor $ node [] + in evalGo getProperties cursor @?= [], + + testCase "returns a non-empty list" $ + let properties = [PB $ toSimpleText "Foo", B Nothing] + cursor = rootCursor $ node properties + in evalGo getProperties cursor @?= properties + ], + + testGroup "modifyProperties" [ + testCase "adds properties" $ + let cursor = rootCursor $ node [FF 1] + action = do modifyProperties $ \props -> return $ props ++ [B Nothing, W Nothing] + getProperties + in evalGo action cursor @?= [FF 1, B Nothing, W Nothing], + + testCase "removes properties" $ + let cursor = rootCursor $ node [W Nothing, FF 1, B Nothing] + action = do modifyProperties $ \props -> return $ filter (not . isMoveProperty) props + getProperties + in evalGo action cursor @?= [FF 1], + + testCase "fires a properties modified event" $ + let cursor = rootCursor $ node [FF 1] + action = do on propertiesModifiedEvent $ \old new -> tell [(old, new)] + modifyProperties $ const $ return [FF 2] + log = execWriter (runGoT action cursor) + in log @?= [([FF 1], [FF 2])] + ] + ] + where isMoveProperty prop = case prop of + B _ -> True + W _ -> True + _ -> False + +getPropertyTests = testGroup "getProperty" [ + testCase "doesn't find an unset property" $ do + Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node []) + Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [B Nothing]), + + testCase "finds a set property" $ do + Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing]) + Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing, DO]) + Just DO @=? evalGo (getProperty propertyDO) (rootCursor $ node [B Nothing, DO]) + ] + +getPropertyValueTests = testGroup "getPropertyValue" [ + testCase "doesn't find an unset property" $ do + Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node []) + Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [B Nothing]), + + testCase "finds a set property" $ do + Just Nothing @=? evalGo (getPropertyValue propertyB) (rootCursor $ node [B Nothing]) + Just (Just (0,0)) @=? + evalGo (getPropertyValue propertyB) (rootCursor $ node [B $ Just (0,0), TE Double1]) + Just Double1 @=? + evalGo (getPropertyValue propertyTE) (rootCursor $ node [B $ Just (0,0), TE Double1]) + ] + +putPropertyTests = testGroup "putProperty" [ + testCase "adds an unset property" $ do + [IT] @=? cursorProperties (execGo (putProperty IT) $ rootCursor $ node []) + [DO, IT] @=? + sortProperties (cursorProperties (execGo (putProperty IT) $ rootCursor $ node [DO])), + + testCase "replaces an existing property" $ + [TE Double2] @=? + cursorProperties (execGo (putProperty $ TE Double2) (rootCursor $ node [TE Double1])) + ] + +deletePropertyTests = testGroup "deleteProperty" [ + testCase "does nothing when the property isn't set" $ do + [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node []) + [B Nothing] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [B Nothing]), + + testCase "removes a property" $ do + [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [DO]) + -- This is documented behaviour for deleteProperty, the fact that it doesn't + -- matter what the property value is: + [DO] @=? cursorProperties + (execGo (deleteProperty $ B $ Just (0,0)) $ rootCursor $ node [DO, B Nothing]) + ] + +modifyPropertyTests = testGroup "modifyProperty" [ + testCase "adds a property to an empty node" $ + let cursor = rootCursor $ node [] + action = modifyProperty propertyIT (\Nothing -> Just IT) + in cursorProperties (execGo action cursor) @?= [IT], + + testCase "adds a property to a non-empty node" $ + let cursor = rootCursor $ node [KO] + action = modifyProperty propertyIT (\Nothing -> Just IT) + in sortProperties (cursorProperties $ execGo action cursor) @?= [IT, KO], + + testCase "removes a property" $ do + let cursor = rootCursor $ node [IT, KO] + cursor' = execGo (modifyProperty propertyKO $ \(Just KO) -> Nothing) cursor + cursor'' = execGo (modifyProperty propertyIT $ \(Just IT) -> Nothing) cursor' + cursorProperties cursor' @?= [IT] + cursorProperties cursor'' @?= [], + + testCase "updates a property" $ do + let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] + action = modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Just $ B $ Just (1,1) + cursor' = execGo action cursor + action' = modifyProperty propertyBM $ \(Just (BM Double2)) -> Just $ BM Double1 + cursor'' = execGo action' cursor' + sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] + sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1], + + testCase "fires an event when modifying a property" $ do + let cursor = rootCursor $ node [B $ Just (0,0)] + action = do on propertiesModifiedEvent $ \[B (Just (0,0))] [] -> tell [0] + modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Nothing + (cursor', log) = runWriter (execGoT action cursor) + [0] @=? log + [] @=? cursorProperties cursor', + + testCase "modifying but not actually changing a property doesn't fire an event" $ do + let cursor = rootCursor $ node [B $ Just (0,0)] + action = do on propertiesModifiedEvent $ \_ _ -> tell ["Event fired."] + modifyProperty propertyB $ \p@(Just (B {})) -> p + (cursor', log) = runWriter (execGoT action cursor) + [B $ Just (0,0)] @=? cursorProperties cursor' + [] @=? log + ] + +modifyPropertyValueTests = testGroup "modifyPropertyValue" [ + testCase "adds a property to an empty node" $ + let cursor = rootCursor $ node [] + action = modifyPropertyValue propertyPL (\Nothing -> Just Black) + in cursorProperties (execGo action cursor) @?= [PL Black], + + testCase "adds a property to a non-empty node" $ + let cursor = rootCursor $ node [KO] + action = modifyPropertyValue propertyPL (\Nothing -> Just White) + in sortProperties (cursorProperties $ execGo action cursor) @?= [KO, PL White], + + testCase "removes a property" $ do + let cursor = rootCursor $ node [B Nothing, TE Double2] + cursor' = execGo (modifyPropertyValue propertyTE $ \(Just Double2) -> Nothing) cursor + cursor'' = execGo (modifyPropertyValue propertyB $ \(Just Nothing) -> Nothing) cursor' + cursorProperties cursor' @?= [B Nothing] + cursorProperties cursor'' @?= [], + + testCase "updates a property" $ do + let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] + action = modifyPropertyValue propertyB $ \(Just (Just (0,0))) -> Just $ Just (1,1) + cursor' = execGo action cursor + action' = modifyPropertyValue propertyBM $ \(Just Double2) -> Just Double1 + cursor'' = execGo action' cursor' + sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] + sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1] + ] + +modifyPropertyStringTests = + testGroup "modifyPropertyString" + -- Test a Text property and a SimpleText property. + (assumptions ++ genTests "comment" propertyC ++ genTests "game name" propertyGN) + where assumptions = let _ = C $ toText "" + _ = GN $ toSimpleText "" + in [] + genTests name property = [ + testCase ("adds a " ++ name) $ + let cursor = rootCursor $ node [] + action = modifyPropertyString property (++ "Hello.") + in cursorProperties (execGo action cursor) @?= + [propertyBuilder property $ stringToSgf "Hello."], + + testCase ("removes a " ++ name) $ + let cursor = rootCursor $ node [propertyBuilder property $ stringToSgf "Hello."] + action = modifyPropertyString property $ \value -> case value of + "Hello." -> "" + other -> error $ "Got: " ++ other + in cursorProperties (execGo action cursor) @?= [], + + testCase ("updates a " ++ name) $ + let cursor = child 0 $ rootCursor $ + node1 [propertyBuilder property $ stringToSgf "one"] $ + node [propertyBuilder property $ stringToSgf "two"] + action = modifyPropertyString property $ \value -> case value of + "two" -> "three" + other -> error $ "Got: " ++ other + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([propertyBuilder property $ stringToSgf "three"], + [propertyBuilder property $ stringToSgf "one"]), + + testCase "leaves a non-existant comment" $ + let result = execGo (modifyPropertyString property id) $ rootCursor $ node [] + in cursorProperties result @?= [] + ] + +modifyPropertyCoordsTests = testGroup "modifyPropertyCoords" [ + testCase "adds a property where there was none" $ + let cursor = rootCursor $ node [] + action = modifyPropertyCoords propertySL $ \[] -> [(0,0), (1,1)] + in [SL $ coords [(0,0), (1,1)]] @=? cursorProperties (execGo action cursor), + + testCase "removes a property where there was one" $ + let cursor = rootCursor $ node [TR $ coord1 (5,5)] + action = modifyPropertyCoords propertyTR $ \[(5,5)] -> [] + in [] @=? cursorProperties (execGo action cursor), + + testCase "modifies an existing property" $ + let cursor = rootCursor $ node [CR $ coord1 (3,4)] + action = modifyPropertyCoords propertyCR $ \[(3,4)] -> [(2,2)] + in [CR $ coord1 (2,2)] @=? cursorProperties (execGo action cursor), + + testCase "doesn't affect other properties" $ + let cursor = rootCursor $ node [SQ $ coord1 (0,0), MA $ coord1 (1,1)] + action = modifyPropertyCoords propertyMA $ \[(1,1)] -> [(2,2)] + in [MA $ coord1 (2,2), SQ $ coord1 (0,0)] @=? + sortProperties (cursorProperties $ execGo action cursor) + ] + +modifyGameInfoTests = testGroup "modifyGameInfo" [ + testGroup "creates info on the root node, starting with none" [ + testCase "starting from the root node" $ + let cursor = rootCursor $ node [] + action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" }) + in cursorProperties (execGo action cursor) @?= [GN $ toSimpleText "Orange"], + + testCase "starting from a non-root node" $ + let cursor = child 0 $ rootCursor $ node1 [] $ node [B Nothing] + action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" }) + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([B Nothing], [GN $ toSimpleText "Orange"]) + ], + + testGroup "modifies existing info on the root" [ + testCase "starting from the root node" $ + let cursor = rootCursor $ node [GN $ toSimpleText "Orange"] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing + , gameInfoBlackName = Just "Peanut butter" + }) + in cursorProperties (execGo action cursor) @?= [PB $ toSimpleText "Peanut butter"], + + testCase "starting from a non-root node" $ + let cursor = child 0 $ rootCursor $ node1 [GN $ toSimpleText "Orange"] $ node [B Nothing] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing + , gameInfoBlackName = Just "Peanut butter" + }) + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([B Nothing], [PB $ toSimpleText "Peanut butter"]) + ], + + testCase "moves game info from a non-root node to the root" $ + let cursor = child 0 $ child 0 $ child 0 $ rootCursor $ + node1 [SZ 19 19] $ + node1 [B $ Just (0,0), GN $ toSimpleText "Orange"] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing }) + cursor' = execGo action cursor + action' = modifyGameInfo (\info -> info { gameInfoBlackName = Just "Peanut butter" }) + cursor'' = execGo action' cursor' + -- unfoldr :: (Maybe Cursor -> Maybe ([Property], Maybe Cursor)) + -- -> Maybe Cursor + -- -> [[Property]] + properties = unfoldr (fmap $ cursorProperties &&& cursorParent) + (Just cursor'') + in map sortProperties properties @?= + [[B $ Just (2,2)], + [W $ Just (1,1)], + [B $ Just (0,0)], + [PB $ toSimpleText "Peanut butter", SZ 19 19]] + ] + +modifyVariationModeTests = testGroup "modifyVariationMode" [ + testCase "testing modes are not default" $ do + defaultVariationMode @/=? mode + defaultVariationMode @/=? mode2, + + testCase "modifies when at a root node" $ + node1 [ST mode] (node []) @=? + cursorNode (execGo setMode $ rootCursor $ node1 [] $ node []), + + testCase "modifies when at a non-root node" $ + node1 [ST mode] (node []) @=? + cursorNode (cursorRoot $ execGo setMode $ child 0 $ rootCursor $ node1 [] $ node []), + + testCase "leaves an unset ST unset" $ + assertST Nothing Nothing $ const defaultVariationMode, + + testCase "leaves a default ST alone" $ + assertST (Just defaultVariationMode) (Just defaultVariationMode) $ const defaultVariationMode, + + testCase "leaves an existing ST alone" $ + assertST (Just mode) (Just mode) $ const mode, + + testCase "adds an ST property" $ + assertST (Just mode) Nothing $ const mode, + + testCase "removes an ST property when setting to default" $ + assertST Nothing (Just mode) $ const defaultVariationMode, + + testCase "modifies an existing ST property" $ + assertST (Just mode2) (Just mode) $ const mode2 + ] + where mode = VariationMode ShowCurrentVariations True + mode2 = VariationMode ShowChildVariations False + setMode = modifyVariationMode $ const mode + assertST maybeExpectedST maybeInitialST fn = + node (ST <$> maybeToList maybeExpectedST) @=? + cursorNode (execGo (modifyVariationMode fn) $ + rootCursor $ node $ ST <$> maybeToList maybeInitialST) + +getMarkTests = testGroup "getMark" [ + testCase "returns Nothing for no mark" $ do + Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node []) + Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [W $ Just (0,0)]), + + testCase "returns Just when a mark is present" $ do + Just MarkSquare @=? evalGo (getMark (1,2)) (rootCursor $ node [SQ $ coord1 (1,2)]) + Just MarkTriangle @=? evalGo (getMark (1,1)) (rootCursor $ node [B $ Just (1,1), + TR $ coord1 (1,1), + SQ $ coord1 (1,2)]), + + testCase "matches all marks" $ forM_ [minBound..maxBound] $ \mark -> + Just mark @=? + evalGo (getMark (0,0)) + (rootCursor $ node [propertyBuilder (markProperty mark) $ coord1 (0,0)]) + ] + +modifyMarkTests = testGroup "modifyMark" [ + testCase "creates a mark where there was none" $ + let cursor = rootCursor $ node [] + action = do modifyMark (\Nothing -> Just MarkX) (0,0) + getMark (0,0) + in Just MarkX @=? evalGo action cursor, + + testCase "removes an existing mark" $ + let cursor = rootCursor $ node [CR $ coord1 (0,0)] + action = do modifyMark (\(Just MarkCircle) -> Nothing) (0,0) + getMark (0,0) + in Nothing @=? evalGo action cursor, + + testCase "replaces an existing mark" $ + let cursor = rootCursor $ node [CR $ coord1 (0,0)] + action = do modifyMark (\(Just MarkCircle) -> Just MarkX) (0,0) + getMark (0,0) + in Just MarkX @=? evalGo action cursor, + + testCase "adds on to an existing mark property" $ + let cursor = rootCursor $ node [MA $ coord1 (0,0)] + action = do modifyMark (\Nothing -> Just MarkX) (1,0) + mapM getMark [(0,0), (1,0)] + in [Just MarkX, Just MarkX] @=? evalGo action cursor, + + testCase "removes from an existing mark property" $ + let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] + action = do modifyMark (\(Just MarkX) -> Nothing) (1,0) + modifyMark (\(Just MarkX) -> Nothing) (0,1) + mapM getMark [(0,0), (1,0), (0,1)] + in [Just MarkX, Nothing, Nothing] @=? evalGo action cursor, + + testCase "removes and adds at the same time" $ + let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] + action = do modifyMark (\(Just MarkX) -> Just MarkSquare) (0,0) + modifyMark (\(Just MarkX) -> Nothing) (0,1) + mapM getMark [(0,0), (1,0), (0,1)] + in [Just MarkSquare, Just MarkX, Nothing] @=? evalGo action cursor + ] + +addChildTests = testGroup "addChild" [ + testCase "adds an only child" $ + cursorNode (execGo (addChild 0 $ node [B Nothing]) (rootCursor $ node [])) + @?= node' [] [node [B Nothing]], + + testCase "adds a first child" $ + cursorNode (execGo (addChild 0 $ node [B $ Just (0,0)]) + (rootCursor $ node' [] [node [B $ Just (1,1)]])) + @?= node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)]], + + testCase "adds a middle child" $ + cursorNode (execGo (addChild 1 $ node [B $ Just (1,1)]) + (rootCursor $ node' [] [node [B $ Just (0,0)], + node [B $ Just (2,2)]])) + @?= node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)], + node [B $ Just (2,2)]], + + testCase "adds a last child" $ + cursorNode (execGo (addChild 2 $ node [B $ Just (2,2)]) + (rootCursor $ node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)]])) + @?= node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)], + node [B $ Just (2,2)]], + + testGroup "path stack correctness" [ + testCase "basic case just not needing updating" $ + let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] + action = do pushPosition + goUp + addChild 1 $ node [W $ Just (0,0)] + popPosition + in cursorNode (execGo action cursor) @?= node [W Nothing], + + testCase "basic case just needing updating" $ + let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] + action = do pushPosition + goUp + addChild 0 $ node [W $ Just (0,0)] + popPosition + in cursorNode (execGo action cursor) @?= node [W Nothing], + + testCase "basic case definitely needing updating" $ + let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)], + node [W $ Just (1,1)]] + action = do goDown 1 + pushPosition + goUp + addChild 0 $ node [W Nothing] + popPosition + in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)], + + testCase "multiple paths to update" $ + let at y x = B $ Just (y,x) + level0Node = node' [at 0 0] $ map level1Node [0..1] + level1Node i = node' [at 1 i] $ map level2Node [0..2] + level2Node i = node' [at 2 i] $ map level3Node [0..3] + level3Node i = node [at 3 i] + action = do goDown 1 >> goDown 2 >> goDown 3 + pushPosition + replicateM_ 4 goUp + goDown 1 >> goDown 2 >> goDown 2 >> goUp >> goDown 1 + addChild 0 $ node' [] [node []] + goDown 0 >> goDown 0 + goToRoot + popPosition + in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)], + + testCase "updates paths with GoUp correctly" $ + let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)] + action = do pushPosition + goDown 0 + goUp + addChild 0 $ node [B $ Just (2,2)] + on navigationEvent $ \step -> tell [step] + popPosition + (_, log) = runWriter (runGoT action cursor) + in log @?= [GoDown 1, GoUp 1] + ] + ] + +gameInfoChangedTests = testGroup "gameInfoChangedEvent" [ + testCase "fires when navigating down" $ + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do on gameInfoChangedEvent onInfo + goDown 0 + in execWriter (runGoT action cursor) @?= [(Nothing, Just "Foo")], + + testCase "fires when navigating up" $ + let cursor = child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do on gameInfoChangedEvent onInfo + goUp + in execWriter (runGoT action cursor) @?= [(Just "Foo", Nothing)], + + testCase "fires from within popPosition" $ + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do pushPosition + goDown 0 + goUp + on gameInfoChangedEvent onInfo + popPosition + in execWriter (runGoT action cursor) @?= + [(Nothing, Just "Foo"), (Just "Foo", Nothing)], + + testCase "fires when modifying properties" $ + let cursor = rootCursor $ node [] + action = do on gameInfoChangedEvent onInfo + modifyProperties $ const $ return [GN $ toSimpleText "Foo"] + modifyProperties $ const $ return [GN $ toSimpleText "Bar"] + modifyProperties $ const $ return [] + in execWriter (runGoT action cursor) @?= + [(Nothing, Just "Foo"), (Just "Foo", Just "Bar"), (Just "Bar", Nothing)] + ] + where onInfo old new = tell [(gameInfoGameName old, gameInfoGameName new)] diff --git a/tests/Game/Goatee/Sgf/ParserTest.hs b/tests/Game/Goatee/Sgf/ParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/ParserTest.hs @@ -0,0 +1,242 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.ParserTest (tests) where + +import Control.Monad (forM_) +import Game.Goatee.Sgf.ParserTestUtils +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.TestInstances () +import Game.Goatee.Sgf.TestUtils +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +tests = testGroup "Game.Goatee.Sgf.Parser" [ + baseCaseTests, + whitespaceTests, + passConversionTests, + movePropertyTests, + setupPropertyTests, + nodeAnnotationPropertyTests, + moveAnnotationPropertyTests, + rootPropertyTests + ] + +baseCaseTests = testGroup "base cases" [ + testCase "works with the trivial collection" $ + parseOrFail "(;)" (@?= emptyNode), + + testCase "works with only a size property" $ do + parseOrFail "(;SZ[1])" (@?= root 1 1 [] []) + parseOrFail "(;SZ[9])" (@?= root 9 9 [] []) + ] + +whitespaceTests = testGroup "whitespace handling" [ + testCase "parses with no extra whitespace" $ + parseOrFail "(;SZ[4];AB[aa][bb]AW[cc];W[dd])" + (@?= root 4 4 [] [node1 [AB $ coords [(0,0), (1,1)], AW $ coords [(2,2)]] $ + node [W $ Just (3,3)]]), + + testCase "parses with spaces between nodes" $ + parseOrFail "(;SZ[1] ;B[])" (@?= root 1 1 [] [node [B Nothing]]), + + testCase "parses with spaces between properties" $ + parseOrFail "(;SZ[1] AB[aa])" (@?= root 1 1 [AB $ coords [(0,0)]] []), + + testCase "parses with spaces between a property's name and value" $ + parseOrFail "(;SZ [1])" (@?= root 1 1 [] []), + + testCase "parses with spaces between property values" $ + parseOrFail "(;SZ[2]AB[aa] [bb])" (@?= root 2 2 [AB $ coords [(0,0), (1,1)]] []), + + testCase "parses with spaces between many elements" $ + parseOrFail " ( ; SZ [4] ; AB [aa:ad] [bb] AW [cc] ; W [dd] ; B [] ) " + (@?= root 4 4 [] [node1 [AB $ coords' [(1,1)] [((0,0), (0,3))], + AW $ coords [(2,2)]] $ + node1 [W $ Just (3,3)] $ + node [B Nothing]]) + + -- TODO Test handling of whitespace between an unknown property name and + -- [value]. + ] + +passConversionTests = testGroup "B[tt]/W[tt] pass conversion" [ + testCase "converts B[tt] for a board sizes <=19x19" $ do + parseOrFail "(;SZ[1];B[tt])" (@?= root 1 1 [] [node [B Nothing]]) + parseOrFail "(;SZ[9];B[tt])" (@?= root 9 9 [] [node [B Nothing]]) + parseOrFail "(;SZ[19];B[tt])" (@?= root 19 19 [] [node [B Nothing]]), + + testCase "converts W[tt] for a board sizes <=19x19" $ do + parseOrFail "(;SZ[1];W[tt])" (@?= root 1 1 [] [node [W Nothing]]) + parseOrFail "(;SZ[9];W[tt])" (@?= root 9 9 [] [node [W Nothing]]) + parseOrFail "(;SZ[19];W[tt])" (@?= root 19 19 [] [node [W Nothing]]), + + testCase "doesn't convert B[tt] for a board sizes >19x19" $ do + parseOrFail "(;SZ[20];B[tt])" (@?= root 20 20 [] [node [B $ Just (19, 19)]]) + parseOrFail "(;SZ[21];B[tt])" (@?= root 21 21 [] [node [B $ Just (19, 19)]]), + + testCase "doesn't convert W[tt] for a board sizes >19x19" $ do + parseOrFail "(;SZ[20];W[tt])" (@?= root 20 20 [] [node [W $ Just (19, 19)]]) + parseOrFail "(;SZ[21];W[tt])" (@?= root 21 21 [] [node [W $ Just (19, 19)]]), + + testCase "doesn't convert non-move properties" $ do + -- TODO These should error, rather than parsing fine. + parseOrFail "(;SZ[9];AB[tt])" (@?= root 9 9 [] [node [AB $ coords [(19, 19)]]]) + parseOrFail "(;SZ[9];TR[tt])" (@?= root 9 9 [] [node [TR $ coords [(19, 19)]]]) + ] + +movePropertyTests = testGroup "move properties" [ + testGroup "B" [ + testCase "parses moves" $ do + parseOrFail "(;B[aa])" (@?= node [B $ Just (0, 0)]) + parseOrFail "(;B[cp])" (@?= node [B $ Just (2, 15)]), + testCase "parses passes" $ + parseOrFail "(;B[])" (@?= node [B Nothing]) + ], + testCase "KO parses" $ + parseOrFail "(;KO[])" (@?= node [KO]), + -- TODO Test MN (assert positive). + testGroup "W" [ + testCase "parses moves" $ do + parseOrFail "(;W[aa])" (@?= node [W $ Just (0, 0)]) + parseOrFail "(;W[cp])" (@?= node [W $ Just (2, 15)]), + testCase "parses passes" $ + parseOrFail "(;W[])" (@?= node [W Nothing]) + ] + ] + +setupPropertyTests = testGroup "setup properties" [ + testCase "AB parses" $ do + parseOrFail "(;AB[ab])" (@?= node [AB $ coords [(0, 1)]]) + parseOrFail "(;AB[ab][cd:ef])" (@?= node [AB $ coords' [(0, 1)] [((2, 3), (4, 5))]]), + testCase "AE parses" $ do + parseOrFail "(;AE[ae])" (@?= node [AE $ coords [(0, 4)]]) + parseOrFail "(;AE[ae][ff:gg])" (@?= node [AE $ coords' [(0, 4)] [((5, 5), (6, 6))]]), + testCase "AW parses" $ do + parseOrFail "(;AW[aw])" (@?= node [AW $ coords [(0, 22)]]) + parseOrFail "(;AW[aw][xy:yz])" (@?= node [AW $ coords' [(0, 22)] [((23, 24), (24, 25))]]), + testCase "PL parses" $ do + parseOrFail "(;PL[B])" (@?= node [PL Black]) + parseOrFail "(;PL[W])" (@?= node [PL White]) + ] + +nodeAnnotationPropertyTests = testGroup "node annotation properties" [ + testCase "C parses" $ + parseOrFail "(;C[Me [30k\\]: What is White doing??\\\n\n:(])" + (@?= node [C $ toText "Me [30k]: What is White doing??\n:("]), + testCase "DM parses" $ do + parseOrFail "(;DM[1])" (@?= node [DM Double1]) + parseOrFail "(;DM[2])" (@?= node [DM Double2]), + testCase "GB parses" $ do + parseOrFail "(;GB[1])" (@?= node [GB Double1]) + parseOrFail "(;GB[2])" (@?= node [GB Double2]), + testCase "GW parses" $ do + parseOrFail "(;GW[1])" (@?= node [GW Double1]) + parseOrFail "(;GW[2])" (@?= node [GW Double2]), + testCase "HO parses" $ do + parseOrFail "(;HO[1])" (@?= node [HO Double1]) + parseOrFail "(;HO[2])" (@?= node [HO Double2]), + testCase "N parses" $ + parseOrFail "(;N[The best\\\n\nmove])" (@?= node [N $ toSimpleText "The best move"]), + testCase "UC parses" $ do + parseOrFail "(;UC[1])" (@?= node [UC Double1]) + parseOrFail "(;UC[2])" (@?= node [UC Double2]), + testCase "V parses" $ do + parseOrFail "(;V[-34.5])" (@?= node [V (-34.5)]) + parseOrFail "(;V[50])" (@?= node [V 50]) + ] + +moveAnnotationPropertyTests = testGroup "move annotation properties" [ + testCase "BM parses" $ do + parseOrFail "(;BM[1])" (@?= node [BM Double1]) + parseOrFail "(;BM[2])" (@?= node [BM Double2]), + testCase "DO parses" $ + parseOrFail "(;DO[])" (@?= node [DO]), + testCase "IT parses" $ + parseOrFail "(;IT[])" (@?= node [IT]), + testCase "TE parses" $ do + parseOrFail "(;TE[1])" (@?= node [TE Double1]) + parseOrFail "(;TE[2])" (@?= node [TE Double2]) + ] + +-- TODO Test markup properties. + +rootPropertyTests = testGroup "root properties" [ + testCase "AP parses" $ + parseOrFail "(;AP[GoGoGo:1.2.3])" + (@?= node [AP (toSimpleText "GoGoGo") (toSimpleText "1.2.3")]), + testCase "CA parses" $ do + parseOrFail "(;CA[UTF-8])" (@?= node [CA $ toSimpleText "UTF-8"]) + parseOrFail "(;CA[ISO-8859-1])" (@?= node [CA $ toSimpleText "ISO-8859-1"]), + testGroup "FF" [ + testCase "accepts version 4" $ + parseOrFail "(;FF[4])" (@?= node [FF 4]), + testCase "rejects versions 1-3" $ do + parseAndFail "(;FF[1])" + parseAndFail "(;FF[2])" + parseAndFail "(;FF[3])" + ], + testGroup "GM" [ + testCase "parses 1 (Go)" $ + parseOrFail "(;GM[1])" (@?= node [GM 1]), + testCase "rejects unsupported games" $ + forM_ [2..16] $ \x -> parseAndFail $ "(;GM[" ++ show x ++ "]" + ], + testGroup "ST" [ + testCase "parses valid variation modes" $ do + parseOrFail "(;ST[0])" (@?= node [ST $ VariationMode ShowChildVariations True]) + parseOrFail "(;ST[1])" (@?= node [ST $ VariationMode ShowCurrentVariations True]) + parseOrFail "(;ST[2])" (@?= node [ST $ VariationMode ShowChildVariations False]) + parseOrFail "(;ST[3])" (@?= node [ST $ VariationMode ShowCurrentVariations False]), + testCase "rejects invalid variation modes" $ + forM_ [4..10] $ \x -> parseAndFail $ "(;ST[" ++ show x ++ "]" + ], + testGroup "SZ" [ + testCase "parses square boards" $ + forM_ [1..52] $ \x -> + parseOrFail ("(;SZ[" ++ show x ++ "])") (@?= node [SZ x x]), + testCase "parses nonsquare boards" $ do + parseOrFail "(;SZ[1:2])" (@?= node [SZ 1 2]) + parseOrFail "(;SZ[1:9])" (@?= node [SZ 1 9]) + parseOrFail "(;SZ[1:19])" (@?= node [SZ 1 19]) + parseOrFail "(;SZ[2:1])" (@?= node [SZ 2 1]) + parseOrFail "(;SZ[9:1])" (@?= node [SZ 9 1]) + parseOrFail "(;SZ[19:1])" (@?= node [SZ 19 1]) + parseOrFail "(;SZ[19:52])" (@?= node [SZ 19 52]) + parseOrFail "(;SZ[10:16])" (@?= node [SZ 10 16]), + testCase "rejects invalid sizes" $ do + -- Boards must have length at least 1... + parseAndFail "(;SZ[0])" + parseAndFail "(;SZ[-1])" + -- ...and at most 52. + parseAndFail "(;SZ[53])" + parseAndFail "(;SZ[54])" + parseAndFail "(;SZ[0:19])" + parseAndFail "(;SZ[19:0])" + parseAndFail "(;SZ[9:53])" + parseAndFail "(;SZ[53:9])", + -- This is specified by the SGF spec: + testCase "rejects square boards defined with two numbers" $ do + parseAndFail "(;SZ[1:1])" + parseAndFail "(;SZ[19:19])" + ] + ] + +-- TODO Test the test of the properties. diff --git a/tests/Game/Goatee/Sgf/ParserTestUtils.hs b/tests/Game/Goatee/Sgf/ParserTestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/ParserTestUtils.hs @@ -0,0 +1,63 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.ParserTestUtils ( + parseOrFail, + parseAndFail, + assertParse, + assertNoParse, + ) where + +import Control.Applicative ((<*)) +import Game.Goatee.Sgf.Parser +import Game.Goatee.Sgf.Tree +import Test.HUnit (assertFailure) +import Text.ParserCombinators.Parsec (Parser, eof, parse) + +-- Parses a string as a complete SGF document. On success, executes the +-- continuation function with the result. Otherwise, causes an assertion +-- failure. +parseOrFail :: String -> (Node -> IO ()) -> IO () +parseOrFail input cont = case parseString input of + Left error -> assertFailure $ "Failed to parse SGF: " ++ error + Right (Collection roots) -> case roots of + root:[] -> cont root + _ -> assertFailure $ "Expected a single root node, got: " ++ show roots + +-- Parses a string as a complete SGF document and expects failure. +parseAndFail :: String -> IO () +parseAndFail input = case parseString input of + Left _ -> return () + Right result -> assertFailure $ "Expected " ++ show input ++ + " not to parse. Parsed to " ++ show result ++ "." + +-- Parses a string using the given parser and expects the parser to consume the +-- entire input. On success, executes the continuation function with the +-- result. Otherwise, causes an assertion failure. +assertParse :: Parser a -> String -> (a -> IO ()) -> IO () +assertParse parser input cont = case parse (parser <* eof) "" input of + Left error -> assertFailure $ "Failed to parse: " ++ show error + Right result -> cont result + +-- Tries to parse a string using the given parser. If the parse succeeds then +-- this function causes an assertion failure, otherwise this function succeeds. +assertNoParse :: Show a => Parser a -> String -> IO () +assertNoParse parser input = case parse (parser <* eof) "" input of + Left _ -> return () + Right result -> assertFailure $ + "Expected " ++ show input ++ " not to parse. " ++ + "Parsed to " ++ show result ++ "." diff --git a/tests/Game/Goatee/Sgf/Property/ParserTest.hs b/tests/Game/Goatee/Sgf/Property/ParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/Property/ParserTest.hs @@ -0,0 +1,391 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.Property.ParserTest (tests) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_) +import Data.Maybe (catMaybes) +import Game.Goatee.Common +import Game.Goatee.Sgf.ParserTestUtils +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Property.Parser +import Game.Goatee.Sgf.TestInstances () +import Game.Goatee.Sgf.TestUtils +import Game.Goatee.Sgf.Types +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) +import Text.ParserCombinators.Parsec (Parser) + +tests = testGroup "Game.Goatee.Sgf.Property.ParserTest" [ + -- Tests for public parsers. + parserColorTests, + parserDoubleTests, + parserGameResultTests, + parserIntegralTests, + parserMoveTests, + parserRealTests, + parserRulesetTests, + parserSizeTests, + parserVariationModeTests, + -- Tests for private parsers. + lineTests, + simpleTextTests, + simpleTextComposedTests, + textTests, + textComposedTests, + -- Miscellaneous tests. + propertyValueArityTests + ] + +parserColorTests = testGroup "colorParser" [ + testCase "parses B" $ assertParse colorParser "[B]" (@?= Black), + testCase "parses W" $ assertParse colorParser "[W]" (@?= White) + ] + +parserDoubleTests = testGroup "doubleParser" [ + testCase "parses 1" $ assertParse doubleParser "[1]" (@?= Double1), + testCase "parses 2" $ assertParse doubleParser "[2]" (@?= Double2) + ] + +parserGameResultTests = testGroup "gameResultParser" [ + testCase "draw" $ do + assertParse gameResultParser "[0]" (@?= GameResultDraw) + assertParse gameResultParser "[Draw]" (@?= GameResultDraw), + + testCase "void" $ + assertParse gameResultParser "[Void]" (@?= GameResultVoid), + + testCase "unknown" $ + assertParse gameResultParser "[?]" (@?= GameResultUnknown), + + testCase "Black wins by points" $ do + assertParse gameResultParser "[B+0.5]" (@?= GameResultWin Black (WinByScore 0.5)) + assertParse gameResultParser "[B+11]" (@?= GameResultWin Black (WinByScore 11)) + assertParse gameResultParser "[B+354.5]" (@?= GameResultWin Black (WinByScore 354.5)), + + testCase "Black wins by resignation" $ do + assertParse gameResultParser "[B+R]" (@?= GameResultWin Black WinByResignation) + assertParse gameResultParser "[B+Resign]" (@?= GameResultWin Black WinByResignation), + + testCase "Black wins on time" $ do + assertParse gameResultParser "[B+T]" (@?= GameResultWin Black WinByTime) + assertParse gameResultParser "[B+Time]" (@?= GameResultWin Black WinByTime), + + testCase "Black wins by forfeit" $ do + assertParse gameResultParser "[B+F]" (@?= GameResultWin Black WinByForfeit) + assertParse gameResultParser "[B+Forfeit]" (@?= GameResultWin Black WinByForfeit), + + testCase "White wins by points" $ do + assertParse gameResultParser "[W+0.5]" (@?= GameResultWin White (WinByScore 0.5)) + assertParse gameResultParser "[W+11]" (@?= GameResultWin White (WinByScore 11)) + assertParse gameResultParser "[W+354.5]" (@?= GameResultWin White (WinByScore 354.5)), + + testCase "White wins by resignation" $ do + assertParse gameResultParser "[W+R]" (@?= GameResultWin White WinByResignation) + assertParse gameResultParser "[W+Resign]" (@?= GameResultWin White WinByResignation), + + testCase "White wins on time" $ do + assertParse gameResultParser "[W+T]" (@?= GameResultWin White WinByTime) + assertParse gameResultParser "[W+Time]" (@?= GameResultWin White WinByTime), + + testCase "White wins by forfeit" $ do + assertParse gameResultParser "[W+F]" (@?= GameResultWin White WinByForfeit) + assertParse gameResultParser "[W+Forfeit]" (@?= GameResultWin White WinByForfeit), + + testCase "custom game results" $ do + assertParseToOther "" + assertParseToOther "Everyone wins." + assertParseToOther "W+Nuclear tesuji" + assertParseToOther "B+Flamingo" + ] + where assertParseToOther input = + assertParse gameResultParser ('[' : input ++ "]") + (@?= GameResultOther (toSimpleText input)) + +parserIntegralTests = testGroup "integralParser" $ integerTestsFor integralParser + +parserMoveTests = testGroup "moveParser" $ coordTestsFor moveParser Just ++ [ + testCase "parses an empty move as a pass" $ assertParse moveParser "[]" (@?= Nothing) + ] + +parserRealTests = testGroup "realParser" $ integerTestsFor realParser ++ [ + testCase "parses a decimal zero" $ assertParse realParser "[0.0]" (@?= 0), + + testCase "parses fractional positive numbers" $ do + assertParse realParser "[0.5]" (@?= (1/2)) + assertParse realParser "[0.00125]" (@?= (1/800)) + assertParse realParser "[3.14]" (@?= (314/100)) + assertParse realParser "[10.0]" (@?= 10), + + testCase "parses fractional negative numbers" $ do + assertParse realParser "[-0.5]" (@?= (-1/2)) + assertParse realParser "[-0.00125]" (@?= (-1/800)) + assertParse realParser "[-3.14]" (@?= (-314/100)) + assertParse realParser "[-10.0]" (@?= (-10)) + ] + +parserRulesetTests = testGroup "rulesetParser" [ + testCase "parses known rules" $ do + assertParse rulesetParser "[AGA]" (@?= KnownRuleset RulesetAga) + assertParse rulesetParser "[Goe]" (@?= KnownRuleset RulesetIng) + assertParse rulesetParser "[Japanese]" (@?= KnownRuleset RulesetJapanese) + assertParse rulesetParser "[NZ]" (@?= KnownRuleset RulesetNewZealand), + + testCase "parses unknown rules" $ do + assertParse rulesetParser "[Foo]" (@?= UnknownRuleset "Foo") + assertParse rulesetParser "[First capture]" (@?= UnknownRuleset "First capture") + ] + +parserSizeTests = testGroup "size" [ + testCase "parses square boards" $ do + assertParse sizeParser "[1]" (@?= (1, 1)) + assertParse sizeParser "[4]" (@?= (4, 4)) + assertParse sizeParser "[9]" (@?= (9, 9)) + assertParse sizeParser "[19]" (@?= (19, 19)) + assertParse sizeParser "[52]" (@?= (52, 52)), + + testCase "parses rectangular boards" $ do + assertParse sizeParser "[1:2]" (@?= (1, 2)) + assertParse sizeParser "[9:5]" (@?= (9, 5)) + assertParse sizeParser "[19:9]" (@?= (19, 9)), + + testCase "rejects boards of non-positive size" $ do + assertNoParse sizeParser "[0]" + assertNoParse sizeParser "[-1]" + assertNoParse sizeParser "[0:5]" + assertNoParse sizeParser "[5:0]" + assertNoParse sizeParser "[0:-2]", + + testCase "rejects square boards given in rectangular format" $ do + assertNoParse sizeParser "[1:1]" + assertNoParse sizeParser "[13:13]" + ] + +parserVariationModeTests = testGroup "variationModeParser" [ + testCase "mode 0" $ + assertParse variationModeParser "[0]" (@?= VariationMode ShowChildVariations True), + + testCase "mode 1" $ + assertParse variationModeParser "[1]" (@?= VariationMode ShowCurrentVariations True), + + testCase "mode 2" $ + assertParse variationModeParser "[2]" (@?= VariationMode ShowChildVariations False), + + testCase "mode 3" $ + assertParse variationModeParser "[3]" (@?= VariationMode ShowCurrentVariations False) + ] + +lineTests = testGroup "line" [ + testCase "parses all valid values" $ do + let cases = zip (['a'..'z'] ++ ['A'..'Z']) [0..] + forM_ cases $ \(char, expected) -> + assertParse line [char] (@?= expected) + ] + +simpleTextTests = testGroup "simpleText" $ + textTestsFor simpleText fromSimpleText False ++ + textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText False) + +simpleTextComposedTests = testGroup "simpleText composed" $ + textTestsFor simpleText fromSimpleText True ++ + textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText True) + +textTests = testGroup "text" $ + textTestsFor text id False ++ + textUnescapedNewlinePreservingTests (text False) + +textComposedTests = testGroup "text composed" $ + textTestsFor text id True ++ + textUnescapedNewlinePreservingTests (text True) + +propertyValueArityTests = testGroup "property value arities" [ + testGroup "single values (single)" [ + testCase "accepts a property that requires a single number" $ + parseOrFail "(;SZ[1])" (@?= node [SZ 1 1]), + + testCase "accepts a property that requires a single point" $ + parseOrFail "(;B[dd])" (@?= node [B $ Just (3, 3)]) + ], + + testGroup "lists (listOf)" [ + testCase "doesn't accept an empty list" $ + parseAndFail "(;AR[])", + + testCase "accepts a single value" $ + parseOrFail "(;AR[aa:bb])" (@?= node [AR [((0, 0), (1, 1))]]), + + testCase "accepts two values" $ + parseOrFail "(;AR[aa:bb][cc:de])" (@?= node [AR [((0, 0), (1, 1)), + ((2, 2), (3, 4))]]) + ], + + testGroup "point lists (listOfPoint)" [ + testCase "doesn't accept an empty list" $ + parseAndFail "(;AB[])", + + testCase "accepts a single point" $ + parseOrFail "(;AB[aa])" (@?= node [AB $ coords [(0, 0)]]), + + testCase "accepts two points" $ + parseOrFail "(;AB[aa][bb])" (@?= node [AB $ coords [(0, 0), (1, 1)]]), + + testCase "accepts a rectangle" $ + parseOrFail "(;AB[aa:bb])" (@?= node [AB $ coords' [] [((0, 0), (1, 1))]]), + + testCase "accepts two rectangles" $ + parseOrFail "(;AB[aa:bb][cd:de])" (@?= node [AB $ coords' [] [((0, 0), (1, 1)), + ((2, 3), (3, 4))]]) + ], + + testGroup "point elists (elistOfPoint)" [ + testCase "accepts an empty list" $ + parseOrFail "(;VW[])" (@?= node [VW $ coords []]), + + testCase "accepts single points" $ + parseOrFail "(;VW[aa][bb])" (@?= node [VW $ coords [(0, 0), (1, 1)]]), + + testCase "accepts a rectangle" $ + parseOrFail "(;VW[aa:bb])" (@?= node [VW $ coords' [] [((0, 0), (1, 1))]]), + + testCase "accepts two rectangles" $ + parseOrFail "(;VW[aa:bb][cc:dd])" (@?= node [VW $ coords' [] [((0, 0), (1, 1)), + ((2, 2), (3, 3))]]) + ] + + -- TODO Test that invalid rectangles such as cd:dc fail to parse (or rather, + -- get corrected with a warning). + ] + +integerTestsFor :: (Eq a, Num a, Show a) => Parser a -> [Test] +integerTestsFor parser = [ + testCase "parses 0" $ do + assertParse parser "[0]" (@?= 0) + assertParse parser "[+0]" (@?= 0) + assertParse parser "[-0]" (@?= 0), + + testCase "parses positive integers" $ do + assertParse parser "[1]" (@?= 1) + assertParse parser "[20]" (@?= 20) + assertParse parser "[4294967296]" (@?= (2 ^ 32)) + assertParse parser "[18446744073709551616]" (@?= (2 ^ 64)), + + testCase "parses positive integers with the plus sign" $ do + assertParse parser "[+1]" (@?= 1) + assertParse parser "[+20]" (@?= 20) + assertParse parser "[+4294967296]" (@?= (2 ^ 32)) + assertParse parser "[+18446744073709551616]" (@?= (2 ^ 64)), + + testCase "parses negative integers" $ do + assertParse parser "[-1]" (@?= (-1)) + assertParse parser "[-20]" (@?= (-20)) + assertParse parser "[-4294967296]" (@?= (- (2 ^ 32))) + assertParse parser "[-18446744073709551616]" (@?= (- (2 ^ 64))) + ] + +coordTestsFor :: (Eq a, Show a) => Parser a -> (Coord -> a) -> [Test] +coordTestsFor parser f = [ + testCase "parses boundary points" $ do + assertParse parser "[aa]" (@?= f (0, 0)) + assertParse parser "[zz]" (@?= f (25, 25)) + assertParse parser "[AA]" (@?= f (26, 26)) + assertParse parser "[ZZ]" (@?= f (51, 51)), + + testCase "parses coordinate order correctly" $ do + assertParse parser "[ab]" (@?= f (0, 1)) + assertParse parser "[ba]" (@?= f (1, 0)), + + testCase "doesn't parse a partial point" $ + assertNoParse parser "[a]" + ] + +textTestsFor :: (Bool -> Parser a) -> (a -> String) -> Bool -> [Test] +textTestsFor makeParser toString testComposed = + let rawParser = makeParser testComposed + parser = toString <$> rawParser + composedParser = mapTuple toString <$> compose rawParser rawParser + in catMaybes [ + Just $ testCase "parses an empty string" $ + assertParse parser "" (@?= ""), + + Just $ testCase "parses a short string" $ + assertParse parser "Hello, world." (@?= "Hello, world."), + + Just $ testCase "preserves leading and trailing whitespace" $ + assertParse parser " \tHi. \t" (@?= " Hi. "), + + Just $ testCase "parses escaped backslashes" $ do + assertParse parser "\\\\" (@?= "\\") + assertParse parser "\\\\\\\\" (@?= "\\\\") + assertNoParse parser "\\" + assertNoParse parser "\\\\\\", + + Just $ testCase "parses escaped ']'s" $ do + assertParse parser "\\]" (@?= "]") + assertParse parser "\\]\\\\\\]" (@?= "]\\]"), + + Just $ if testComposed + then testCase "parses escaped ':'s" $ do + assertParse parser "\\:" (@?= ":") + assertParse parser "\\:\\\\\\:" (@?= ":\\:") + assertNoParse parser ":" + else testCase "parses unescaped ':'s" $ do + assertParse parser ":" (@?= ":") + assertParse parser "::" (@?= "::") + -- An escaped colon should parse just the same. + assertParse parser "\\:" (@?= ":"), + + if not testComposed + then Nothing + else Just $ testCase "supports composed values" $ do + assertParse composedParser ":" (@?= ("", "")) + assertParse composedParser "a:" (@?= ("a", "")) + assertParse composedParser ":z" (@?= ("", "z")) + assertParse composedParser "a:z" (@?= ("a", "z")) + assertParse composedParser "a\\\\:z" (@?= ("a\\", "z")) + assertParse composedParser "a\\:b:y\\:z" (@?= ("a:b", "y:z")) + assertNoParse composedParser "", + + -- Tests non-newline whitespace replacement. Newline handling is + -- specific to individual parsers. + Just $ testCase "replaces whitespace with spaces" $ + assertParse parser "\t\r\f\v" (@?= " "), + + Just $ testCase "removes escaped newlines" $ do + assertParse parser "\\\n" (@?= "") + assertParse parser "foo\\\nbar" (@?= "foobar") + assertParse parser "foo \\\n bar" (@?= "foo bar") + ] + +textUnescapedNewlinePreservingTests :: Parser String -> [Test] +textUnescapedNewlinePreservingTests parser = [ + testCase "preserves unescaped newlines" $ do + assertParse parser "\n" (@?= "\n") + assertParse parser "\n\n" (@?= "\n\n") + assertParse parser "foo\nbar" (@?= "foo\nbar") + assertParse parser "foo \n bar" (@?= "foo \n bar") + ] + +textUnescapedNewlineConvertingTests :: Parser String -> [Test] +textUnescapedNewlineConvertingTests parser = [ + testCase "converts unescaped newlines to spaces" $ do + assertParse parser "\n" (@?= " ") + assertParse parser "\n\n" (@?= " ") + assertParse parser "foo\nbar" (@?= "foo bar") + assertParse parser "foo \n bar" (@?= "foo bar") + ] diff --git a/tests/Game/Goatee/Sgf/PropertyTest.hs b/tests/Game/Goatee/Sgf/PropertyTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/PropertyTest.hs @@ -0,0 +1,74 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.PropertyTest (tests) where + +import qualified Data.Set as Set +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Types +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +tests = testGroup "Game.Goatee.Sgf.Property" [ + propertyMetadataTests, + markPropertyTests + ] + +propertyMetadataTests = testGroup "property metadata" [ + testCase "game info properties" $ gameInfoProperties @=? filterTo GameInfoProperty allProperties, + testCase "general properties" $ generalProperties @=? filterTo GeneralProperty allProperties, + testCase "move properties" $ moveProperties @=? filterTo MoveProperty allProperties, + testCase "root properties" $ rootProperties @=? filterTo RootProperty allProperties, + testCase "setup properties" $ setupProperties @=? filterTo SetupProperty allProperties, + + testCase "inherited properties" $ [DD cl] @=? filter propertyInherited allProperties + ] + where filterTo propType = filter ((propType ==) . propertyType) + moveProperties = [-- Move properties. + B Nothing, KO, MN 1, W Nothing, + -- Move annotation properties. + BM db, DO, IT, TE db] + setupProperties = [-- Setup properties. + AB cl, AE cl, AW cl, PL Black] + generalProperties = [-- Node annotation properties. + C tx, DM db, GB db, GW db, HO db, N st, UC db, V rv, + -- Markup properties. + AR [], CR cl, DD cl, LB [], LN [], MA cl, SL cl, SQ cl, TR cl, + -- Guess this fits here. + UnknownProperty "" (toUnknownPropertyValue "")] + rootProperties = [-- Root properties. + AP st st, CA st, FF 1, GM 1, ST vm, SZ 1 1] + gameInfoProperties = [-- Game info properties. + AN st, BR st, BT st, CP st, DT st, EV st, GC st, GN st, ON st, OT st, + PB st, PC st, PW st, RE GameResultVoid, RO st, RU ru, + SO st, TM rv, US st, WR st, WT st] + allProperties = moveProperties ++ setupProperties ++ generalProperties ++ + rootProperties ++ gameInfoProperties + cl = emptyCoordList + db = Double1 + tx = toText "" + st = toSimpleText "" + ru = KnownRuleset RulesetJapanese + rv = 1 + vm = defaultVariationMode + +markPropertyTests = testGroup "markProperty" [ + testCase "doesn't repeat properties" $ + let marks = [minBound..maxBound] + in length marks @=? Set.size (Set.fromList $ map (propertyName . markProperty) marks) + ] diff --git a/tests/Game/Goatee/Sgf/RoundTripTest.hs b/tests/Game/Goatee/Sgf/RoundTripTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/RoundTripTest.hs @@ -0,0 +1,85 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.RoundTripTest (tests) where + +import Data.Function (on) +import Game.Goatee.Common +import Game.Goatee.Sgf.Parser +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Renderer.Tree +import Game.Goatee.Sgf.TestUtils +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=), Assertion, assertFailure) + +testCollection' :: Collection -> Assertion +testCollection' collection = + case runRender $ renderCollection collection of + Left message -> assertFailure $ "Failed to render: " ++ message + Right serialized -> + case parseString serialized of + Left error -> assertFailure $ "Failed to parse: " ++ error ++ + "\n\nEntire SGF: " ++ serialized + Right collection' -> do + on (@?=) CollectionWithDeepEquality collection' collection + case runRender $ renderCollection collection' of + Left message -> assertFailure $ "Second render failed: " ++ message + Right serializedAgain -> serializedAgain @?= serialized + +-- | Returns an assertion that the given node round-trips okay. +testNode' :: Node -> Assertion +testNode' = testCollection' . Collection . (:[]) + +-- | Returns a test with the given string name that round-trips a single node. +testNode :: String -> Node -> Test +testNode label node = testCase label $ testNode' node + +tests = testGroup "Game.Goatee.Sgf.RoundTripTest" [ + singleNodeGameTests, + propertyValueTests + ] + +singleNodeGameTests = testGroup "games with single nodes" [ + testNode "empty game" $ node [], + testNode "some default properties" $ node [FF 4, GM 1, ST defaultVariationMode] + ] + +propertyValueTests = testGroup "property value types" [ + testGroup "label list values" [ + testNode "one value" $ node [LB [((5,2), toSimpleText "Hi.")]], + testNode "multiple value" $ node [LB [((5, 2), toSimpleText "Hi."), + ((0, 1), toSimpleText "Bye.")]] + ], + + testGroup "point-valued values" $ + for [0..boardSizeMax-1] + (\row -> testNode ("row " ++ show row) $ node [B $ Just (0, row)]) ++ + for [0..boardSizeMax-1] + (\col -> testNode ("row " ++ show col) $ node [B $ Just (col, 0)]), + + testGroup "real values" [ + testNode "1500" $ node [TM 1500], + testNode "60.5" $ node [TM 60.5], + testNode "10.1" $ node [TM 10.1] + ] + ] + +-- TODO Many more round-trip tests. diff --git a/tests/Game/Goatee/Sgf/TestInstances.hs b/tests/Game/Goatee/Sgf/TestInstances.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/TestInstances.hs @@ -0,0 +1,25 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Test utilities for working with the SGF modules. +module Game.Goatee.Sgf.TestInstances () where + +import Data.Function (on) +import Game.Goatee.Sgf.Tree (Node, NodeWithDeepEquality(NodeWithDeepEquality)) + +instance Eq Node where + (==) = (==) `on` NodeWithDeepEquality diff --git a/tests/Game/Goatee/Sgf/TestUtils.hs b/tests/Game/Goatee/Sgf/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/TestUtils.hs @@ -0,0 +1,61 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Test utilities for working with the SGF modules. +module Game.Goatee.Sgf.TestUtils ( + node, + node1, + node', + root, + child, + sortProperties, + ) where + +import Data.Function (on) +import Data.List (sortBy) +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree + +node :: [Property] -> Node +node props = emptyNode { nodeProperties = props } + +node1 :: [Property] -> Node -> Node +node1 props child = emptyNode { nodeProperties = props + , nodeChildren = [child] + } + +node' :: [Property] -> [Node] -> Node +node' props children = emptyNode { nodeProperties = props + , nodeChildren = children + } + +-- | Creates a root node that starts with only a 'SZ' property. This is more +-- minimal than 'rootNode'. +root :: Int -> Int -> [Property] -> [Node] -> Node +root width height props = + foldr addChild $ foldr addProperty emptyNode (SZ width height:props) + +child :: Int -> Cursor -> Cursor +child = flip cursorChild + +-- | Sorts properties by their 'Show' strings, for use in tests that need to +-- check an unordered list of properties. +-- +-- TODO Probably better to have a compare-unordered operator. +sortProperties :: [Property] -> [Property] +sortProperties = sortBy (compare `on` show) diff --git a/tests/Game/Goatee/Sgf/TreeTest.hs b/tests/Game/Goatee/Sgf/TreeTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/TreeTest.hs @@ -0,0 +1,114 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.TreeTest (tests) where + +import Data.Version (showVersion) +import Game.Goatee.App (applicationName) +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.TestInstances () +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Game.Goatee.Test.Common +import Paths_goatee (version) +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), (@?=)) + +tests = testGroup "Game.Goatee.Sgf.Tree" [ + emptyNodeTests, + rootNodeTests, + findPropertyTests, + addPropertyTests, + addChildTests + ] + +emptyNodeTests = testGroup "emptyNode" [ + testCase "has no properties" $ [] @=? nodeProperties emptyNode, + testCase "has no children" $ [] @=? nodeChildren emptyNode + ] + +rootNodeTests = testGroup "rootNode" [ + testCase "sets SZ correctly" $ do + assertElem (SZ 9 9) $ nodeProperties $ rootNode $ Just (9, 9) + assertElem (SZ 19 19) $ nodeProperties $ rootNode $ Just (19, 19) + assertElem (SZ 9 5) $ nodeProperties $ rootNode $ Just (9, 5), + + testCase "sets AP correctly" $ do + let ap = AP (toSimpleText applicationName) + (toSimpleText $ showVersion version) + assertElem ap $ nodeProperties $ rootNode Nothing + assertElem ap $ nodeProperties $ rootNode $ Just (9, 9) + ] + +findPropertyTests = testGroup "findProperty" [ + testCase "returns Nothing for an empty node" $ + Nothing @=? findProperty propertyB (mk []), + + testCase "returns Nothing if no properties match" $ + Nothing @=? findProperty propertyB (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]), + + testCase "finds present properties" $ do + Just (B (Just (2,3))) @=? + findProperty propertyB (mk [B (Just (2,3))]) + Just (W Nothing) @=? + findProperty propertyW (mk [B Nothing, W Nothing]) + Just IT @=? + findProperty propertyIT (mk [IT, GW Double2]) + Just (GW Double2) @=? + findProperty propertyGW (mk [IT, GW Double2]), + + testCase "doesn't find absent properties" $ do + Nothing @=? findProperty propertyW (mk [B Nothing]) + Nothing @=? findProperty propertyW (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]) + ] + where mk properties = emptyNode { nodeProperties = properties } + +addPropertyTests = testGroup "addProperty" [ + testCase "adds properties in order" $ do + let prop1 = B (Just (6,6)) + prop2 = RE GameResultVoid + prop3 = C (toText "Game over.") + node1 = addProperty prop1 emptyNode + node2 = addProperty prop2 node1 + node3 = addProperty prop3 node2 + node1 @?= emptyNode { nodeProperties = [prop1] } + node2 @?= emptyNode { nodeProperties = [prop1, prop2] } + node3 @?= emptyNode { nodeProperties = [prop1, prop2, prop3] } + ] + +addChildTests = testGroup "addChild" [ + testCase "adds children in order" $ do + let node1 = emptyNode { nodeProperties = [B (Just (0,0))] } + node2 = emptyNode { nodeProperties = [W (Just (1,1))] } + node3 = emptyNode { nodeProperties = [B (Just (2,2))] } + node4 = emptyNode { nodeProperties = [W Nothing] } + node2' = addChild node3 node2 + node1' = addChild node2' node1 + node1'' = addChild node4 node1' + node1'' @?= mk [B (Just (0,0))] + [mk [W (Just (1,1))] + [mk [B (Just (2,2))] + []], + mk [W Nothing] + []] + ] + where mk properties children = emptyNode { nodeProperties = properties + , nodeChildren = children + } + +-- TODO Test validateNode. diff --git a/tests/Game/Goatee/Sgf/TypesTest.hs b/tests/Game/Goatee/Sgf/TypesTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Sgf/TypesTest.hs @@ -0,0 +1,146 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Sgf.TypesTest (tests) where + +import Data.List (sort) +import Game.Goatee.Sgf.Types +import Game.Goatee.Test.Common +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), Assertion) + +tests = testGroup "Game.Goatee.Sgf.Types" [ + expandCoordListTests, + buildCoordListTests, + simpleTextTests, + cnotTests + ] + +expandCoordListTests = testGroup "expandCoordList" [ + testCase "works with an empty CoordList" $ do + [] @=? expandCoordList (coords []) + [] @=? expandCoordList (coords' [] []), + + testCase "works for single points" $ do + [(1,2)] @=? expandCoordList (coord1 (1,2)) + [(3,4), (1,2)] @=? expandCoordList (coords [(3,4), (1,2)]) + let ten = [(i,i) | i <- [1..10]] + ten @=? expandCoordList (coords ten), + + -- TODO Test that a 1x1 rectangle is rejected. + + testCase "works for a nx1 rect" $ + [(5,2), (5,3), (5,4)] @=? expandCoordList (coords' [] [((5,2), (5,4))]), + + testCase "works for a 1xn rect" $ + [(1,0), (1,1), (1,2), (1,3)] @=? expandCoordList (coords' [] [((1,0), (1,3))]), + + testCase "works for an mxn rect" $ + [(m,n) | m <- [2..5], n <- [3..7]] @=? + expandCoordList (coords' [] [((2,3), (5,7))]), + + -- TODO Test that x0 > x1 || y0 > y1 is rejected. + + testCase "works with multiple rects" $ + [(0,0), (0,1), (0,2), (3,4), (4,4), (5,4)] @=? + expandCoordList (coords' [] [((0,0), (0,2)), ((3,4), (5,4))]), + + testCase "concatenates single points and rects" $ + [(1,1), (0,0), (2,2), (2,3), (2,4)] @=? + expandCoordList (coords' [(1,1), (0,0)] [((2,2), (2,4))]) + ] + +buildCoordListTests = testGroup "buildCoordList" [ + testCase "handles the empty case" $ assertSinglesAndRects [] [] [], + + testCase "handles one single" $ + assertSinglesAndRects [(0,1)] [] [(0,1)], + + testCase "handles multiple singles" $ + assertSinglesAndRects [(0,0), (1,1)] [] [(0,0), (1,1)], + + testCase "handles a small rect (1x2)" $ + assertSinglesAndRects [] [((0,1), (0,2))] [(0,1), (0,2)], + + testCase "handles a small square (2x2)" $ + assertSinglesAndRects [] [((1,1), (2,2))] [(x,y) | x <- [1..2], y <- [1..2]], + + testCase "handles a larger rect" $ + assertSinglesAndRects [] [((0,0), (2,4))] [(x,y) | x <- [0..2], y <- [0..4]], + + testCase "handles two rects" $ + assertSinglesAndRects [] [((0,1), (1,2)), ((3,0), (4,1))] + [(0,1), (1,1), (0,2), (1,2), (3,0), (4,0), (3,1), (4,1)], + + testCase "handles rects and singles together" $ + assertSinglesAndRects [(0,0)] [((1,1), (2,2))] + [(0,0), (1,1), (1,2), (2,1), (2,2)], + + testCase "handles five points together" $ do + assertCoords [(1,0), (0,1), (1,1), (0,2), (1,2)] + assertCoords [(0,0), (1,0), (0,1), (1,1), (0,2)] + assertCoords [(0,0), (1,0), (2,0), (0,1), (1,1)] + assertCoords [(1,0), (2,0), (0,1), (1,1), (2,1)], + + testCase "handles a more complex case" $ + assertCoords [(3,0), (4,0), + (3,1), (4,1), + (0,2), (1,2), (2,2), (3,2), (4,2), + (0,3), (1,3), + (0,4), (1,4), (3,4), (4,4)], + + testCase "handles a diagonal pattern" $ + assertCoords [(0,0), (2,0), (4,0), + (1,1), (3,1), (5,1), + (2,2)] + ] + where -- | Asserts that the given grid of booleans parses to a 'CoordList' + -- that has the expected single points (not necessarily in the same + -- order), as well as the expected rectangles (not necessarily in the + -- same order). + assertSinglesAndRects :: [Coord] -> [(Coord, Coord)] -> [Coord] -> Assertion + assertSinglesAndRects expectedSingles expectedRects input = + coords' expectedSingles expectedRects @=? buildCoordList input + + -- | Asserts that the set of points returned from applying + -- 'buildCoordList' to the given grid of booleans is equal to + -- the given set of points. + assertCoords :: [Coord] -> Assertion + assertCoords input = sort input @=? sort (expandCoordList $ buildCoordList input) + +simpleTextTests = testGroup "SimpleText" [ + testCase "accepts the empty string" $ + "" @=? fromSimpleText (toSimpleText ""), + + testCase "passes through strings without newlines" $ do + "Hello." @=? fromSimpleText (toSimpleText "Hello.") + "Bad for B." @=? fromSimpleText (toSimpleText "Bad for B.") + "[4k?]" @=? fromSimpleText (toSimpleText "[4k?]") + printableAsciiChars @=? fromSimpleText (toSimpleText printableAsciiChars), + + testCase "converts newlines to spaces" $ do + " " @=? fromSimpleText (toSimpleText "\n") + "Hello, world." @=? fromSimpleText (toSimpleText "Hello,\nworld.") + "Hello, world." @=? fromSimpleText (toSimpleText "Hello, \n world.") + " Hello, world. " @=? fromSimpleText (toSimpleText "\nHello, world.\n") + ] + +cnotTests = testGroup "cnot" [ + testCase "changes Black to White" $ White @=? cnot Black, + testCase "changes White to Black" $ Black @=? cnot White + ] diff --git a/tests/Game/Goatee/Test/Common.hs b/tests/Game/Goatee/Test/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Test/Common.hs @@ -0,0 +1,47 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Common utilities for testing code. +module Game.Goatee.Test.Common ( + (@/=?), + assertElem, + printableAsciiChars, + ) where + +import Control.Monad (unless, when) +import Test.HUnit (Assertion, assertFailure) + +-- | Asserts that two values are not equal. Typically, the left argument is a +-- constant value that the right, computed argument should not equal, to mirror +-- '@=?'. +(@/=?) :: (Eq a, Show a) => a -> a -> Assertion +notExpected @/=? actual = + when (notExpected == actual) $ assertFailure $ + let notExpected' = show notExpected + actual' = show actual + in if actual' == notExpected' + then "did not expect: " ++ actual' + else " this value: " ++ actual' ++ + "\nshould not equal: " ++ notExpected' + +assertElem :: (Eq a, Show a) => a -> [a] -> Assertion +assertElem item list = + unless (item `elem` list) $ assertFailure $ + "Expected to find " ++ show item ++ " in the list " ++ show list ++ "." + +printableAsciiChars :: String +printableAsciiChars = [' '..'~'] diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,43 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Main (main) where + +import qualified Game.Goatee.CommonTest +import qualified Game.Goatee.Sgf.BoardTest +import qualified Game.Goatee.Sgf.MonadTest +import qualified Game.Goatee.Sgf.ParserTest +import qualified Game.Goatee.Sgf.Property.ParserTest +import qualified Game.Goatee.Sgf.PropertyTest +import qualified Game.Goatee.Sgf.RoundTripTest +import qualified Game.Goatee.Sgf.TreeTest +import qualified Game.Goatee.Sgf.TypesTest +import Test.Framework (defaultMain) + +tests = [ Game.Goatee.CommonTest.tests + , Game.Goatee.Sgf.BoardTest.tests + , Game.Goatee.Sgf.MonadTest.tests + , Game.Goatee.Sgf.ParserTest.tests + , Game.Goatee.Sgf.Property.ParserTest.tests + , Game.Goatee.Sgf.PropertyTest.tests + , Game.Goatee.Sgf.RoundTripTest.tests + , Game.Goatee.Sgf.TreeTest.tests + , Game.Goatee.Sgf.TypesTest.tests + ] + +main :: IO () +main = defaultMain tests