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-gtk.cabal b/goatee-gtk.cabal new file mode 100644 --- /dev/null +++ b/goatee-gtk.cabal @@ -0,0 +1,85 @@ +name: goatee-gtk +version: 0.1.0 +synopsis: A monadic take on a 2,500-year-old board game - GTK+ UI. +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 GTK+ UI. + +source-repository head + type: git + location: git://git.savannah.gnu.org/goatee.git + +library + build-depends: + base >= 4 && < 5, + cairo >= 0.12 && < 0.13, + containers >= 0.4 && < 0.6, + directory >= 1.1 && < 1.3, + filepath >= 1.3 && < 1.4, + gtk >= 0.12 && < 0.13, + goatee >= 0.1 && < 0.2, + mtl >= 2.1 && < 2.3 + exposed-modules: + Game.Goatee.Ui.Gtk + Game.Goatee.Ui.Gtk.Latch + extensions: + ExistentialQuantification + FlexibleInstances + FunctionalDependencies + MultiParamTypeClasses + ScopedTypeVariables + ViewPatterns + ghc-options: -W -fwarn-incomplete-patterns + hs-source-dirs: src + other-modules: + Game.Goatee.Ui.Gtk.Actions + Game.Goatee.Ui.Gtk.Common + Game.Goatee.Ui.Gtk.GamePropertiesPanel + Game.Goatee.Ui.Gtk.Goban + Game.Goatee.Ui.Gtk.InfoLine + Game.Goatee.Ui.Gtk.MainWindow + Game.Goatee.Ui.Gtk.Utils + Paths_goatee_gtk + +executable goatee-gtk + build-depends: + base >= 4 && < 5, + gtk >= 0.12 && < 0.13, + goatee-gtk + ghc-options: -W -fwarn-incomplete-patterns + hs-source-dirs: src-exe + main-is: Main.hs + +test-suite test-goatee-gtk + build-depends: + base >= 4 && < 5, + goatee-gtk, + HUnit >= 1.2 && < 1.3, + 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.Ui.Gtk.LatchTest + Test + type: exitcode-stdio-1.0 diff --git a/src-exe/Main.hs b/src-exe/Main.hs new file mode 100644 --- /dev/null +++ b/src-exe/Main.hs @@ -0,0 +1,33 @@ +-- 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 Control.Monad (void) +import Game.Goatee.Ui.Gtk +import Graphics.UI.Gtk (initGUI, mainGUI) + +main :: IO () +main = do + args <- initGUI + if null args + then void $ startNewBoard Nothing + else do result <- startFile $ head args + case result of + Left msg -> print msg + _ -> return () + mainGUI diff --git a/src/Game/Goatee/Ui/Gtk.hs b/src/Game/Goatee/Ui/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk.hs @@ -0,0 +1,575 @@ +-- 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 . + +-- | The main module for the GTK+ UI, used by clients of the UI. Also +-- implements the UI controller. +module Game.Goatee.Ui.Gtk ( + startBoard, + startNewBoard, + startFile, + ) where + +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, readMVar, putMVar, modifyMVar, modifyMVar_) +import Control.Exception (IOException, catch, finally) +import Control.Monad (forM_, join, liftM, unless, when) +import Data.Foldable (foldl') +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Unique (Unique, newUnique) +import Game.Goatee.App +import Game.Goatee.Common +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Renderer +import Game.Goatee.Sgf.Renderer.Tree +import Game.Goatee.Sgf.Tree +import qualified Game.Goatee.Sgf.Monad as Monad +import Game.Goatee.Sgf.Monad (Event, on, childAddedEvent, propertiesModifiedEvent) +import Game.Goatee.Ui.Gtk.Common +import qualified Game.Goatee.Ui.Gtk.MainWindow as MainWindow +import Game.Goatee.Ui.Gtk.MainWindow (MainWindow) +import Graphics.UI.Gtk ( + AttrOp ((:=)), + ButtonsType (ButtonsNone, ButtonsOk, ButtonsYesNo), + DialogFlags (DialogDestroyWithParent, DialogModal), + FileChooserAction (FileChooserActionOpen, FileChooserActionSave), + MessageType (MessageError, MessageQuestion), + ResponseId (ResponseCancel, ResponseNo, ResponseOk, ResponseYes), + aboutDialogAuthors, aboutDialogCopyright, aboutDialogLicense, aboutDialogNew, + aboutDialogProgramName, aboutDialogWebsite, + dialogAddButton, dialogRun, + fileChooserAddFilter, fileChooserDialogNew, fileChooserGetFilename, + mainQuit, + messageDialogNew, + stockCancel, stockOpen, stockSave, stockSaveAs, + widgetDestroy, widgetHide, + set, + ) +import qualified Paths_goatee_gtk as Paths +import System.Directory (doesFileExist) + +-- | A structure for holding global application information about all open +-- boards. +data AppState = AppState { appControllers :: MVar (Map CtrlId UiCtrlImpl) + -- ^ Maps all of the open boards' controllers by + -- their IDs. + } + +-- | Creates an 'AppState' that is holding no controllers. +newAppState :: IO AppState +newAppState = do + controllers <- newMVar Map.empty + return AppState { appControllers = controllers } + +-- | Registers a 'UiCtrlImpl' with an 'AppState'. +appStateRegister :: AppState -> UiCtrlImpl -> IO () +appStateRegister appState ui = + modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) ui + +-- | Unregisters a 'UiCtrlImpl' from an 'AppState'. If the 'AppState' is left +-- with no controllers, then the GTK+ main loop is shut down and the application +-- exits. +appStateUnregister :: AppState -> UiCtrlImpl -> IO () +appStateUnregister appState ui = do + ctrls' <- modifyMVar (appControllers appState) $ \ctrls -> + let ctrls' = Map.delete (uiCtrlId ui) ctrls + in return (ctrls', ctrls') + when (Map.null ctrls') mainQuit + +data UiHandler = forall handler. UiHandler String (Event UiGoM handler) handler + +data DirtyChangedHandlerRecord = + DirtyChangedHandlerRecord { dirtyChangedHandlerOwner :: String + , dirtyChangedHandlerFn :: DirtyChangedHandler + } + +data FilePathChangedHandlerRecord = + FilePathChangedHandlerRecord { filePathChangedHandlerOwner :: String + , filePathChangedHandlerFn :: FilePathChangedHandler + } + +data ModesChangedHandlerRecord = + ModesChangedHandlerRecord { modesChangedHandlerOwner :: String + , modesChangedHandlerFn :: ModesChangedHandler + } + +-- | A unique ID that identifies a 'UiCtrlImpl'. +newtype CtrlId = CtrlId Unique + deriving (Eq, Ord) + +-- | Implementation of 'UiCtrl'. +data UiCtrlImpl = UiCtrlImpl { uiCtrlId :: CtrlId + , uiAppState :: AppState + , uiDirty :: IORef Bool + , uiFilePath :: IORef (Maybe FilePath) + , uiModes :: IORef UiModes + , uiCursor :: MVar Cursor + + , uiMainWindow :: IORef (Maybe (MainWindow UiCtrlImpl)) + + -- Go monad action-related properties: + , uiHandlers :: IORef (Map Registration UiHandler) + , uiBaseAction :: IORef (UiGoM ()) + + -- Ui action-related properties: + , uiDirtyChangedHandlers :: + IORef (Map Registration DirtyChangedHandlerRecord) + , uiFilePathChangedHandlers :: + IORef (Map Registration FilePathChangedHandlerRecord) + , uiModesChangedHandlers :: + IORef (Map Registration ModesChangedHandlerRecord) + } + +instance UiCtrl UiCtrlImpl where + readModes = readIORef . uiModes + + modifyModes ui f = do + oldModes <- readModes ui + newModes <- f oldModes + unless (newModes == oldModes) $ do + writeIORef (uiModes ui) newModes + fireModesChangedHandlers ui oldModes newModes + + runUiGo ui go = do + cursor <- takeMVar (uiCursor ui) + runUiGo' ui go cursor + + readCursor = readMVar . uiCursor + + isValidMove ui coord = do + cursor <- readMVar $ uiCursor ui + return $ isCurrentValidMove (cursorBoard cursor) coord + + playAt ui coord = do + cursor <- takeMVar $ uiCursor ui + if not $ isCurrentValidMove (cursorBoard cursor) coord + then do + dialog <- messageDialogNew Nothing + [DialogModal, DialogDestroyWithParent] + MessageError + ButtonsOk + "Illegal move." + dialogRun dialog + widgetDestroy dialog + putMVar (uiCursor ui) cursor + else case cursorChildPlayingAt coord cursor of + Just child -> runUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor + Nothing -> + let board = cursorBoard cursor + player = boardPlayerTurn board + index = length $ cursorChildren cursor + child = emptyNode { nodeProperties = [colorToMove player coord] } + in runUiGo' ui (Monad.addChild index child >> Monad.goDown index) cursor + + goUp ui = runUiGo ui $ do + cursor <- Monad.getCursor + if isNothing $ cursorParent cursor + then return False + else Monad.goUp >> return True + + goDown ui index = runUiGo ui $ do + cursor <- Monad.getCursor + if null $ drop index $ cursorChildren cursor + then return False + else Monad.goDown index >> return True + + goLeft ui = runUiGo ui $ do + cursor <- Monad.getCursor + case (cursorParent cursor, cursorChildIndex cursor) of + (Nothing, _) -> return False + (Just _, 0) -> return False + (Just _, n) -> do Monad.goUp + Monad.goDown $ n - 1 + return True + + goRight ui = runUiGo ui $ do + cursor <- Monad.getCursor + case (cursorParent cursor, cursorChildIndex cursor) of + (Nothing, _) -> return False + (Just parent, n) | n == cursorChildCount parent - 1 -> return False + (Just _, n) -> do Monad.goUp + Monad.goDown $ n + 1 + return True + + register ui caller event handler = do + unique <- newUnique + modifyIORef (uiHandlers ui) $ Map.insert unique $ UiHandler caller event handler + modifyIORef (uiBaseAction ui) (>> on event handler) + return unique + + unregister ui unique = do + handlers <- readIORef $ uiHandlers ui + let (handlers', found) = if Map.member unique handlers + then (Map.delete unique handlers, True) + else (handlers, False) + when found $ do + writeIORef (uiHandlers ui) handlers' + rebuildBaseAction ui + return found + + registeredHandlers = + liftM (map (\(UiHandler owner event _) -> (owner, show event)) . Map.elems) . + readIORef . + uiHandlers + + registerModesChangedHandler ui owner handler = do + unique <- newUnique + modifyIORef (uiModesChangedHandlers ui) $ Map.insert unique + ModesChangedHandlerRecord { modesChangedHandlerOwner = owner + , modesChangedHandlerFn = handler + } + return unique + + unregisterModesChangedHandler ui unique = do + handlers <- readIORef $ uiModesChangedHandlers ui + let (handlers', found) = if Map.member unique handlers + then (Map.delete unique handlers, True) + else (handlers, False) + when found $ writeIORef (uiModesChangedHandlers ui) handlers' + return found + + registeredModesChangedHandlers = + liftM (map modesChangedHandlerOwner . Map.elems) . readIORef . uiModesChangedHandlers + + getMainWindow = fmap MainWindow.myWindow . getMainWindow' + + openBoard maybeUi maybePath rootNode = do + ctrlId <- fmap CtrlId newUnique + appState <- maybe newAppState (return . uiAppState) maybeUi + dirty <- newIORef False + filePath <- newIORef maybePath + modesVar <- newIORef defaultUiModes + cursorVar <- newMVar $ rootCursor rootNode + mainWindowRef <- newIORef Nothing + uiHandlers <- newIORef Map.empty + baseAction <- newIORef $ return () + dirtyChangedHandlers <- newIORef Map.empty + filePathChangedHandlers <- newIORef Map.empty + modesChangedHandlers <- newIORef Map.empty + + let ui = UiCtrlImpl { uiCtrlId = ctrlId + , uiAppState = appState + , uiDirty = dirty + , uiFilePath = filePath + , uiModes = modesVar + , uiCursor = cursorVar + , uiMainWindow = mainWindowRef + , uiHandlers = uiHandlers + , uiBaseAction = baseAction + , uiDirtyChangedHandlers = dirtyChangedHandlers + , uiFilePathChangedHandlers = filePathChangedHandlers + , uiModesChangedHandlers = modesChangedHandlers + } + + appStateRegister appState ui + rebuildBaseAction ui + + mainWindow <- MainWindow.create ui + writeIORef mainWindowRef $ Just mainWindow + MainWindow.display mainWindow + return ui + + fileOpen ui = do + dialog <- fileChooserDialogNew (Just "Open a file") + Nothing + FileChooserActionOpen + [(stockCancel, ResponseCancel), + (stockOpen, ResponseOk)] + mapM_ (fileChooserAddFilter dialog) =<< fileFiltersForSgf + response <- dialogRun dialog + widgetHide dialog + finally + (when (response == ResponseOk) $ do + maybePath <- fileChooserGetFilename dialog + when (isJust maybePath) $ do + let path = fromJust maybePath + loadResult <- openFile (Just ui) path + case loadResult of + Left parseError -> do + errorDialog <- messageDialogNew + Nothing + [] + MessageError + ButtonsOk + ("Error loading " ++ path ++ ".\n\n" ++ show parseError) + dialogRun errorDialog + widgetDestroy errorDialog + Right _ -> return ()) + (widgetDestroy dialog) + + fileSave ui = do + cursor <- readCursor ui + maybePath <- getFilePath ui + case maybePath of + Nothing -> fileSaveAs ui + Just path -> + -- TODO Exception handling when the write fails. + -- TODO Don't just write a single tree. + -- TODO Only save when dirty? (Be careful not to break Save As on a non-dirty game.) + case runRender $ + renderCollection Collection { collectionTrees = [cursorNode $ cursorRoot cursor] } of + Left message -> do + dialog <- messageDialogNew Nothing + [DialogModal, DialogDestroyWithParent] + MessageError + ButtonsOk + ("Error serializing game tree:\n\n" ++ message) + dialogRun dialog + widgetDestroy dialog + return False + Right sgf -> do + writeFile path sgf + setDirty ui False + return True + + fileSaveAs ui = do + dialog <- fileChooserDialogNew (Just "Save file as") + Nothing + FileChooserActionSave + [(stockCancel, ResponseCancel), + (stockSave, ResponseOk)] + mapM_ (fileChooserAddFilter dialog) =<< fileFiltersForSgf + response <- dialogRun dialog + finally + (case response of + ResponseOk -> do + maybePath <- fileChooserGetFilename dialog + case maybePath of + Just path -> do + confirm <- confirmSaveIfAlreadyExists path + if confirm + then do setFilePath ui $ Just path + fileSave ui + else return False + _ -> return False + _ -> return False) + (widgetDestroy dialog) + + fileClose ui = do + close <- confirmFileClose ui + when close $ closeBoard ui + return close + + fileQuit ui = do + ctrls <- fmap Map.elems $ readMVar $ appControllers $ uiAppState ui + okayToClose <- andM $ map confirmFileClose ctrls + when okayToClose $ mapM_ closeBoard ctrls + return okayToClose + + helpAbout _ = do + about <- aboutDialogNew + license <- fmap (fromMaybe fallbackLicense) readLicense + set about [ aboutDialogProgramName := applicationName + , aboutDialogCopyright := applicationCopyright + , aboutDialogLicense := Just license + , aboutDialogWebsite := applicationWebsite + , aboutDialogAuthors := applicationAuthors + ] + dialogRun about + widgetDestroy about + return () + + getFilePath = readIORef . uiFilePath + + setFilePath ui path = do + oldPath <- readIORef $ uiFilePath ui + writeIORef (uiFilePath ui) path + handlers <- readIORef $ uiFilePathChangedHandlers ui + forM_ (Map.elems handlers) $ \record -> + filePathChangedHandlerFn record oldPath path + + registerFilePathChangedHandler ui owner fireImmediately handler = do + unique <- newUnique + modifyIORef (uiFilePathChangedHandlers ui) $ Map.insert unique + FilePathChangedHandlerRecord { filePathChangedHandlerOwner = owner + , filePathChangedHandlerFn = handler + } + when fireImmediately $ do + path <- getFilePath ui + handler path path + return unique + + unregisterFilePathChangedHandler ui unique = do + handlers <- readIORef $ uiFilePathChangedHandlers ui + let (handlers', found) = if Map.member unique handlers + then (Map.delete unique handlers, True) + else (handlers, False) + when found $ writeIORef (uiFilePathChangedHandlers ui) handlers' + return found + + registeredFilePathChangedHandlers = + liftM (map filePathChangedHandlerOwner . Map.elems) . readIORef . uiFilePathChangedHandlers + + getDirty = readIORef . uiDirty + + setDirty ui newDirty = do + oldDirty <- readIORef $ uiDirty ui + unless (oldDirty == newDirty) $ do + writeIORef (uiDirty ui) newDirty + handlers <- readIORef $ uiDirtyChangedHandlers ui + forM_ (map dirtyChangedHandlerFn $ Map.elems handlers) ($ newDirty) + + registerDirtyChangedHandler ui owner fireImmediately handler = do + unique <- newUnique + modifyIORef (uiDirtyChangedHandlers ui) $ Map.insert unique + DirtyChangedHandlerRecord { dirtyChangedHandlerOwner = owner + , dirtyChangedHandlerFn = handler + } + when fireImmediately $ do + dirty <- readIORef $ uiDirty ui + handler dirty + return unique + + unregisterDirtyChangedHandler ui unique = do + handlers <- readIORef $ uiDirtyChangedHandlers ui + let (handlers', found) = if Map.member unique handlers + then (Map.delete unique handlers, True) + else (handlers, False) + when found $ writeIORef (uiDirtyChangedHandlers ui) handlers' + return found + + registeredDirtyChangedHandlers = + liftM (map dirtyChangedHandlerOwner . Map.elems) . readIORef . uiDirtyChangedHandlers + +-- | 'runUiGo' for 'UiCtrlImpl' is implemented by taking the cursor MVar, +-- running a Go action, putting the MVar, then running handlers. Many types of +-- actions the UI wants to perform need to be able to take the cursor +-- themselves, do some logic, then pass it off to run a Go action, re-put, and +-- call handlers. This function is a helper for such UI code. +runUiGo' :: UiCtrlImpl -> UiGoM a -> Cursor -> IO a +runUiGo' ui go cursor = do + baseAction <- readIORef $ uiBaseAction ui + let (value, cursor', handlers) = runUiGoPure (baseAction >> go) cursor + putMVar (uiCursor ui) cursor' + handlers + return value + +startBoard :: Node -> IO UiCtrlImpl +startBoard = openBoard Nothing Nothing + +startNewBoard :: Maybe (Int, Int) -> IO UiCtrlImpl +startNewBoard = openNewBoard Nothing + +startFile :: FilePath -> IO (Either String UiCtrlImpl) +startFile = openFile Nothing + +rebuildBaseAction :: UiCtrlImpl -> IO () +rebuildBaseAction ui = + readIORef (uiHandlers ui) >>= writeIORef (uiBaseAction ui) . buildBaseAction + where buildBaseAction = + foldl' (\io (UiHandler _ event handler) -> io >> on event handler) + commonAction + commonAction = do + -- TODO This really calls for some sort of event hierarchy, so + -- that we can listen for all mutating events here, rather than + -- making it easy to forget to add new events here. + on childAddedEvent $ \_ _ -> setDirtyTrue + on propertiesModifiedEvent $ \_ _ -> setDirtyTrue + setDirtyTrue = afterGo $ setDirty ui True + +fireModesChangedHandlers :: UiCtrlImpl -> UiModes -> UiModes -> IO () +fireModesChangedHandlers ui oldModes newModes = do + handlers <- readIORef $ uiModesChangedHandlers ui + forM_ (Map.elems handlers) $ \handler -> + modesChangedHandlerFn handler oldModes newModes + +-- | Retrieves the 'MainWindow' owned by the controller. It is an error to call +-- this before the main window has been set up. +getMainWindow' :: UiCtrlImpl -> IO (MainWindow UiCtrlImpl) +getMainWindow' ui = join $ + fmap (maybe (fail "getMainWindow: No window available.") return) $ + readIORef $ + uiMainWindow ui + +-- | If the given file already exists, then the user is shown a dialog box +-- asking whether the file should be overwritten. Returns true if the user says +-- yes, or if the file doesn't exist. +confirmSaveIfAlreadyExists :: FilePath -> IO Bool +confirmSaveIfAlreadyExists path = do + exists <- doesFileExist path + if exists + then do dialog <- messageDialogNew + Nothing + [] + MessageQuestion + ButtonsYesNo + (path ++ " already exists. Overwrite?") + response <- dialogRun dialog + widgetDestroy dialog + return $ response == ResponseYes + else return True + +-- | Should be called before destroying the main window. Checks the dirty +-- state of UI; if dirty, then a dialog prompts the user whether the game +-- should be saved before closing, and giving the option to cancel closing. +-- Returns true if the window should be closed. +confirmFileClose :: UiCtrl ui => ui -> IO Bool +confirmFileClose ui = do + dirty <- getDirty ui + if dirty + then do filePath <- getFilePath ui + fileName <- getFileName ui + window <- getMainWindow ui + dialog <- messageDialogNew + (Just window) + [DialogModal, DialogDestroyWithParent] + MessageQuestion + ButtonsNone + (fileName ++ " has unsaved changes. Save before closing?") + dialogAddButton dialog "Close without saving" ResponseNo + dialogAddButton dialog stockCancel ResponseCancel + dialogAddButton dialog (maybe stockSaveAs (const stockSave) filePath) ResponseYes + result <- dialogRun dialog + widgetDestroy dialog + case result of + ResponseYes -> fileSave ui + ResponseNo -> return True + _ -> return False + else return True + +-- | Hides and releases the game's 'Game.Goatee.Ui.Gtk.MainWindow', and shuts +-- down the UI controller (in effect closing the game, with no prompting). If +-- this is the last board open, then the application will exit. +closeBoard :: UiCtrlImpl -> IO () +closeBoard ui = do + MainWindow.destroy =<< getMainWindow' ui + appStateUnregister (uiAppState ui) ui + +-- | Attempts to read the project's license file. If successful, the license is +-- returend, otherwise a fallback message is returned instead. +readLicense :: IO (Maybe String) +readLicense = do + path <- Paths.getDataFileName "LICENSE" + fmap Just (readFile path) `Control.Exception.catch` \(_ :: IOException) -> return Nothing + +fallbackLicense :: String +fallbackLicense = + "Could not read the license file." ++ + "\n" ++ + "\nGoatee is free software: you can redistribute it and/or modify" ++ + "\nit under the terms of the GNU Affero General Public License as published by" ++ + "\nthe Free Software Foundation, either version 3 of the License, or" ++ + "\n(at your option) any later version." ++ + "\n" ++ + "\nGoatee is distributed in the hope that it will be useful," ++ + "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++ + "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" ++ + "\nGNU Affero General Public License for more details." ++ + "\n" ++ + "\nYou should have received a copy of the GNU Affero General Public License" ++ + "\nalong with Goatee. If not, see ." diff --git a/src/Game/Goatee/Ui/Gtk/Actions.hs b/src/Game/Goatee/Ui/Gtk/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Actions.hs @@ -0,0 +1,306 @@ +-- 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 . + +-- | GTK+ 'Action' definitions. +module Game.Goatee.Ui.Gtk.Actions ( + Actions, + create, + destroy, + myFileNew9Action, + myFileNew13Action, + myFileNew19Action, + myFileNewCustomAction, + myFileOpenAction, + myFileSaveAction, + myFileSaveAsAction, + myFileCloseAction, + myFileQuitAction, + myToolActions, + myViewVariationsChildAction, + myViewVariationsCurrentAction, + myViewVariationsBoardMarkupOnAction, + myViewVariationsBoardMarkupOffAction, + myViewHighlightCurrentMovesAction, + myHelpAboutAction, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (void, when) +import Data.Maybe (fromMaybe) +import Game.Goatee.Ui.Gtk.Common +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Monad hiding (on) +import Game.Goatee.Sgf.Types +import Graphics.UI.Gtk ( + Action, + ActionGroup, + AttrOp ((:=)), + Packing (PackGrow), + RadioAction, + RadioActionEntry ( + RadioActionEntry, + radioActionAccelerator, radioActionLabel, radioActionName, radioActionStockId, + radioActionTooltip, radioActionValue + ), + ResponseId (ResponseCancel, ResponseOk), + SpinButtonUpdatePolicy (UpdateIfValid), + ToggleAction, + actionActivate, actionActivated, actionGroupAddActionWithAccel, actionGroupAddRadioActions, + actionGroupGetAction, actionGroupNew, actionNew, actionToggled, + boxPackStart, + dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse, + get, + labelNewWithMnemonic, labelSetMnemonicWidget, + on, + radioActionChanged, radioActionCurrentValue, radioActionNew, radioActionSetGroup, + set, + spinButtonGetValueAsInt, spinButtonNewWithRange, spinButtonSetNumeric, spinButtonSetUpdatePolicy, + spinButtonSetValue, spinButtonSetWrap, + stockCancel, + tableAttachDefaults, tableNew, + toggleActionActive, toggleActionNew, + widgetDestroy, widgetShowAll, + ) + +data Actions ui = Actions { myUi :: ui + , myRegistrations :: ViewRegistrations + , myFileNew9Action :: Action + , myFileNew13Action :: Action + , myFileNew19Action :: Action + , myFileNewCustomAction :: Action + , myFileOpenAction :: Action + , myFileSaveAction :: Action + , myFileSaveAsAction :: Action + , myFileCloseAction :: Action + , myFileQuitAction :: Action + , myToolActions :: ActionGroup + , myViewVariationsChildAction :: RadioAction + , myViewVariationsCurrentAction :: RadioAction + , myViewVariationsBoardMarkupOnAction :: RadioAction + , myViewVariationsBoardMarkupOffAction :: RadioAction + , myViewHighlightCurrentMovesAction :: ToggleAction + , myHelpAboutAction :: Action + } + +instance UiCtrl ui => UiView (Actions ui) ui where + viewName = const "Actions" + viewCtrl = myUi + viewRegistrations = myRegistrations + +create :: UiCtrl ui => ui -> IO (Actions ui) +create ui = do + let tools = enumFrom minBound + modes <- readModes ui + + -- File actions. + fileActions <- actionGroupNew "File" + + fileNew9Action <- actionNew "FileNew9" "New _9x9 board" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileNew9Action Nothing + on fileNew9Action actionActivated $ void $ openNewBoard (Just ui) (Just (9, 9)) + + fileNew13Action <- actionNew "FileNew13" "New 1_3x13 board" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileNew13Action Nothing + on fileNew13Action actionActivated $ void $ openNewBoard (Just ui) (Just (13, 13)) + + fileNew19Action <- actionNew "FileNew19" "New _19x19 board" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileNew19Action $ Just "n" + on fileNew19Action actionActivated $ void $ openNewBoard (Just ui) (Just (19, 19)) + + fileNewCustomAction <- actionNew "FileNewCustom" "New _custom board..." Nothing Nothing + actionGroupAddActionWithAccel fileActions fileNewCustomAction Nothing + on fileNewCustomAction actionActivated $ do + dialog <- dialogNew + upper <- dialogGetUpper dialog + table <- tableNew 2 2 False + boxPackStart upper table PackGrow 0 + + -- SGF only supports boards up to 'boardSizeMax', but Goatee works fine with + -- larger boards. The spinner wants an upper bound, so let's at least set + -- something that isn't too outrageous along a single dimension. + let arbitraryUpperLimit = 1000 + makeSpinButton = do + spin <- spinButtonNewWithRange + (fromIntegral boardSizeMin) + (fromIntegral arbitraryUpperLimit) + 1 + spinButtonSetUpdatePolicy spin UpdateIfValid + spinButtonSetNumeric spin True + spinButtonSetWrap spin False + return spin + + widthLabel <- labelNewWithMnemonic "_Width" + widthSpin <- makeSpinButton + labelSetMnemonicWidget widthLabel widthSpin + tableAttachDefaults table widthLabel 0 1 0 1 + tableAttachDefaults table widthSpin 1 2 0 1 + + heightLabel <- labelNewWithMnemonic "_Height" + heightSpin <- makeSpinButton + labelSetMnemonicWidget heightLabel heightSpin + tableAttachDefaults table heightLabel 0 1 1 2 + tableAttachDefaults table heightSpin 1 2 1 2 + + dialogAddButton dialog stockCancel ResponseCancel + dialogAddButton dialog "C_reate" ResponseOk + dialogSetDefaultResponse dialog ResponseOk + + spinButtonSetValue widthSpin $ fromIntegral boardSizeDefault + spinButtonSetValue heightSpin $ fromIntegral boardSizeDefault + + widgetShowAll dialog + response <- dialogRun dialog + width <- spinButtonGetValueAsInt widthSpin + height <- spinButtonGetValueAsInt heightSpin + widgetDestroy dialog + when (response == ResponseOk) $ + void $ openNewBoard (Just ui) (Just (width, height)) + + fileOpenAction <- actionNew "FileOpen" "_Open file..." Nothing Nothing + actionGroupAddActionWithAccel fileActions fileOpenAction $ Just "o" + on fileOpenAction actionActivated $ fileOpen ui + + fileSaveAction <- actionNew "FileSave" "_Save file" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileSaveAction $ Just "s" + on fileSaveAction actionActivated $ void $ fileSave ui + + fileSaveAsAction <- actionNew "FileSaveAs" "Sa_ve file as..." Nothing Nothing + actionGroupAddActionWithAccel fileActions fileSaveAsAction $ Just "s" + on fileSaveAsAction actionActivated $ void $ fileSaveAs ui + + fileCloseAction <- actionNew "FileClose" "_Close" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileCloseAction $ Just "w" + on fileCloseAction actionActivated $ void $ fileClose ui + + fileQuitAction <- actionNew "FileQuit" "_Quit" Nothing Nothing + actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "q" + on fileQuitAction actionActivated $ void $ fileQuit ui + + -- Tool actions. + toolActions <- actionGroupNew "Tools" + actionGroupAddRadioActions toolActions + (flip map tools $ \tool -> + RadioActionEntry { radioActionName = show tool + , radioActionLabel = toolLabel tool + , radioActionStockId = Nothing + , radioActionAccelerator = Nothing + , radioActionTooltip = Nothing + , radioActionValue = fromEnum tool + }) + (fromEnum initialTool) + (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue)) + + -- Variation mode view actions. + viewVariationsChildAction <- radioActionNew "viewVariationsChild" + "_Child variations" + (Just "Show children node as variations") + Nothing + (fromEnum ShowChildVariations) + viewVariationsCurrentAction <- radioActionNew "viewVariationsCurrent" + "C_urrent variations" + (Just "Show variations of the current node") + Nothing + (fromEnum ShowCurrentVariations) + radioActionSetGroup viewVariationsChildAction viewVariationsCurrentAction + + viewVariationsBoardMarkupOnAction <- radioActionNew "viewVariationsBoardMarkupOn" + "_Show on board" + (Just "Show move variations on the board") + Nothing + (fromEnum True) + viewVariationsBoardMarkupOffAction <- radioActionNew "viewVariationsBoardMarkupOn" + "_Hide on board" + (Just "Hide move variations on the board") + Nothing + (fromEnum False) + radioActionSetGroup viewVariationsBoardMarkupOnAction viewVariationsBoardMarkupOffAction + + initialVariationMode <- + rootInfoVariationMode . gameInfoRootInfo . boardGameInfo . cursorBoard <$> + readCursor ui + set viewVariationsChildAction + [radioActionCurrentValue := fromEnum (variationModeSource initialVariationMode)] + set viewVariationsBoardMarkupOnAction + [radioActionCurrentValue := fromEnum (variationModeBoardMarkup initialVariationMode)] + + -- This signal is emitted on every action in a radio group when the active + -- item is changed, so we only need to listen with one action. + on viewVariationsChildAction radioActionChanged $ \action -> do + value <- toEnum <$> get action radioActionCurrentValue + runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeSource = value } + + on viewVariationsBoardMarkupOnAction radioActionChanged $ \action -> do + value <- toEnum <$> get action radioActionCurrentValue + runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeBoardMarkup = value } + + viewHighlightCurrentMovesAction <- + toggleActionNew "ViewHighlightCurrentMoves" "Highlight _current moves" Nothing Nothing + set viewHighlightCurrentMovesAction [toggleActionActive := uiHighlightCurrentMovesMode modes] + on viewHighlightCurrentMovesAction actionToggled $ do + active <- get viewHighlightCurrentMovesAction toggleActionActive + modifyModes ui $ \modes -> return modes { uiHighlightCurrentMovesMode = active } + + helpAboutAction <- actionNew "HelpAbout" "_About" Nothing Nothing + on helpAboutAction actionActivated $ helpAbout ui + + actionActivate =<< + fmap (fromMaybe $ error $ "Could not find the initial tool " ++ show initialTool ++ ".") + (actionGroupGetAction toolActions $ show initialTool) + + registrations <- viewNewRegistrations + + let me = Actions { myUi = ui + , myRegistrations = registrations + , myFileNew9Action = fileNew9Action + , myFileNew13Action = fileNew13Action + , myFileNew19Action = fileNew19Action + , myFileNewCustomAction = fileNewCustomAction + , myFileOpenAction = fileOpenAction + , myFileSaveAction = fileSaveAction + , myFileSaveAsAction = fileSaveAsAction + , myFileCloseAction = fileCloseAction + , myFileQuitAction = fileQuitAction + , myToolActions = toolActions + , myViewVariationsChildAction = viewVariationsChildAction + , myViewVariationsCurrentAction = viewVariationsCurrentAction + , myViewVariationsBoardMarkupOnAction = viewVariationsBoardMarkupOnAction + , myViewVariationsBoardMarkupOffAction = viewVariationsBoardMarkupOffAction + , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction + , myHelpAboutAction = helpAboutAction + } + + initialize me + return me + +initialize :: UiCtrl ui => Actions ui -> IO () +initialize me = + viewRegister me variationModeChangedEvent $ \_ new -> afterGo $ do + let newSource = fromEnum $ variationModeSource new + newBoardMarkup = fromEnum $ variationModeBoardMarkup new + sourceAction = myViewVariationsChildAction me + boardMarkupAction = myViewVariationsBoardMarkupOnAction me + + oldSource <- get sourceAction radioActionCurrentValue + when (newSource /= oldSource) $ + set sourceAction [radioActionCurrentValue := newSource] + + oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue + when (newBoardMarkup /= oldBoardMarkup) $ + set boardMarkupAction [radioActionCurrentValue := newBoardMarkup] + +destroy :: UiCtrl ui => Actions ui -> IO () +destroy = viewUnregisterAll diff --git a/src/Game/Goatee/Ui/Gtk/Common.hs b/src/Game/Goatee/Ui/Gtk/Common.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Common.hs @@ -0,0 +1,419 @@ +-- 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 dependencies among all GTK+ UI code. Contains class definitions and +-- some common data declarations. +module Game.Goatee.Ui.Gtk.Common ( + -- * UI controllers + UiGoM, + afterGo, + runUiGoPure, + UiCtrl (..), + Registration, + DirtyChangedHandler, + FilePathChangedHandler, + ModesChangedHandler, + modifyModesPure, + setTool, + -- * UI views + UiView (..), + ViewRegistrations, + viewNewRegistrations, + viewRegister, + viewUnregisterAll, + -- * UI modes + UiModes (..), + ViewMode (..), + defaultUiModes, + Tool (..), + initialTool, + toolOrdering, + toolLabel, + toolToColor, + fileFiltersForSgf, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Writer (Writer, runWriter, tell) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import Data.Unique (Unique) +import Game.Goatee.Common (Seq(..)) +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Monad +import Game.Goatee.Sgf.Parser +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Graphics.UI.Gtk (FileFilter, Window, fileFilterAddPattern, fileFilterNew, fileFilterSetName) +import System.FilePath (takeFileName) + +-- | A Go monad with handlers in the 'IO' monad. +type UiGoM = GoT (Writer (Seq IO)) + +-- | Schedules an IO action to run after the currently-executing Go monad +-- completes. The IO action should not attempt to access the cursor, as it may +-- not be available; instead it should work within the Go monad for cursor +-- manipulation (e.g. 'Game.Goatee.Sgf.Monad.getCursor'). +afterGo :: IO () -> UiGoM () +afterGo = tell . Seq + +-- | Applies a 'UiGoM' to a 'Cursor' purely, as opposed to 'runUiGo' which works +-- with the UI controller's cursor. Returns a tuple containing the Go action's +-- result, the final cursor, and the IO action resulting from all handlers being +-- run. +runUiGoPure :: UiGoM a -> Cursor -> (a, Cursor, IO ()) +runUiGoPure go cursor = + let ((value, cursor'), Seq action) = runWriter $ runGoT go cursor + in (value, cursor', action) + +-- | A controller for the GTK+ UI. +class UiCtrl a where + -- | Reads the current UI modes. + readModes :: a -> IO UiModes + + -- | Modifies the controller's modes according to the given action, then fires + -- a mode change event via 'fireViewModesChanged'. + modifyModes :: a -> (UiModes -> IO UiModes) -> IO () + + -- | Runs a Go monad on the current cursor, updating the cursor and firing + -- handlers as necessary. + runUiGo :: a -> UiGoM b -> IO b + + -- | Returns the current cursor. + readCursor :: a -> IO Cursor + + -- | Determines whether it is currently valid to play at the given point. + isValidMove :: a -> Coord -> IO Bool + + -- | Makes the current player place a stone at the given point. + playAt :: a -> Coord -> IO () + + -- | If possible, takes a step up to the parent of the current node in the + -- game tree. Returns whether a move was made (i.e. whether the current node + -- is not the root node). + goUp :: a -> IO Bool + + -- | If possible, takes a step down from the current node to its child at the + -- given index. Returns whether a move was made (i.e. whether the node had + -- @n+1@ children). + goDown :: a -> Int -> IO Bool + + -- | If possible, move to the sibling node immediately to the left of the + -- current one. Returns whether a move was made (i.e. whether there was a + -- left sibling). + goLeft :: a -> IO Bool + + -- | If possible, move to the sibling node immediately to the right of the + -- current one. Returns whether a move was made (i.e. whether there was a + -- right sibling). + goRight :: a -> IO Bool + + -- | Registers a handler for a given 'Event'. The string is the name of the + -- caller, used to keep track of what components registered what handlers. + -- Returns a 'Registration' that can be given to 'unregister' to prevent any + -- further calls to the handler. + register :: a -> String -> Event UiGoM handler -> handler -> IO Registration + + -- | Unregisters the handler for a 'Registration' that was returned from + -- 'register'. Returns true if such a handler was found and removed. + unregister :: a -> Registration -> IO Bool + + -- | Returns the currently registered handlers, as (owner, event name) pairs. + registeredHandlers :: a -> IO [(String, String)] + + -- | Registers a handler that will execute when UI modes change. The string + -- is the name of the caller, used to keep track of what components registered + -- what handlers. + registerModesChangedHandler :: a -> String -> ModesChangedHandler -> IO Registration + + -- | Unregisters the modes-changed handler for a 'Registration' that was + -- returned from 'registerModesChangedHandler'. Returns true if such a + -- handler was found and removed. + unregisterModesChangedHandler :: a -> Registration -> IO Bool + + -- | Returns the owners of the currently registered 'ModesChangedHandler's. + registeredModesChangedHandlers :: a -> IO [String] + + -- | Returns the 'Window' for the game's 'MainWindow'. + getMainWindow :: a -> IO Window + + openBoard :: Maybe a -> Maybe FilePath -> Node -> IO a + + openNewBoard :: Maybe a -> Maybe (Int, Int) -> IO a + openNewBoard ui = openBoard ui Nothing . rootNode + + openFile :: Maybe a -> FilePath -> IO (Either String a) + openFile ui file = do + result <- parseFile file + case result of + -- TODO Don't only choose the first tree in the collection. + Right collection -> + fmap Right $ openBoard ui (Just file) $ head $ collectionTrees collection + Left err -> return $ Left err + + -- | Prompts with an open file dialog for a game to open, then opens the + -- selected game if the user picks one. + fileOpen :: a -> IO () + + -- | Saves the current game to a file. If the current game is not currently + -- tied to a file, then this will act identically to 'fileSaveAs'. Returns true + -- iff the game was saved. + fileSave :: a -> IO Bool + + -- | Presents a file save dialog for the user to specify a file to write the + -- current game to. If the user provides a filename, then the game is + -- written. If the user names an existing file, then another dialog confirms + -- overwriting the existing file. Returns true iff the user accepted the + -- dialog(s) and the game was saved. + fileSaveAs :: a -> IO Bool + + -- | Closes the game and all UI windows, etc. attached to the given controller. + -- If the game is dirty, then a dialog first prompts the user whether to save, + -- throw away changes, or abort the closing. + fileClose :: a -> IO Bool + + -- | Closes all open games and exits the program. If any games are dirty then + -- we check if the user wants to save them. If the user clicks cancel at any + -- point then shutdown is cancelled and no games are closed. + fileQuit :: a -> IO Bool + + -- | Presents the user with an about dialog that shows general information + -- about the application to the user (authorship, license, etc.). + helpAbout :: a -> IO () + + -- | Returns the path to the file that the UI is currently displaying, or + -- nothing if the UI is displaying an unsaved game. + getFilePath :: a -> IO (Maybe FilePath) + + -- | Returns the filename (base name, with no directories before it) that is + -- currently open in the UI, or if the UI is showing an unsaved game, then a + -- fallback "untitled" string. As this may not be a real filename, it should + -- be used for display purposes only, and not for actually writing to. + getFileName :: a -> IO String + getFileName ui = maybe untitledFileName takeFileName <$> getFilePath ui + + -- | Sets the path to the file that the UI is currently displaying. This + -- changes the value returned by 'getFilePath' but does not do any saving or + -- loading. + setFilePath :: a -> Maybe FilePath -> IO () + + -- | Registers a handler that will execute when the file path the UI is bound + -- to changes. + registerFilePathChangedHandler :: a + -> String + -- ^ The name of the caller, used to track + -- what components registered what handlers. + -> Bool + -- ^ If true, the handler will be called + -- immediately after registration. + -> FilePathChangedHandler + -> IO Registration + + -- | Unregisters the handler for a 'Registration' that was returned from + -- 'registerFilePathChangedHandler'. Returns true if such a handler was found + -- and removed. + unregisterFilePathChangedHandler :: a -> Registration -> IO Bool + + -- | Returns the owners of the currently registered 'FilePathChangedHandler's. + registeredFilePathChangedHandlers :: a -> IO [String] + + -- | Returns whether the UI is dirty, i.e. whether there are unsaved changes + -- to the current game. + getDirty :: a -> IO Bool + + -- | Sets the dirty state of the UI. + setDirty :: a -> Bool -> IO () + + -- | Registers a handler that will execute when the dirty state of the UI + -- changes. + registerDirtyChangedHandler :: a + -> String + -- ^ The name of the caller, used to track what + -- components registered what handlers. + -> Bool + -- ^ If true, the handler will be called + -- immediately after registration. + -> DirtyChangedHandler + -> IO Registration + + -- | Unregisters the handler for a 'Registration' that was returned from + -- 'registerDirtyChangedHandler'. Returns true if such a handler was found + -- and removed. + unregisterDirtyChangedHandler :: a -> Registration -> IO Bool + + -- | Returns the owners of the currently registered 'DirtyChangedHandler's. + registeredDirtyChangedHandlers :: a -> IO [String] + +-- | A key that refers to registration of a handler with a UI controller. Used +-- to unregister handlers. +type Registration = Unique + +-- | A handler for when the dirty state of the UI changes. Passed the new dirty +-- state. The old dirty state is the logical negation of the new state. +type DirtyChangedHandler = Bool -> IO () + +-- | A handler for taking action when the file path for the current game +-- changes. Passed the old path and the new path, in that order. +type FilePathChangedHandler = Maybe FilePath -> Maybe FilePath -> IO () + +-- | A handler for taking action when UI modes change. Passed the old modes and +-- the new modes, in that order. +type ModesChangedHandler = UiModes -> UiModes -> IO () + +modifyModesPure :: UiCtrl ui => ui -> (UiModes -> UiModes) -> IO () +modifyModesPure ui f = modifyModes ui (return . f) + +-- | Assigns to the current tool within the modes of 'ui' (firing any relevant +-- change handlers). +setTool :: UiCtrl ui => ui -> Tool -> IO () +setTool ui tool = modifyModesPure ui $ \modes -> modes { uiTool = tool } + +-- | A UI widget that listens to the state of a 'UiCtrl'. This class makes it +-- easy to register and unregister event handlers with 'viewRegister' and +-- 'viewUnregisterAll'. +class UiCtrl ui => UiView view ui | view -> ui where + -- | A printable name of the view; usually just the data type name. + viewName :: view -> String + + -- | A reference to the view's controller. + viewCtrl :: view -> ui + + -- | An updatable list of registrations for event handlers the view has + -- registered. + viewRegistrations :: view -> ViewRegistrations + +type ViewRegistrations = IORef [Registration] + +-- | Creates a new 'ViewRegistrations'. +viewNewRegistrations :: IO ViewRegistrations +viewNewRegistrations = newIORef [] + +-- | Registers a handler for an event on a view. +viewRegister :: UiView view ui => view -> Event UiGoM handler -> handler -> IO () +viewRegister view event handler = do + let ui = viewCtrl view + name = viewName view + registration <- register ui name event handler + modifyIORef (viewRegistrations view) (registration:) + +-- | Unregisters all event handlers that the view has registered in its +-- 'viewRegistrations'. +viewUnregisterAll :: UiView view ui => view -> IO () +viewUnregisterAll view = do + let ui = viewCtrl view + registrations = viewRegistrations view + readIORef registrations >>= mapM_ (unregister ui) + writeIORef registrations [] + +data UiModes = UiModes { uiViewMode :: ViewMode + , uiViewOneColorModeColor :: Color + , uiViewBlindModesAnnouncePlayer :: Bool + -- ^ If true, announce the player whose turn it is with + -- blindfolds off. If false, announce the player whose + -- turn it is with blindfolds on. + , uiHighlightCurrentMovesMode :: Bool + -- ^ Whether to draw an indicator on the game board for + -- moves on the current node. + , uiTool :: Tool + } deriving (Eq, Show) + +data ViewMode = ViewRegularMode + | ViewOneColorMode + | ViewNothingMode + deriving (Eq, Show) + +defaultUiModes :: UiModes +defaultUiModes = UiModes { uiViewMode = ViewRegularMode + , uiViewOneColorModeColor = Black + , uiViewBlindModesAnnouncePlayer = True + , uiHighlightCurrentMovesMode = False + , uiTool = ToolPlay + } + +-- | Selectable tools for operating on the board. +data Tool = ToolPlay -- ^ Game tool. + | ToolJump -- ^ Game tool. + | ToolScore -- ^ Game tool. + | ToolBlack -- ^ Editing tool. + | ToolWhite -- ^ Editing tool. + | ToolErase -- ^ Editing tool. + | ToolArrow -- ^ Markup tool. + | ToolMarkCircle -- ^ Markup tool. + | ToolLabel -- ^ Markup tool. + | ToolLine -- ^ Markup tool. + | ToolMarkX -- ^ Markup tool. + | ToolMarkSelected -- ^ Markup tool. + | ToolMarkSquare -- ^ Markup tool. + | ToolMarkTriangle -- ^ Markup tool. + | ToolVisible -- ^ Visibility tool. + | ToolDim -- ^ Visibility tool. + deriving (Bounded, Enum, Eq, Show) + +-- | The tool that should be selected when a board first opens in the UI. +initialTool :: Tool +initialTool = ToolPlay + +-- | The ordering and grouping of tools as they should appear in the UI. +toolOrdering :: [[Tool]] +toolOrdering = + [[ToolPlay, ToolJump, ToolScore], + [ToolBlack, ToolWhite, ToolErase], + [ToolArrow, ToolMarkCircle, ToolLabel, ToolLine, ToolMarkX, ToolMarkSelected, + ToolMarkSquare, ToolMarkTriangle], + [ToolVisible, ToolDim]] + +toolLabel :: Tool -> String +toolLabel tool = case tool of + ToolPlay -> "Play" + ToolJump -> "Jump to move" + ToolScore -> "Score" + ToolBlack -> "Paint black stones" + ToolWhite -> "Paint white stones" + ToolErase -> "Erase stones" + ToolArrow -> "Draw arrows" + ToolMarkCircle -> "Mark circles" + ToolLabel -> "Label points" + ToolLine -> "Draw lines" + ToolMarkX -> "Mark Xs" + ToolMarkSelected -> "Mark selected" + ToolMarkSquare -> "Mark squares" + ToolMarkTriangle -> "Mark triangles" + ToolVisible -> "Toggle points visible" + ToolDim -> "Toggle points dimmed" + +-- | Converts 'ToolBlack' and 'ToolWhite' into 'Color's. Does not accept any +-- other tools. +toolToColor :: Tool -> Color +toolToColor ToolBlack = Black +toolToColor ToolWhite = White +toolToColor other = error $ "toolToColor is invalid for " ++ show other ++ "." + +-- | Creates a list of 'FileFilter's that should be used in 'FileChooser's that +-- are working with SGF files. +fileFiltersForSgf :: IO [FileFilter] +fileFiltersForSgf = do + sgf <- fileFilterNew + fileFilterSetName sgf "SGF files (*.sgf)" + fileFilterAddPattern sgf "*.sgf" + all <- fileFilterNew + fileFilterSetName all "All files (*)" + fileFilterAddPattern all "*" + return [sgf, all] + +-- | The name to display in the UI for a game that has not yet been saved to +-- disk. +untitledFileName :: String +untitledFileName = "(Untitled)" diff --git a/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs b/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs @@ -0,0 +1,235 @@ +-- 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 panel that displays a vertical list of controls for editing a game's +-- 'GameInfo'. +module Game.Goatee.Ui.Gtk.GamePropertiesPanel ( + GamePropertiesPanel, + create, + destroy, + myWidget, + ) where + +import Control.Monad (forM_, void, when) +import Data.Maybe (fromMaybe) +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Monad hiding (on) +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Game.Goatee.Ui.Gtk.Common +import Game.Goatee.Ui.Gtk.Latch +import Game.Goatee.Ui.Gtk.Utils +import Graphics.UI.Gtk ( + Entry, + Packing (PackGrow, PackNatural), + PolicyType (PolicyAutomatic), + TextBuffer, TextView, + Widget, + WrapMode (WrapWord), + boxPackStart, + bufferChanged, + containerAdd, + entryNew, entrySetText, + get, + hSeparatorNew, + labelNewWithMnemonic, labelSetMnemonicWidget, + on, + scrolledWindowNew, + scrolledWindowSetPolicy, + tableAttachDefaults, tableNew, tableSetRowSpacing, + textBufferSetText, textBufferText, + textViewGetBuffer, textViewNew, textViewSetWrapMode, + toWidget, + vBoxNew, + ) + +data GamePropertiesPanel ui = + GamePropertiesPanel { myUi :: ui + , myRegistrations :: ViewRegistrations + , myWidget :: Widget + , myBlackName :: Entry + , myBlackRank :: Entry + , myBlackTeam :: Entry + , myWhiteName :: Entry + , myWhiteRank :: Entry + , myWhiteTeam :: Entry + , myComment :: TextView + , myCommentLatch :: Latch + -- ^ When a 'TextBuffer' is programatically assigned to, + -- two change events are fired, one to delete the old + -- text and one to insert the new text. We don't want + -- to handle the intermediate value by writing it back + -- to the model because this triggers dirtyness. So we + -- hold this latch on while we are doing a model-to-view + -- update in order to avoid this problem. + } + +instance UiCtrl ui => UiView (GamePropertiesPanel ui) ui where + viewName = const "GamePropertiesPanel" + viewCtrl = myUi + viewRegistrations = myRegistrations + +create :: UiCtrl ui => ui -> IO (GamePropertiesPanel ui) +create ui = do + let rows = 8 + cols = 2 + box <- vBoxNew False 0 + table <- tableNew rows cols False + boxPackStart box table PackNatural 0 + + let addSeparator row = do sep <- hSeparatorNew + tableAttachDefaults table sep 0 cols row (row + 1) + tableSetRowSpacing table (row - 1) 6 + tableSetRowSpacing table row 6 + + let blackRow = 0 + blackNameLabel <- labelNewWithMnemonic "_Black" + blackNameEntry <- entryNew + labelSetMnemonicWidget blackNameLabel blackNameEntry + tableAttachDefaults table blackNameLabel 0 1 blackRow (blackRow + 1) + tableAttachDefaults table blackNameEntry 1 2 blackRow (blackRow + 1) + + blackRankLabel <- labelNewWithMnemonic "_Rank" + blackRankEntry <- entryNew + labelSetMnemonicWidget blackRankLabel blackRankEntry + tableAttachDefaults table blackRankLabel 0 1 (blackRow + 1) (blackRow + 2) + tableAttachDefaults table blackRankEntry 1 2 (blackRow + 1) (blackRow + 2) + + blackTeamLabel <- labelNewWithMnemonic "T_eam" + blackTeamEntry <- entryNew + labelSetMnemonicWidget blackTeamLabel blackTeamEntry + tableAttachDefaults table blackTeamLabel 0 1 (blackRow + 2) (blackRow + 3) + tableAttachDefaults table blackTeamEntry 1 2 (blackRow + 2) (blackRow + 3) + + addSeparator 3 + + let whiteRow = 4 + whiteNameLabel <- labelNewWithMnemonic "_White" + whiteNameEntry <- entryNew + labelSetMnemonicWidget whiteNameLabel whiteNameEntry + tableAttachDefaults table whiteNameLabel 0 1 whiteRow (whiteRow + 1) + tableAttachDefaults table whiteNameEntry 1 2 whiteRow (whiteRow + 1) + + whiteRankLabel <- labelNewWithMnemonic "Ran_k" + whiteRankEntry <- entryNew + labelSetMnemonicWidget whiteRankLabel whiteRankEntry + tableAttachDefaults table whiteRankLabel 0 1 (whiteRow + 1) (whiteRow + 2) + tableAttachDefaults table whiteRankEntry 1 2 (whiteRow + 1) (whiteRow + 2) + + whiteTeamLabel <- labelNewWithMnemonic "Te_am" + whiteTeamEntry <- entryNew + labelSetMnemonicWidget whiteTeamLabel whiteTeamEntry + tableAttachDefaults table whiteTeamLabel 0 1 (whiteRow + 2) (whiteRow + 3) + tableAttachDefaults table whiteTeamEntry 1 2 (whiteRow + 2) (whiteRow + 3) + + addSeparator 7 + + comment <- textViewNew + commentLatch <- newLatch + textViewSetWrapMode comment WrapWord + commentScroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic + containerAdd commentScroll comment + boxPackStart box commentScroll PackGrow 0 + + registrations <- viewNewRegistrations + + let me = GamePropertiesPanel { myUi = ui + , myRegistrations = registrations + , myWidget = toWidget box + , myBlackName = blackNameEntry + , myBlackRank = blackRankEntry + , myBlackTeam = blackTeamEntry + , myWhiteName = whiteNameEntry + , myWhiteRank = whiteRankEntry + , myWhiteTeam = whiteTeamEntry + , myComment = comment + , myCommentLatch = commentLatch + } + + initialize me + return me + +initialize :: UiCtrl ui => GamePropertiesPanel ui -> IO () +initialize me = do + let ui = myUi me + + -- Watch for game info changes. + viewRegister me gameInfoChangedEvent $ \_ newInfo -> + afterGo $ updateUiGameInfo me newInfo + + -- Watch for node changes. + let onNodeChange = do cursor <- getCursor + afterGo $ updateUiNodeInfo me cursor + viewRegister me navigationEvent $ const onNodeChange + viewRegister me propertiesModifiedEvent $ const $ const onNodeChange + + updateUi me =<< readCursor ui + + commentBuffer <- textViewGetBuffer $ myComment me + on commentBuffer bufferChanged $ handleCommentBufferChanged me commentBuffer + + connectEntryToGameInfo ui myBlackName $ \x info -> info { gameInfoBlackName = strToMaybe x } + connectEntryToGameInfo ui myBlackRank $ \x info -> info { gameInfoBlackRank = strToMaybe x } + connectEntryToGameInfo ui myBlackTeam $ \x info -> info { gameInfoBlackTeamName = strToMaybe x } + connectEntryToGameInfo ui myWhiteName $ \x info -> info { gameInfoWhiteName = strToMaybe x } + connectEntryToGameInfo ui myWhiteRank $ \x info -> info { gameInfoWhiteRank = strToMaybe x } + connectEntryToGameInfo ui myWhiteTeam $ \x info -> info { gameInfoWhiteTeamName = strToMaybe x } + + where connectEntryToGameInfo ui entryAccessor updater = + onEntryChange (entryAccessor me) $ \value -> + runUiGo ui $ void $ modifyGameInfo (updater value) + strToMaybe str = if null str then Nothing else Just str + +destroy :: UiCtrl ui => GamePropertiesPanel ui -> IO () +destroy = viewUnregisterAll + +handleCommentBufferChanged :: UiCtrl ui => GamePropertiesPanel ui -> TextBuffer -> IO () +handleCommentBufferChanged me commentBuffer = + -- Don't push the new comment value back to the model if we're already + -- updating the view from the model. + whenLatchOff (myCommentLatch me) $ do + newComment <- get commentBuffer textBufferText + runUiGo (myUi me) $ modifyPropertyString propertyC $ const newComment + +updateUi :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO () +updateUi me cursor = do + updateUiGameInfo me $ boardGameInfo $ cursorBoard cursor + updateUiNodeInfo me cursor + +updateUiGameInfo :: GamePropertiesPanel ui -> GameInfo -> IO () +updateUiGameInfo me info = + forM_ [(gameInfoBlackName, myBlackName), + (gameInfoBlackRank, myBlackRank), + (gameInfoBlackTeamName, myBlackTeam), + (gameInfoWhiteName, myWhiteName), + (gameInfoWhiteRank, myWhiteRank), + (gameInfoWhiteTeamName, myWhiteTeam)] $ \(getter, entry) -> + entrySetText (entry me) $ fromMaybe "" $ getter info + +updateUiNodeInfo :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO () +updateUiNodeInfo me cursor = do + let newText = maybe "" fromText $ findPropertyValue propertyC $ cursorNode cursor + buf <- textViewGetBuffer $ myComment me + oldText <- get buf textBufferText + when (oldText /= newText) $ do + withLatchOn (myCommentLatch me) $ textBufferSetText buf newText + -- It's not necessary to call this handler, but we do for consistency, since + -- all other widgets currently behave this way (write back and forth until + -- synchronized). + handleCommentBufferChanged me buf diff --git a/src/Game/Goatee/Ui/Gtk/Goban.hs b/src/Game/Goatee/Ui/Gtk/Goban.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Goban.hs @@ -0,0 +1,699 @@ +-- 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 widget that renders an interactive Go board. +module Game.Goatee.Ui.Gtk.Goban ( + Goban, + create, + destroy, + myWidget, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (liftM, unless, when) +import qualified Data.Foldable as F +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromJust, isJust) +import Data.Tree (drawTree, unfoldTree) +import Game.Goatee.Common +import Game.Goatee.Sgf.Board hiding (isValidMove) +import Game.Goatee.Sgf.Monad ( + childAddedEvent, modifyMark, navigationEvent, propertiesModifiedEvent, + ) +import Game.Goatee.Sgf.Property +import Game.Goatee.Sgf.Tree +import Game.Goatee.Sgf.Types +import Game.Goatee.Ui.Gtk.Common +import Graphics.Rendering.Cairo ( + Antialias (AntialiasDefault, AntialiasNone), + Render, + arc, + closePath, + deviceToUser, + deviceToUserDistance, + fillPreserve, + liftIO, + lineTo, + moveTo, + paint, + paintWithAlpha, + popGroupToSource, + pushGroup, + rotate, + scale, + setAntialias, + setLineWidth, + setSourceRGB, + stroke, + translate, + ) +import Graphics.UI.Gtk ( + DrawingArea, + EventMask (ButtonPressMask, LeaveNotifyMask, PointerMotionMask), + Modifier (Shift), + Widget, + buttonPressEvent, + drawingAreaNew, + eventCoordinates, eventKeyName, eventModifier, + exposeEvent, + keyPressEvent, + leaveNotifyEvent, + motionNotifyEvent, + on, + renderWithDrawable, + toWidget, + widgetAddEvents, widgetGetDrawWindow, widgetGetSize, widgetGrabFocus, widgetQueueDraw, + widgetSetCanFocus, + ) + +{-# ANN module "HLint: ignore Use camelCase" #-} + +-- | If false, then the up and down keys will move toward and away +-- from the game tree root, and left and right will move between +-- siblings. If true, these are reversed. +useHorizontalKeyNavigation :: Bool +useHorizontalKeyNavigation = True + +-- Key handler code below requires that these keys don't use modifiers. +keyNavActions :: UiCtrl a => Map String (a -> IO Bool) +keyNavActions = + Map.fromList $ + if useHorizontalKeyNavigation + then [("Up", goLeft), + ("Down", goRight), + ("Left", goUp), + ("Right", flip goDown 0)] + else [("Up", goUp), + ("Down", flip goDown 0), + ("Left", goLeft), + ("Right", goRight)] + +boardBgColor :: Rgb +boardBgColor = rgb255 229 178 58 + +blackStoneColor :: Rgb +blackStoneColor = rgb 0 0 0 + +blackStoneBorderColor :: Rgb +blackStoneBorderColor = rgb 1 1 1 + +whiteStoneColor :: Rgb +whiteStoneColor = rgb 1 1 1 + +whiteStoneBorderColor :: Rgb +whiteStoneBorderColor = rgb 0 0 0 + +stoneColor :: Color -> Rgb +stoneColor color = case color of + Black -> blackStoneColor + White -> whiteStoneColor + +stoneBorderColor :: Color -> Rgb +stoneBorderColor color = case color of + Black -> blackStoneBorderColor + White -> whiteStoneBorderColor + +-- | Percentage of coordinate size, in @[0, 1]@. +stoneBorderThickness :: Double +stoneBorderThickness = 0.03 + +-- | The radius of small circles that are overlaid on points to indicate that +-- move variations exist. Percentage of coordinate size, in @[0, 1]@. +stoneVariationRadius :: Double +stoneVariationRadius = 0.15 + +-- | The width of the border of a variation circle. Percentage of coordinate +-- size, in @[0, 1]@. +stoneVariationBorderThickness :: Double +stoneVariationBorderThickness = 0.02 + +-- | The opacity, in @[0, 1]@, of a stone that should be drawn dimmed because of +-- 'DD'. +dimmedPointOpacity :: Double +dimmedPointOpacity = 0.3 + +-- | Returns the color that should be used to draw a 'Mark' on either an empty +-- point, or one with a stone of the given color. +coordAnnotationStrokeColor :: Maybe Color -> Rgb +coordAnnotationStrokeColor = maybe blackStoneColor stoneBorderColor + +-- | For line and arrow annotations, the width of the line. 1 is the width of a +-- stone. +boardAnnotationLineWidth :: Double +boardAnnotationLineWidth = 0.08 + +-- | For arrow annotations, the distance to pull back along the length of a line +-- before extending at right angles to form the arrowhead. +boardAnnotationArrowPullback :: Double +boardAnnotationArrowPullback = 0.2 + +-- | For arrow annotations, the distance to extend away from the baseline in +-- either direction to form the arrowhead. +boardAnnotationArrowWidth :: Double +boardAnnotationArrowWidth = 0.1 + +-- | A GTK widget that renders a Go board. +-- +-- @ui@ should be an instance of 'UiCtrl'. +data Goban ui = Goban { myUi :: ui + , myRegistrations :: ViewRegistrations + , myWidget :: Widget + , myDrawingArea :: DrawingArea + , myModesChangedHandler :: IORef (Maybe Registration) + } + +instance UiCtrl ui => UiView (Goban ui) ui where + viewName = const "Goban" + viewCtrl = myUi + viewRegistrations = myRegistrations + +-- | Holds data relating to the state of the mouse hovering over the board. +data HoverState = HoverState { hoverCoord :: Maybe Coord + -- ^ The board coordinate corresponding to the + -- current mouse position. Nothing if the mouse + -- is not over the board. + , hoverIsValidMove :: Bool + -- ^ True iff the hovered point is legal to play + -- on for the current player. + } deriving (Show) + +-- | Augments a 'CoordState' with data that is only used for rendering purposes. +data RenderedCoord = RenderedCoord { + renderedCoordState :: CoordState + , renderedCoordCurrent :: Bool + , renderedCoordVariation :: Maybe Color + -- ^ If a variation move exists at this point, then this will be the color + -- of the move. + } deriving (Show) + +-- | Creates a 'Goban' for rendering Go boards of the given size. +create :: UiCtrl ui => ui -> IO (Goban ui) +create ui = do + hoverStateRef <- newIORef HoverState { hoverCoord = Nothing + , hoverIsValidMove = False + } + + drawingArea <- drawingAreaNew + widgetSetCanFocus drawingArea True + widgetAddEvents drawingArea [LeaveNotifyMask, + ButtonPressMask, + PointerMotionMask] + + on drawingArea exposeEvent $ liftIO $ do + drawBoard ui hoverStateRef drawingArea + return True + + on drawingArea motionNotifyEvent $ do + mouseCoord <- fmap Just eventCoordinates + liftIO $ handleMouseMove ui hoverStateRef drawingArea mouseCoord + return True + + on drawingArea leaveNotifyEvent $ do + liftIO $ handleMouseMove ui hoverStateRef drawingArea Nothing + return True + + on drawingArea buttonPressEvent $ do + liftIO $ widgetGrabFocus drawingArea + mouseXy <- eventCoordinates + liftIO $ doToolAtPoint ui drawingArea mouseXy + return True + + on drawingArea keyPressEvent $ do + key <- eventKeyName + mods <- eventModifier + let km = (key, mods) + let maybeAction = Map.lookup key keyNavActions + cond (return False) + [(null mods && isJust maybeAction, + liftIO $ fromJust maybeAction ui >> return True), + + -- Write a list of the current node's properties to the console. + (km == ("t", []), liftIO $ do + cursor <- readCursor ui + print $ nodeProperties $ cursorNode cursor + return True), + + -- Draw a tree rooted at the current node to the console. + (km == ("T", [Shift]), liftIO $ do + cursor <- readCursor ui + putStrLn $ drawTree $ flip unfoldTree (cursorNode cursor) $ \node -> + (show $ nodeProperties node, nodeChildren node) + return True)] + + registrations <- viewNewRegistrations + modesChangedHandler <- newIORef Nothing + + let me = Goban { myUi = ui + , myRegistrations = registrations + , myWidget = toWidget drawingArea + , myDrawingArea = drawingArea + , myModesChangedHandler = modesChangedHandler + } + + initialize me + return me + +initialize :: UiCtrl ui => Goban ui -> IO () +initialize me = do + let ui = myUi me + onChange = afterGo $ update me + viewRegister me childAddedEvent $ const $ const onChange + viewRegister me navigationEvent $ const onChange + viewRegister me propertiesModifiedEvent $ const $ const onChange + writeIORef (myModesChangedHandler me) =<< + liftM Just (registerModesChangedHandler ui "Goban" $ \_ _ -> update me) + -- TODO Need to update the hover state's validity on cursor and tool (mode?) + -- changes. + update me + +destroy :: UiCtrl ui => Goban ui -> IO () +destroy me = do + let ui = myUi me + viewUnregisterAll me + F.mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me) + +update :: UiCtrl ui => Goban ui -> IO () +update = widgetQueueDraw . myDrawingArea + +-- | Called when the mouse is moved. Updates the 'HoverState' according to the +-- new mouse location, and redraws the board if necessary. +handleMouseMove :: UiCtrl a + => a + -> IORef HoverState + -> DrawingArea + -> Maybe (Double, Double) + -> IO () +handleMouseMove ui hoverStateRef drawingArea maybeClickCoord = do + maybeXy <- case maybeClickCoord of + Nothing -> return Nothing + Just (mouseX, mouseY) -> do + board <- fmap cursorBoard (readCursor ui) + gtkToBoardCoordinates board drawingArea mouseX mouseY + updateHoverPosition ui hoverStateRef maybeXy >>= flip when + (widgetQueueDraw drawingArea) + +-- | Applies the current tool at the given GTK coordinate, if such an action is +-- valid. +doToolAtPoint :: UiCtrl ui => ui -> DrawingArea -> (Double, Double) -> IO () +doToolAtPoint ui drawingArea (mouseX, mouseY) = do + cursor <- readCursor ui + let board = cursorBoard cursor + maybeXy <- gtkToBoardCoordinates board drawingArea mouseX mouseY + whenMaybe maybeXy $ \xy -> do + tool <- fmap uiTool (readModes ui) + + case tool of + ToolMarkCircle -> toggleMark ui xy MarkCircle + ToolMarkSelected -> toggleMark ui xy MarkSelected + ToolMarkSquare -> toggleMark ui xy MarkSquare + ToolMarkTriangle -> toggleMark ui xy MarkTriangle + ToolMarkX -> toggleMark ui xy MarkX + ToolPlay -> do + valid <- isValidMove ui xy + when valid $ playAt ui xy + _ -> return () -- TODO Support other tools. + where toggleMark ui xy mark = runUiGo ui $ modifyMark (toggleMark' mark) xy + toggleMark' mark maybeExistingMark = case maybeExistingMark of + Just existingMark | existingMark == mark -> Nothing + _ -> Just mark + +-- | Updates the hover state for the mouse having moved to the given board +-- coordinate. Returns true if the board coordinate has changed. +updateHoverPosition :: UiCtrl ui => ui -> IORef HoverState -> Maybe Coord -> IO Bool +updateHoverPosition ui hoverStateRef maybeXy = do + hoverState <- readIORef hoverStateRef + if maybeXy == hoverCoord hoverState + then return False + else do valid <- case maybeXy of + Nothing -> return False + Just xy -> isValidMove ui xy + writeIORef hoverStateRef HoverState { hoverCoord = maybeXy + , hoverIsValidMove = valid + } + return True + +applyBoardCoordinates :: BoardState -> DrawingArea -> IO (Render ()) +applyBoardCoordinates board drawingArea = do + (canvasWidth, canvasHeight) <- return . mapTuple fromIntegral =<< widgetGetSize drawingArea + + let maxStoneWidth = canvasWidth / fromIntegral (boardWidth board) + maxStoneHeight = canvasHeight / fromIntegral (boardHeight board) + maxStoneLength = min maxStoneWidth maxStoneHeight + + return $ do + -- Set user coordinates so that the top-left stone occupies the rectangle + -- from (0,0) to (1,1). + when (canvasWidth > canvasHeight) $ translate ((canvasWidth - canvasHeight) / 2) 0 + when (canvasHeight > canvasWidth) $ translate 0 ((canvasHeight - canvasWidth) / 2) + scale maxStoneLength maxStoneLength + +-- | Takes a GTK coordinate and, using a Cairo rendering context, returns the +-- corresponding board coordinate, or @Nothing@ if the GTK coordinate is not +-- over the board. +gtkToBoardCoordinates :: BoardState -> DrawingArea -> Double -> Double -> IO (Maybe (Int, Int)) +gtkToBoardCoordinates board drawingArea x y = do + drawWindow <- widgetGetDrawWindow drawingArea + changeCoords <- applyBoardCoordinates board drawingArea + result@(bx, by) <- fmap (mapTuple floor) $ + renderWithDrawable drawWindow $ + changeCoords >> deviceToUser x y + return $ if bx < 0 || bx >= boardWidth board || + by < 0 || by >= boardHeight board + then Nothing + else Just result + +-- | Fully redraws the board based on the current controller and UI state. +drawBoard :: UiCtrl ui => ui -> IORef HoverState -> DrawingArea -> IO () +drawBoard ui hoverStateRef drawingArea = do + cursor <- readCursor ui + modes <- readModes ui + hoverState <- readIORef hoverStateRef + + let board = cursorBoard cursor + tool = uiTool modes + variationMode = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $ cursorBoard cursor + + variations :: [(Coord, Color)] + variations = if variationModeBoardMarkup variationMode + then cursorVariations (variationModeSource variationMode) cursor + else [] + + -- Positions of stones that have been played at the current node. + current :: [Coord] + current = if uiHighlightCurrentMovesMode modes + then concatMap (\prop -> case prop of + B (Just xy) -> [xy] + W (Just xy) -> [xy] + _ -> []) $ + cursorProperties cursor + else [] + + -- The state of the board's points, with all data for rendering. + renderedCoords :: [[RenderedCoord]] + renderedCoords = + -- Add current moves. + (flip .) + foldr (\(x, y) grid -> + listUpdate (flip listUpdate x $ + \renderedCoord -> renderedCoord { renderedCoordCurrent = True }) + y + grid) + current $ + -- Add variations. + foldr (\((x, y), color) grid -> + listUpdate (flip listUpdate x $ + \renderedCoord -> renderedCoord { renderedCoordVariation = Just color }) + y + grid) + (map (map $ \state -> RenderedCoord state False Nothing) $ + mapBoardCoords maybeAddHover board) + variations + + maybeAddHover :: Int -> Int -> CoordState -> CoordState + maybeAddHover y x state = case hoverCoord hoverState of + Just (hx, hy) | x == hx && y == hy -> + modifyCoordForHover tool board hoverState state + _ -> state + + drawWindow <- widgetGetDrawWindow drawingArea + changeCoords <- applyBoardCoordinates board drawingArea + renderWithDrawable drawWindow $ do + changeCoords + + -- Fill the background a nice woody shade. + setRgb boardBgColor + paint + + -- Draw the grid and all points. + gridLineWidth <- fst <$> deviceToUserDistance 1 0 + + let drawCoord' = drawCoord board gridLineWidth (gridLineWidth * 2) + + -- First draw points that are visible and not dimmed. + forIndexM_ renderedCoords $ \y row -> + forIndexM_ row $ \x renderedCoord -> do + let coord = renderedCoordState renderedCoord + when (coordVisible coord && not (coordDimmed coord)) $ + drawCoord' x y renderedCoord + + -- Then draw visible but dimmed points. This is performed under a single + -- Cairo group for performance reasons. (Having a group for each dimmed + -- point is *really* slow with a board full of dimmed points.) + pushGroup + forIndexM_ renderedCoords $ \y row -> + forIndexM_ row $ \x renderedCoord -> do + let coord = renderedCoordState renderedCoord + when (coordVisible coord && coordDimmed coord) $ + drawCoord' x y renderedCoord + popGroupToSource + paintWithAlpha dimmedPointOpacity + + -- Draw non-CoordState-based annotations. + unless (null (boardLines board) && null (boardArrows board)) $ do + setSourceRGB 0 0 0 + setLineWidth boardAnnotationLineWidth + mapM_ (uncurry drawLine) $ boardLines board + mapM_ (uncurry drawArrow) $ boardArrows board + return () + +-- | Draws a single point on the board. +drawCoord :: BoardState + -- ^ The board being drawn. + -> Double + -- ^ The pixel width of the grid in the board's interior. + -> Double + -- ^ The pixel width of the grid on the board's border. + -> Int + -- ^ The x-index of the point to be drawn. + -> Int + -- ^ The y-index of the point to be drawn. + -> RenderedCoord + -- ^ The point to be drawn. + -> Render () +drawCoord board gridWidth gridBorderWidth x y renderedCoord = do + let x' = fromIntegral x + y' = fromIntegral y + coord = renderedCoordState renderedCoord + current = renderedCoordCurrent renderedCoord + variation = renderedCoordVariation renderedCoord + -- Translate the grid so that we can draw the stone from (0,0) to (1,1). + translate x' y' + -- Draw the grid, stone (if present), and mark (if present). + drawGrid board gridWidth gridBorderWidth x y + F.mapM_ drawStone $ coordStone coord + maybe (return ()) (drawMark $ coordStone coord) $ coordMark coord + case (current, variation) of + -- With @VariationMode ShowChildVariations True@, this is the case of an + -- immediately recaptured ko. With @ShowCurrentVariations@ and a valid SGF + -- this case shouldn't happen. + (True, Just variation') -> do drawCurrent True + drawVariation variation' True + (True, _) -> drawCurrent False + (_, Just variation') -> drawVariation variation' False + _ -> return () + -- Restore the coordinate system for the next stone. + translate (-x') (-y') + +-- | Given a current tool, board, and hover, modifies a 'CoordState' to reflect +-- that the user is hovering over the point. The effect depends on the tool. +-- The effect is to suggest what would happen if the point were clicked. +modifyCoordForHover :: Tool -> BoardState -> HoverState -> CoordState -> CoordState +modifyCoordForHover tool board hover coord = case tool of + ToolPlay -> if hoverIsValidMove hover + then coord { coordStone = Just (boardPlayerTurn board) } + else coord + ToolJump -> coord -- TODO Hover for ToolJump. + ToolScore -> coord -- TODO Hover for ToolScore. + ToolBlack -> coord { coordStone = Just (toolToColor tool) } + ToolWhite -> coord { coordStone = Just (toolToColor tool) } + ToolErase -> coord { coordStone = Nothing } + ToolArrow -> coord -- TODO Hover for ToolArrow. + ToolMarkCircle -> toggleMark MarkCircle coord + ToolLabel -> coord -- TODO Hover for ToolLabel. + ToolLine -> coord -- TODO Hover for ToolLine. + ToolMarkX -> toggleMark MarkX coord + ToolMarkSelected -> toggleMark MarkSelected coord + ToolMarkSquare -> toggleMark MarkSquare coord + ToolMarkTriangle -> toggleMark MarkTriangle coord + ToolVisible -> coord { coordVisible = not $ coordVisible coord } + ToolDim -> coord { coordDimmed = not $ coordDimmed coord } + +-- | Toggles a specific mark on a 'CoordState'. If the @CoordState@ already has +-- that mark, then it is removed. If the @CoordState@ has no mark or has +-- another mark, then the given mark is added to the @CoordState@, overwriting +-- an existing mark if there is one. +toggleMark :: Mark -> CoordState -> CoordState +toggleMark mark coord = let justMark = Just mark + in if coordMark coord == justMark + then coord { coordMark = Nothing } + else coord { coordMark = justMark } + +-- | Draws the gridlines for a single point on the board. +drawGrid :: BoardState -> Double -> Double -> Int -> Int -> Render () +drawGrid board gridWidth gridBorderWidth x y = do + -- Draw the grid. + let atLeft = x == 0 + atTop = y == 0 + atRight = x == boardWidth board - 1 + atBottom = y == boardHeight board - 1 + gridX0 = if atLeft then 0.5 else 0 + gridY0 = if atTop then 0.5 else 0 + gridX1 = if atRight then 0.5 else 1 + gridY1 = if atBottom then 0.5 else 1 + -- Temporarily disable antialiasing. We want grid lines to be sharp. + setAntialias AntialiasNone + setSourceRGB 0 0 0 + setLineWidth $ if atTop || atBottom then gridBorderWidth else gridWidth + moveTo gridX0 0.5 + lineTo gridX1 0.5 + stroke + setLineWidth $ if atLeft || atRight then gridBorderWidth else gridWidth + moveTo 0.5 gridY0 + lineTo 0.5 gridY1 + stroke + setAntialias AntialiasDefault + +-- | Draws a stone from @(0, 0)@ to @(1, 1)@ in user coordinates. +drawStone :: Color -> Render () +drawStone color = do + arc 0.5 0.5 (0.5 - stoneBorderThickness / 2) 0 pi_2 + setRgb $ stoneColor color + fillPreserve + setLineWidth stoneBorderThickness + setRgb $ stoneBorderColor color + stroke + +-- | Draws the given mark on the current point. The color should be that of the +-- stone on the point, if there is one; it determines the color of the mark. +drawMark :: Maybe Color -> Mark -> Render () +drawMark stone mark = do + case mark of + MarkCircle -> arc 0.5 0.5 0.25 0 pi_2 + MarkTriangle -> do moveTo trianglePoint1X trianglePoint1Y + lineTo trianglePoint2X trianglePoint2Y + lineTo trianglePoint3X trianglePoint3Y + closePath + MarkSquare -> do moveTo 0.25 0.25 + lineTo 0.25 0.75 + lineTo 0.75 0.75 + lineTo 0.75 0.25 + closePath + MarkX -> do moveTo 0.25 0.25 + lineTo 0.75 0.75 + moveTo 0.25 0.75 + lineTo 0.75 0.25 + MarkSelected -> do moveTo 0.2 0.5 + lineTo 0.5 0.8 + lineTo 0.8 0.5 + lineTo 0.5 0.2 + closePath + setRgb $ coordAnnotationStrokeColor stone + setLineWidth 0.1 + stroke + +-- The coordinates for inscribing a triangle within a unit circle centered about +-- @(0.5, 0.5)@, with radius @triangleRadius@. +triangleRadius, trianglePoint1X, trianglePoint1Y, trianglePoint2X, trianglePoint2Y :: Double +trianglePoint3X, trianglePoint3Y :: Double +triangleRadius = 0.3 +trianglePoint1X = 0.5 +trianglePoint1Y = 0.5 - triangleRadius +trianglePoint2X = 0.5 - triangleRadius * cos (pi / 6) +trianglePoint2Y = 0.5 + triangleRadius * 0.5 {-sin (pi / 6)-} +trianglePoint3X = 0.5 + triangleRadius * cos (pi / 6) +trianglePoint3Y = 0.5 + triangleRadius * 0.5 {-sin (pi / 6)-} + +-- | Draws a line between the given board points. Expects the context to be +-- already set up to draw. +drawLine :: Coord -> Coord -> Render () +drawLine (fromIntegral -> x0, fromIntegral -> y0) + (fromIntegral -> x1, fromIntegral -> y1) = do + moveTo (x0 + 0.5) (y0 + 0.5) + lineTo (x1 + 0.5) (y1 + 0.5) + stroke + +-- | Draws an arrow from the first point to the second point. Expects the +-- context to be already set up to draw. +drawArrow :: Coord -> Coord -> Render () +drawArrow (fromIntegral -> x0, fromIntegral -> y0) + (fromIntegral -> x1, fromIntegral -> y1) = do + let angle = atan ((y1 - y0) / (x1 - x0)) + if x0 <= x1 then 0 else pi + len = sqrt ((y1 - y0)**2 + (x1 - x0)**2) - boardAnnotationLineWidth + tx = x0 + 0.5 + ty = y0 + 0.5 + -- Set up user space so that we can draw the line from (0,0) to + -- (0,lineLength). + translate tx ty + rotate angle + moveTo 0 0 + lineTo len 0 + stroke + moveTo len 0 + lineTo (len - boardAnnotationArrowPullback) boardAnnotationArrowWidth + lineTo (len - boardAnnotationArrowPullback) (-boardAnnotationArrowWidth) + closePath + stroke + rotate (-angle) + translate (-tx) (-ty) + +-- | Draws a dot via 'drawSmallDot' to indicate that a variation is available +-- where the given player plays a stone here. The dot is of the given color. +-- If the boolean is true, then a semicircle is drawn that will not overlap with +-- a similar semicircle drawn by 'drawCurrent'. +drawVariation :: Color -> Bool -> Render () +drawVariation stone half = + let angle0 = if half then pi_1_75 else 0 + angle1 = if half then pi_0_75 else pi_2 + in drawSmallDot (stoneColor stone) (stoneBorderColor stone) angle0 angle1 + +-- | Draws a dot via 'drawSmallDot' to indicate that the current coordinate was +-- played on in the current node. If the boolean is true, then a semicircle is +-- drawn that will not overlap with a similar semicircle drawn by +-- 'drawVariation'. +drawCurrent :: Bool -> Render () +drawCurrent half = + let angle0 = if half then pi_0_75 else 0 + angle1 = if half then pi_1_75 else pi_2 + in drawSmallDot (0,0,1) (0,0,0) angle0 angle1 + +-- | Draws a small filled arc centered on the current coordinate being drawn. +drawSmallDot :: Rgb -> Rgb -> Double -> Double -> Render () +drawSmallDot fill border angle0 angle1 = do + arc 0.5 0.5 stoneVariationRadius angle0 angle1 + setRgb fill + fillPreserve + setLineWidth stoneVariationBorderThickness + setRgb border + stroke + +type Rgb = (Double, Double, Double) + +rgb :: Double -> Double -> Double -> Rgb +rgb = (,,) + +rgb255 :: Double -> Double -> Double -> Rgb +rgb255 r g b = (r / 255, g / 255, b / 255) + +setRgb :: Rgb -> Render () +setRgb (r, g, b) = setSourceRGB r g b + +pi_0_75, pi_1_75, pi_2 :: Floating a => a +pi_0_75 = pi * 0.75 +pi_1_75 = pi * 1.75 +pi_2 = pi * 2 diff --git a/src/Game/Goatee/Ui/Gtk/InfoLine.hs b/src/Game/Goatee/Ui/Gtk/InfoLine.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/InfoLine.hs @@ -0,0 +1,104 @@ +-- 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 text widget that displays information about the game, including some +-- overall information, as well as the current board position. +module Game.Goatee.Ui.Gtk.InfoLine ( + InfoLine, + create, + destroy, + myLabel, + ) where + +import Data.Maybe (fromMaybe) +import Game.Goatee.Sgf.Board +import Game.Goatee.Sgf.Monad +import Game.Goatee.Ui.Gtk.Common +import Graphics.UI.Gtk (Label, labelNew, labelSetMarkup) + +data InfoLine ui = InfoLine { myUi :: ui + , myRegistrations :: ViewRegistrations + , myLabel :: Label + } + +instance UiCtrl ui => UiView (InfoLine ui) ui where + viewName = const "InfoLine" + viewCtrl = myUi + viewRegistrations = myRegistrations + +create :: UiCtrl ui => ui -> IO (InfoLine ui) +create ui = do + label <- labelNew Nothing + registrations <- viewNewRegistrations + + let me = InfoLine { myUi = ui + , myRegistrations = registrations + , myLabel = label + } + + initialize me + return me + +initialize :: UiCtrl ui => InfoLine ui -> IO () +initialize me = do + let updateAfter = afterGo . updateWithCursor me =<< getCursor + viewRegister me childAddedEvent $ const $ const updateAfter + viewRegister me navigationEvent $ const updateAfter + viewRegister me propertiesModifiedEvent $ const $ const updateAfter + update me + +destroy :: UiCtrl ui => InfoLine ui -> IO () +destroy = viewUnregisterAll + +update :: UiCtrl ui => InfoLine ui -> IO () +update me = do + cursor <- readCursor $ myUi me + updateWithCursor me cursor + +updateWithCursor :: UiCtrl ui => InfoLine ui -> Cursor -> IO () +updateWithCursor me cursor = + labelSetMarkup (myLabel me) $ generateMarkup cursor + +generateMarkup :: Cursor -> String +generateMarkup cursor = + let board = cursorBoard cursor + gameInfoMsg = fromMaybe "" $ do + let info = boardGameInfo board + black <- gameInfoBlackName info + white <- gameInfoWhiteName info + let renderRank = maybe "" (\x -> " (" ++ x ++ ")") + blackRank = renderRank $ gameInfoBlackRank info + whiteRank = renderRank $ gameInfoWhiteRank info + return $ white ++ whiteRank ++ " vs. " ++ black ++ blackRank ++ "\n" + siblingMsg = case cursorParent cursor of + Nothing -> "Start of game." + Just parent -> + let parentChildCount = cursorChildCount parent + in if parentChildCount > 1 + then "Variation " ++ show (cursorChildIndex cursor + 1) ++ + "/" ++ show parentChildCount ++ "." + else "" + childrenMsg = let childCount = cursorChildCount cursor + in case childCount of + 0 -> "End of variation." + 1 -> "" + _ -> "" ++ show childCount ++ " variations from here." + in gameInfoMsg ++ "Move " ++ show (boardMoveNumber board) ++ ", " ++ + show (boardPlayerTurn board) ++ " to play. Captures: B+" ++ + show (boardBlackCaptures board) ++ ", W+" ++ show (boardWhiteCaptures board) + ++ ".\n" ++ siblingMsg ++ + (if siblingMsg /= [] && childrenMsg /= [] then " " else "") ++ childrenMsg diff --git a/src/Game/Goatee/Ui/Gtk/Latch.hs b/src/Game/Goatee/Ui/Gtk/Latch.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Latch.hs @@ -0,0 +1,70 @@ +-- 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.Ui.Gtk.Latch ( + Latch, + newLatch, + withLatchOn, + whenLatch, whenLatchOff, whenLatchOn, + ) where + +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) +import Control.Exception (finally) +import Control.Monad (when) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + +-- | A binary switch that is off unless held on during the execution of some IO +-- process. The state of a latch can be read at any time, but can be held on by +-- at most one thread at a time. +data Latch = Latch { latchValue :: IORef Bool + , latchLock :: MVar () + } + +-- | Creates a new latch that is off. +newLatch :: IO Latch +newLatch = do + value <- newIORef False + lock <- newMVar () + return Latch { latchValue = value + , latchLock = lock + } + +-- | Flips the latch on, executes the action, and finally flips the latch off +-- again (even if the action throws an exception). A latch may be held on by at +-- most one thread at a time. If a second thread tries to turn the latch on, it +-- will block. +withLatchOn :: Latch -> IO a -> IO a +withLatchOn (Latch value lock) io = do + takeMVar lock + finally (writeIORef value True >> io) $ do + writeIORef value False + putMVar lock () + +-- | Executes an action only when the latch is on (if given true) or off (if +-- given false). +whenLatch :: Bool -> Latch -> IO () -> IO () +whenLatch value latch io = do + actual <- readIORef $ latchValue latch + when (value == actual) io + +-- | Executes an action only when a latch is off. +whenLatchOff :: Latch -> IO () -> IO () +whenLatchOff = whenLatch False + +-- | Executes an action only when a latch is on. +whenLatchOn :: Latch -> IO () -> IO () +whenLatchOn = whenLatch True diff --git a/src/Game/Goatee/Ui/Gtk/MainWindow.hs b/src/Game/Goatee/Ui/Gtk/MainWindow.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/MainWindow.hs @@ -0,0 +1,267 @@ +-- 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 . + +-- | Implementation of the main window that contains the game board. +module Game.Goatee.Ui.Gtk.MainWindow ( + MainWindow, + create, + destroy, + display, + myWindow, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_, liftM, unless) +import Control.Monad.Trans (liftIO) +import qualified Data.Foldable as F +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Game.Goatee.Ui.Gtk.Common +import qualified Game.Goatee.Ui.Gtk.Actions as Actions +import Game.Goatee.Ui.Gtk.Actions (Actions) +import qualified Game.Goatee.Ui.Gtk.GamePropertiesPanel as GamePropertiesPanel +import Game.Goatee.Ui.Gtk.GamePropertiesPanel (GamePropertiesPanel) +import qualified Game.Goatee.Ui.Gtk.Goban as Goban +import Game.Goatee.Ui.Gtk.Goban (Goban) +import qualified Game.Goatee.Ui.Gtk.InfoLine as InfoLine +import Game.Goatee.Ui.Gtk.InfoLine (InfoLine) +import Graphics.UI.Gtk ( + Action, + Menu, + Packing (PackGrow, PackNatural), + Window, + actionCreateMenuItem, actionCreateToolItem, actionGroupGetAction, + boxPackStart, + containerAdd, + deleteEvent, + hPanedNew, + menuBarNew, menuItemNewWithMnemonic, menuItemSetSubmenu, menuNew, menuShellAppend, + notebookAppendPage, notebookNew, + on, + panedAdd1, panedAdd2, panedSetPosition, + separatorMenuItemNew, separatorToolItemNew, + toolbarNew, + vBoxNew, + widgetDestroy, widgetGrabFocus, widgetShowAll, + windowNew, windowSetDefaultSize, windowSetTitle, + ) +import System.IO (hPutStrLn, stderr) + +data MainWindow ui = MainWindow { myUi :: ui + , myWindow :: Window + , myActions :: Actions ui + , myGamePropertiesPanel :: GamePropertiesPanel ui + , myGoban :: Goban ui + , myInfoLine :: InfoLine ui + , myDirtyChangedHandler :: IORef (Maybe Registration) + , myFilePathChangedHandler :: IORef (Maybe Registration) + } + +create :: UiCtrl ui => ui -> IO (MainWindow ui) +create ui = do + window <- windowNew + windowSetDefaultSize window 640 480 + + actions <- Actions.create ui + + boardBox <- vBoxNew False 0 + containerAdd window boardBox + + menuBar <- menuBarNew + boxPackStart boardBox menuBar PackNatural 0 + + menuFile <- menuItemNewWithMnemonic "_File" + menuFileMenu <- menuNew + menuShellAppend menuBar menuFile + menuItemSetSubmenu menuFile menuFileMenu + + menuFileNew <- menuItemNewWithMnemonic "_New file" + menuFileNewMenu <- menuNew + menuItemSetSubmenu menuFileNew menuFileNewMenu + addActionsToMenu menuFileNewMenu actions + [ Actions.myFileNew9Action + , Actions.myFileNew13Action + , Actions.myFileNew19Action + , Actions.myFileNewCustomAction + ] + + containerAdd menuFileMenu menuFileNew + addActionsToMenu menuFileMenu actions + [ Actions.myFileOpenAction + , Actions.myFileSaveAction + , Actions.myFileSaveAsAction + ] + containerAdd menuFileMenu =<< separatorMenuItemNew + addActionsToMenu menuFileMenu actions + [ Actions.myFileCloseAction + , Actions.myFileQuitAction + ] + + menuTool <- menuItemNewWithMnemonic "_Tool" + menuToolMenu <- menuNew + menuShellAppend menuBar menuTool + menuItemSetSubmenu menuTool menuToolMenu + + toolbar <- toolbarNew + boxPackStart boardBox toolbar PackNatural 0 + + sequence_ $ + intersperse (do menuSep <- separatorMenuItemNew + toolSep <- separatorToolItemNew + containerAdd menuToolMenu menuSep + containerAdd toolbar toolSep) $ + flip map toolOrdering $ \toolGroup -> + forM_ toolGroup $ \tool -> do + action <- fromMaybe (error $ "Tool has no action: " ++ show tool) <$> + actionGroupGetAction (Actions.myToolActions actions) (show tool) + menuItem <- actionCreateMenuItem action + toolItem <- actionCreateToolItem action + containerAdd menuToolMenu menuItem + containerAdd toolbar toolItem + + menuView <- menuItemNewWithMnemonic "_View" + menuViewMenu <- menuNew + menuShellAppend menuBar menuView + menuItemSetSubmenu menuView menuViewMenu + + menuViewVariations <- menuItemNewWithMnemonic "_Variations" + menuViewVariationsMenu <- menuNew + containerAdd menuViewMenu menuViewVariations + menuItemSetSubmenu menuViewVariations menuViewVariationsMenu + + containerAdd menuViewVariationsMenu =<< + actionCreateMenuItem (Actions.myViewVariationsChildAction actions) + containerAdd menuViewVariationsMenu =<< + actionCreateMenuItem (Actions.myViewVariationsCurrentAction actions) + containerAdd menuViewVariationsMenu =<< separatorMenuItemNew + containerAdd menuViewVariationsMenu =<< + actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOnAction actions) + containerAdd menuViewVariationsMenu =<< + actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOffAction actions) + + containerAdd menuViewMenu =<< + actionCreateMenuItem (Actions.myViewHighlightCurrentMovesAction actions) + + menuHelp <- menuItemNewWithMnemonic "_Help" + menuHelpMenu <- menuNew + menuShellAppend menuBar menuHelp + menuItemSetSubmenu menuHelp menuHelpMenu + addActionsToMenu menuHelpMenu actions [Actions.myHelpAboutAction] + + infoLine <- InfoLine.create ui + boxPackStart boardBox (InfoLine.myLabel infoLine) PackNatural 0 + + hPaned <- hPanedNew + boxPackStart boardBox hPaned PackGrow 0 + + --hPanedMin <- get hPaned panedMinPosition + --hPanedMax <- get hPaned panedMaxPosition + --putStrLn $ "Paned position in [" ++ show hPanedMin ++ ", " ++ show hPanedMax ++ "]." + -- TODO Don't hard-code the pane width. + panedSetPosition hPaned 400 -- (truncate (fromIntegral hPanedMax * 0.8)) + + goban <- Goban.create ui + panedAdd1 hPaned $ Goban.myWidget goban + + controlsBook <- notebookNew + panedAdd2 hPaned controlsBook + + gamePropertiesPanel <- GamePropertiesPanel.create ui + notebookAppendPage controlsBook (GamePropertiesPanel.myWidget gamePropertiesPanel) "Properties" + + dirtyChangedHandler <- newIORef Nothing + filePathChangedHandler <- newIORef Nothing + + let me = MainWindow { myUi = ui + , myWindow = window + , myActions = actions + , myGamePropertiesPanel = gamePropertiesPanel + , myGoban = goban + , myInfoLine = infoLine + , myDirtyChangedHandler = dirtyChangedHandler + , myFilePathChangedHandler = filePathChangedHandler + } + + initialize me + + on window deleteEvent $ liftIO $ do + fileClose ui + return True + + widgetGrabFocus $ Goban.myWidget goban + + return me + +-- | Initialization that must be done after the 'UiCtrl' is available. +initialize :: UiCtrl ui => MainWindow ui -> IO () +initialize me = do + let ui = myUi me + + writeIORef (myDirtyChangedHandler me) =<< + liftM Just (registerDirtyChangedHandler ui "MainWindow" False $ \_ -> updateWindowTitle me) + writeIORef (myFilePathChangedHandler me) =<< + liftM Just (registerFilePathChangedHandler ui "MainWindow" True $ \_ _ -> updateWindowTitle me) + +destroy :: UiCtrl ui => MainWindow ui -> IO () +destroy me = do + Actions.destroy $ myActions me + GamePropertiesPanel.destroy $ myGamePropertiesPanel me + Goban.destroy $ myGoban me + InfoLine.destroy $ myInfoLine me + + let ui = myUi me + F.mapM_ (unregisterDirtyChangedHandler ui) =<< readIORef (myDirtyChangedHandler me) + F.mapM_ (unregisterFilePathChangedHandler ui) =<< readIORef (myFilePathChangedHandler me) + + -- A main window owns a UI controller. Once a main window is destroyed, + -- there should be no remaining handlers registered. + -- TODO Revisit this if we have multiple windows under a controller. + registeredHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ + "MainWindow.destroy: Warning, there are still handler(s) registered:" ++ + concatMap (\handler -> "\n- " ++ show handler) handlers + registeredDirtyChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ + "MainWindow.destroy: Warning, there are still dirty changed handler(s) registered:" ++ + concatMap (\handler -> "\n- " ++ show handler) handlers + registeredFilePathChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ + "MainWindow.destroy: Warning, there are still file path changed handler(s) registered:" ++ + concatMap (\handler -> "\n- " ++ show handler) handlers + registeredModesChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ + "MainWindow.destroy: Warning, there are still modes changed handler(s) registered:" ++ + concatMap (\handler -> "\n- " ++ show handler) handlers + + widgetDestroy $ myWindow me + +-- | Makes a 'MainWindow' visible. +display :: MainWindow ui -> IO () +display = widgetShowAll . myWindow + +-- | Takes a object of generic type, extracts a bunch of actions from it, and +-- adds those actions to a menu. +addActionsToMenu :: Menu -> a -> [a -> Action] -> IO () +addActionsToMenu menu actions accessors = + forM_ accessors $ \accessor -> + containerAdd menu =<< actionCreateMenuItem (accessor actions) + +updateWindowTitle :: UiCtrl ui => MainWindow ui -> IO () +updateWindowTitle me = do + let ui = myUi me + fileName <- getFileName ui + dirty <- getDirty ui + let title = fileName ++ " - Goatee" + addDirty = if dirty then ('*':) else id + windowSetTitle (myWindow me) $ addDirty title diff --git a/src/Game/Goatee/Ui/Gtk/Utils.hs b/src/Game/Goatee/Ui/Gtk/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Utils.hs @@ -0,0 +1,34 @@ +-- 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 . + +-- | General GTK utilities that don't exist in the Gtk2Hs. +module Game.Goatee.Ui.Gtk.Utils ( + onEntryChange, + ) where + +import Control.Monad (void) +import Graphics.UI.Gtk (EditableClass, EntryClass, editableChanged, entryGetText, on) + +-- | Registers a handler to be called when the value contained in the entry's +-- buffer changes. The handler is called with the new value. +onEntryChange :: (EditableClass self, EntryClass self) + => self + -> (String -> IO ()) + -> IO () +onEntryChange entry handler = + void $ on entry editableChanged runHandler + where runHandler = entryGetText entry >>= handler diff --git a/tests/Game/Goatee/Ui/Gtk/LatchTest.hs b/tests/Game/Goatee/Ui/Gtk/LatchTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Ui/Gtk/LatchTest.hs @@ -0,0 +1,53 @@ +-- 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.Ui.Gtk.LatchTest (tests) where + +import Data.IORef (modifyIORef, newIORef, readIORef) +import Game.Goatee.Ui.Gtk.Latch +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +tests = testGroup "Game.Goatee.Ui.Gtk.Latch" [ + testCase "a new latch is off" $ do + latch <- newLatch + ref <- newIORef 0 + whenLatchOff latch $ modifyIORef ref (+ 1) + whenLatchOn latch $ modifyIORef ref (+ 2) + (1 @=?) =<< readIORef ref, + + testCase "a latch can be held on" $ do + latch <- newLatch + ref <- newIORef 0 + withLatchOn latch $ do + whenLatchOff latch $ modifyIORef ref (+ 1) + whenLatchOn latch $ modifyIORef ref (+ 2) + (2 @=?) =<< readIORef ref, + + testCase "a new latch returns to being off after it is released" $ do + latch <- newLatch + ref <- newIORef 0 + withLatchOn latch $ do + whenLatchOff latch $ modifyIORef ref (+ 1) + whenLatchOn latch $ modifyIORef ref (+ 2) + whenLatchOff latch $ modifyIORef ref (+ 4) + whenLatchOn latch $ modifyIORef ref (+ 8) + (6 @=?) =<< readIORef ref + ] diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.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 . + +module Main (main) where + +import qualified Game.Goatee.Ui.Gtk.LatchTest +import Test.Framework (defaultMain) + +tests = [ Game.Goatee.Ui.Gtk.LatchTest.tests + ] + +main :: IO () +main = defaultMain tests