goatee-gtk (empty) → 0.1.0
raw patch · 15 files changed
+3587/−0 lines, 15 filesdep +HUnitdep +basedep +cairosetup-changed
Dependencies added: HUnit, base, cairo, containers, directory, filepath, goatee, goatee-gtk, gtk, mtl, test-framework, test-framework-hunit
Files
- LICENSE +661/−0
- Setup.hs +19/−0
- goatee-gtk.cabal +85/−0
- src-exe/Main.hs +33/−0
- src/Game/Goatee/Ui/Gtk.hs +575/−0
- src/Game/Goatee/Ui/Gtk/Actions.hs +306/−0
- src/Game/Goatee/Ui/Gtk/Common.hs +419/−0
- src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs +235/−0
- src/Game/Goatee/Ui/Gtk/Goban.hs +699/−0
- src/Game/Goatee/Ui/Gtk/InfoLine.hs +104/−0
- src/Game/Goatee/Ui/Gtk/Latch.hs +70/−0
- src/Game/Goatee/Ui/Gtk/MainWindow.hs +267/−0
- src/Game/Goatee/Ui/Gtk/Utils.hs +34/−0
- tests/Game/Goatee/Ui/Gtk/LatchTest.hs +53/−0
- tests/Test.hs +27/−0
+ LICENSE view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU 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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.++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+<http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -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 <http://www.gnu.org/licenses/>.++import Distribution.Simple+main = defaultMain
+ goatee-gtk.cabal view
@@ -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 <bog@khumba.net>+maintainer: Bryan Gardiner <bog@khumba.net>+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
+ src-exe/Main.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/Game/Goatee/Ui/Gtk.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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 <http://www.gnu.org/licenses/>."
+ src/Game/Goatee/Ui/Gtk/Actions.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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 "<Control>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 "<Control>o"+ on fileOpenAction actionActivated $ fileOpen ui++ fileSaveAction <- actionNew "FileSave" "_Save file" Nothing Nothing+ actionGroupAddActionWithAccel fileActions fileSaveAction $ Just "<Control>s"+ on fileSaveAction actionActivated $ void $ fileSave ui++ fileSaveAsAction <- actionNew "FileSaveAs" "Sa_ve file as..." Nothing Nothing+ actionGroupAddActionWithAccel fileActions fileSaveAsAction $ Just "<Control><Shift>s"+ on fileSaveAsAction actionActivated $ void $ fileSaveAs ui++ fileCloseAction <- actionNew "FileClose" "_Close" Nothing Nothing+ actionGroupAddActionWithAccel fileActions fileCloseAction $ Just "<Control>w"+ on fileCloseAction actionActivated $ void $ fileClose ui++ fileQuitAction <- actionNew "FileQuit" "_Quit" Nothing Nothing+ actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "<Control>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
+ src/Game/Goatee/Ui/Gtk/Common.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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)"
+ src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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
+ src/Game/Goatee/Ui/Gtk/Goban.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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
+ src/Game/Goatee/Ui/Gtk/InfoLine.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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 -> ""+ _ -> "<b>" ++ show childCount ++ " variations from here.</b>"+ 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
+ src/Game/Goatee/Ui/Gtk/Latch.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/Game/Goatee/Ui/Gtk/MainWindow.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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
+ src/Game/Goatee/Ui/Gtk/Utils.hs view
@@ -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 <http://www.gnu.org/licenses/>.++-- | 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
+ tests/Game/Goatee/Ui/Gtk/LatchTest.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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+ ]
+ tests/Test.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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