diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/happlets-lib-gtk.cabal b/happlets-lib-gtk.cabal new file mode 100644 --- /dev/null +++ b/happlets-lib-gtk.cabal @@ -0,0 +1,163 @@ +-- "happlets-lib-gtk.cabal" build configuration for this project. +-- +-- Copyright (C) 2017-2018 Ramin Honary. +-- +-- "happlets-gtk" is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License (AGPL) as +-- published by the Free Software Foundation. +-- +-- "happlets-lib-gtk" 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 General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +NAME: happlets-lib-gtk +VERSION: 0.1.0.0 +AUTHOR: Ramin Honary +COPYRIGHT: (C) 2017-2018 Ramin Honary, all rights reserved. +MAINTAINER: RaminHAL9001@gmail.com +HOMEPAGE: https://github.com/RaminHAL9001/happlets-lib-gtk +LICENSE: AGPL +LICENSE-FILE: LICENSE +BUILD-TYPE: Simple +CABAL-VERSION: >= 1.18 + +CATEGORY: GUI, Game +SYNOPSIS: The "Haskell Applets" Gtk+ ver. 2 back-end for "happlets". + +DESCRIPTION: + . + *WARNING:* There are still some known bugs in this package, it is being + uploaded to Hackage for evaluation purposes only. Although it is being + actively developed, there is no release schedule for a production-ready + version of this package. Contributions to the repository on GitHub are + welcome. + . + This packages provides the Gtk+ v2 back-end to the "happlets" GUI + framework. To create a Gtk+ applet, import the "Happlets.Lib.Gtk" + module. "Happlets.Lib.Gtk" re-exports the "Happlets" module, so you can + use all of the primitives provided by the "Happlets" module to construct + your applet. In your "main" function, launch the main event loop by + passing the 'Happlets.Lib.Gtk.gtkHapplet' function as the "Provider" + either to the 'Happlets.Initialize.happlet' function or to the + 'Happlets.Initialize.simpleHapplet' function. + . + For an example of how to program your own Happlet, run the "cabal + configure" command with the "--enable-tests" flag set. This will build + the "Happlets.Lib.Gtk.TestSuite" executable program. Refer to the source + code for "TestSuite" to see how the application is structured. + . + The goal of the Happlets project is to allow you to create very simple, + thread-safe applications that contain nothing more than a single window + with a drawing canvas that can respond to user input events, like mouse + clicks, key-presses, or frame animation events. The intention is to + create a minimal programming platform for small, single-purpose + graphical applications which simply displays some interactive graphic, + for example a plot of some data, or a simple game. Naturally, the + Happlet program can be arbitrarily complex, but it may be better to + consider other, FRP-based solutions if managing events becomes too + difficult. + . + +Library { + + HS-SOURCE-DIRS: src + DEFAULT-LANGUAGE: Haskell2010 + + GHC-OPTIONS: -Wall + -fno-warn-name-shadowing + -fno-warn-unused-do-bind + + EXPOSED-MODULES: + Happlets.Lib.Gtk + + BUILD-DEPENDS: + cairo >=0.13.3.0 && <0.14.0.0, + diagrams-cairo >=1.4 && <2.0, + diagrams-core >=1.4 && <2.0, + diagrams-lib >=1.4.0.0 && <2.0.0.0, + glib >=0.12.0.0 && <0.14.0.0, + gtk >=0.13.0 && <0.15.0, + happlets >=0.1.0.0 && <1.0.0.0, + lens >=4.0.0.0 && <5.0.0.0, + linear >=1.20.0 && <2.0.0.0, + mtl >=2.2.0 && <=2.2.1, + pango >=0.13.4.0 && <0.14.0.0, + semigroups >=0.16.0 && <0.19.0, + text >=1.1.1.4 && <=2.0.0.0, + time >=1.4.0.0 && <=1.6.0.0, + base >=4.7 && <4.9 + + DEFAULT-EXTENSIONS: + DeriveDataTypeable + DeriveFunctor + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + ImplicitParams + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving +} + +Test-suite happlets-lib-gtk-test { + + TYPE: exitcode-stdio-1.0 + MAIN-IS: Happlets/Lib/Gtk/TestSuite.hs + HS-SOURCE-DIRS: src + DEFAULT-LANGUAGE: Haskell2010 + + GHC-OPTIONS: -threaded -Wall + -fno-warn-name-shadowing + -fno-warn-unused-do-bind + -main-is Happlets.Lib.Gtk.TestSuite + + OTHER-MODULES: + Happlets.Lib.Gtk + + BUILD-DEPENDS: +-- bytestring >=0.10.0.0 && <1.0.0.0, + cairo >=0.13.3.0 && <0.14.0.0, +-- colour >=2.0.0 && <3.0.0, +-- containers >=0.5.5.0 && <=0.5.7.0, + diagrams-cairo >=1.4 && <2.0, + diagrams-core >=1.4 && <2.0, + diagrams-lib >=1.4.0.0 && <2.0.0.0, + glib >=0.12.0.0 && <0.14.0.0, + gtk >=0.13.0 && <0.15.0, + happlets >=0.1.0.0 && <1.0.0.0, + lens >=4.0.0.0 && <5.0.0.0, + linear >=1.20.0 && <2.0.0.0, + mtl >=2.2.0 && <=2.2.1, + semigroups >=0.16.0 && <0.19.0, + text >=1.1.1.4 && <=2.0.0.0, + time >=1.4.0.0 && <=1.6.0.0, +-- transformers >=0.3.0.0 && <=0.4.3.0, +-- unix >=2.7.0.0 && <=2.8.0.0, + base >=4.7 && <4.9 + + DEFAULT-EXTENSIONS: + DeriveDataTypeable + DeriveFunctor + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + ImplicitParams + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving +} diff --git a/src/Happlets/Lib/Gtk.hs b/src/Happlets/Lib/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Happlets/Lib/Gtk.hs @@ -0,0 +1,1186 @@ +-- | This is the Gtk+ version 2 back-end for Happlets, and will also serve as the Happlet referecne +-- implementation. Creating a window automatically calls the the Gtk+ initializer. Use +-- 'newGtkWindow' to create a new window, and any of the "Happlet.World" functinos to manipulate the +-- windows. This module re-exports the "Happlets" module so it is not necessary to import both. +module Happlets.Lib.Gtk + ( gtkHapplet, GtkGUI, GtkRedraw, + GtkWindow, gtkLaunchEventLoop, + GtkImage, CairoRender(..), GtkCairoDiagram, gtkCairoDiagram, + cairoClearCanvas, cairoSetColorRGBA32, + gtkAnimationFrameRate, + module Happlets, + module Happlets.Draw + ) + where + +---------------------------------------------------------------------------------------------------- + +import Happlets +import Happlets.Draw +import Happlets.Provider + +import Control.Arrow +import Control.Concurrent +--import Control.Lens +--import Control.Monad +--import Control.Monad.Reader +import Control.Monad.State + +import Data.IORef +import Data.Maybe +import Data.Semigroup +import qualified Data.Text as Strict +import Data.Time.Clock +--import Data.Typeable +import Data.Word + +import qualified Graphics.Rendering.Cairo as Cairo + +--import qualified Graphics.UI.Gtk.Abstract.Container as Gtk +import qualified Graphics.UI.Gtk.Abstract.Widget as Gtk +import qualified Graphics.UI.Gtk.Cairo as Gtk +--import qualified Graphics.UI.Gtk.Display.Image as Gtk +--import qualified Graphics.UI.Gtk.Gdk.GtkWindowState as Gtk +import qualified Graphics.UI.Gtk.Gdk.Drawable as Gtk +import qualified Graphics.UI.Gtk.Gdk.DrawWindow as Gtk +import qualified Graphics.UI.Gtk.Gdk.EventM as Gtk +--import qualified Graphics.UI.Gtk.Gdk.Keys as Gtk +import qualified Graphics.UI.Gtk.Gdk.GC as Gtk +import qualified Graphics.UI.Gtk.Gdk.Pixmap as Gtk +import qualified Graphics.UI.Gtk.Gdk.Region as Gtk +import qualified Graphics.UI.Gtk.Gdk.Screen as Gtk +import qualified Graphics.UI.Gtk.General.General as Gtk +--import qualified Graphics.UI.Gtk.Layout.Alignment as Gtk +import qualified Graphics.UI.Gtk.Windows.Window as Gtk + +import Diagrams.Backend.Cairo.Internal +import Diagrams.BoundingBox +import Diagrams.Core.Compile +import Diagrams.Core.Types +import Diagrams.Size (dims) + +import Linear.Affine +import Linear.V2 (V2(..)) + +import System.IO +import System.IO.Unsafe + +--import System.Glib.Attributes (AttrOp(..)) +--import qualified System.Glib.Attributes as Glib +import qualified System.Glib.Signals as Glib +import qualified System.Glib.Utils as Glib +import qualified System.Glib.MainLoop as Glib + +import Debug.Trace + +---------------------------------------------------------------------------------------------------- + +debugThisModule :: Bool +debugThisModule = True + +type LogGUI = String -> IO () + +mkLogger + :: (Monad m, MonadIO m) + => String -> Bool -> m LogGUI +mkLogger func enable = return $ if not (debugThisModule && enable) + then const $ return () + else \ msg -> do + tid <- myThreadId + traceIO $ '[' : show tid ++ "][Happlets.Lib.Gtk." ++ func ++ "] " ++ msg + +---------------------------------------------------------------------------------------------------- + +dToW16 :: Double -> Word16 +dToW16 = round . (*) (realToFrac (maxBound::Word16)) + +dToGrey :: Double -> Gtk.Color +dToGrey d = Gtk.Color (dToW16 d) (dToW16 d) (dToW16 d) + +-- | This is the frame rate used by default when installing an animation event handler. This value +-- can be configured by modifying the 'Happlets.Config.animationFrameRate'. +gtkAnimationFrameRate :: Double +gtkAnimationFrameRate = 60.0 + +---------------------------------------------------------------------------------------------------- + +-- | This data type acts as a handle to a Gtk+ environment, which contains pointers to the window +-- and graphpics contexts which you can manipulate by inserting or removing your own Happlets to be +-- displayed within it. +data GtkWindow + = GtkUnlockedWin !(MVar GtkWindowState) + -- ^ This is the constructor used by public-facing APIs. The 'Happlets.Initialize.newWindow' + -- 'Happlets.Initialize.deleteWindow', and 'Happlets.Initialize.attachWindow' functions all + -- return or pass this constructor around. + | GtkLockedWin !(GtkWindowState) + -- ^ This is the constructor use internally, particularly when evaluating the 'Happlets.GUI.GUI' + -- monad. When evaluation completes, it is stored back into the MVar for 'GtkUnlockedWin' and the + -- 'GtkUnlockedWin' is returned instead. + +-- | A monadic wrapper around a 'Cario.Render' monad. The only reason for this to exist is because +-- there needs to be an instance of 'Data.Semigroup.Semigroup'. +-- +-- The 'Controller' type is defined to use the 'CairoRender' as it's @view@ type. You can also +-- convert a 'GtkCairoDiagram' to a 'CairoRender' using the 'gtkCairoDiagram' function. +newtype CairoRender a = CairoRender { runCairoRender :: Cairo.Render a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance Semigroup a => Semigroup (CairoRender a) where + (CairoRender a) <> (CairoRender b) = CairoRender $ (<>) <$> a <*> b + +instance Monoid a => Monoid (CairoRender a) where + mappend (CairoRender a) (CairoRender b) = CairoRender $ mappend <$> a <*> b + mempty = return mempty + +-- | Contains parameters that can exist /after/ the 'Gtk.Window' has been allocated. These +-- parameters are stored in an 'MVar' which is initialized in an empty state until the Gtk+ window +-- is actually made visible (when it recieves the first "configure" event). The reason for this is +-- that many of the 'Happlets.GUI.GUI' functions may try to evaluate a redraw before the window +-- exists and the DrawWIndow has been allocated. +data GtkWindowLive + = GtkWindowLive + { gtkDrawWindow :: !Gtk.DrawWindow + , theGtkPixmap :: !Gtk.Pixmap + -- ^ This is the 'Gtk.Pixmap' that contains the buffer of the image that is displayed in the + -- Happlet window. Every time the window is resized, this object is re-allocated, so it is + -- important that this value be accessible in only one location, do not store a copy of it + -- into an MVar or IORef which other threads may write to arbitrarily, unless you like the + -- image to be garbled. + , theGtkGraphCtx :: !Gtk.GC + -- ^ This is the old-fashioned GUI graphics context, which keeps track of things like + -- foreground color, background color, clip region, and pen location. This is used for Gdk + -- (not Gtk+) drawing primitives. As far as I know, this data structure is deprecated and does + -- not even exist in Gtk+ version 3, but it is still the only way to perform certain + -- graphics operations in Gtk+ version 2. + } + +data GtkWindowState + = GtkWindowState + { currentConfig :: !Config + , thisWindow :: !(MVar GtkWindowState) + , gtkWindowLive :: !(MVar GtkWindowLive) + , gtkWindow :: !Gtk.Window + , theInitReaction :: !(ConnectReact PixSize) + , theResizeReaction :: !(ConnectReact PixCoord) + , theVisibilityReaction :: !(ConnectReact Bool) + , theFocusReaction :: !(ConnectReact Bool) + , theMouseHandler :: !(ConnectReact Mouse) + , theCursorHandler :: !(ConnectReact Mouse) + , theKeyHandler :: !(ConnectReact Keyboard) + , theAnimatorThread :: !(ConnectReact AnimationMoment) + } + +data ConnectReact event + = Disconnected + | ConnectReact{ doDisconnect :: GtkState (), doReact :: event -> GtkState Bool } + +evalConnectReact :: ConnectReact event -> event -> GtkState Bool +evalConnectReact = \ case + Disconnected -> const $ return False + ConnectReact{doReact=f} -> f + +forceDisconnect :: Lens' GtkWindowState (ConnectReact event) -> GtkState () +forceDisconnect connection = use connection >>= \ case + ConnectReact{doDisconnect=discon} -> discon >> connection .= Disconnected + Disconnected -> return () + +--gtkPixmap :: Lens' GtkWindowLive Gtk.Pixmap +--gtkPixmap = lens theGtkPixmap $ \ a b -> a{ theGtkPixmap = b } + +--gtkGraphCtx :: Lens' GtkWindowLive Gtk.GC +--gtkGraphCtx = lens theGtkGraphCtx $ \ a b -> a{ theGtkGraphCtx = b } + +initReaction :: Lens' GtkWindowState (ConnectReact PixSize) +initReaction = lens theInitReaction $ \ a b -> a{ theInitReaction = b } + +visibilityReaction :: Lens' GtkWindowState (ConnectReact Bool) +visibilityReaction = lens theVisibilityReaction $ \ a b -> a{ theVisibilityReaction = b } + +focusReaction :: Lens' GtkWindowState (ConnectReact Bool) +focusReaction = lens theFocusReaction $ \ a b -> a{ theFocusReaction = b } + +resizeReaction :: Lens' GtkWindowState (ConnectReact PixCoord) +resizeReaction = lens theResizeReaction $ \ a b -> a{ theResizeReaction = b } + +mouseHandler :: Lens' GtkWindowState (ConnectReact Mouse) +mouseHandler = lens theMouseHandler $ \ a b -> a{ theMouseHandler = b } + +cursorHandler :: Lens' GtkWindowState (ConnectReact Mouse) +cursorHandler = lens theCursorHandler $ \ a b -> a{ theCursorHandler = b } + +keyHandler :: Lens' GtkWindowState (ConnectReact Keyboard) +keyHandler = lens theKeyHandler $ \ a b -> a{ theKeyHandler = b } + +animatorThread :: Lens' GtkWindowState (ConnectReact AnimationMoment) +animatorThread = lens theAnimatorThread $ \ a b -> a{ theAnimatorThread = b } + +-- Create an image buffer with an alpha channel for a 'Graphics.UI.Gtk.Abstract.Widget.Widget' to +-- be rendered. +mkAlphaChannel :: LogGUI -> Gtk.Widget -> IO () +mkAlphaChannel logGUI window = do + logGUI $ "Gtk.widgetGetScreen" + screen <- Gtk.widgetGetScreen window + logGUI $ "Gtk.screenGetRGBAColormap" + colormap <- Gtk.screenGetRGBAColormap screen + case colormap of + Nothing -> do + logGUI $ "-- Colormap dos NOT support alpha channels" + return () + Just colormap -> do + logGUI $ "Gtk.widgetSetColorMap" + Gtk.widgetSetColormap window colormap + +--gtkCanvas :: GtkState Gtk.DrawWindow +--gtkCanvas = gets gtkWindowLive >>= liftIO . liftM gtkDrawWindow . readMVar + +---------------------------------------------------------------------------------------------------- + +newtype GtkState a + = GtkState { unwrapGtkState :: StateT GtkWindowState IO a } + deriving (Functor) + +instance Applicative GtkState where + pure = return + (<*>) = ap + +instance Monad GtkState where + return = GtkState . return + (GtkState a) >>= b = GtkState $ a >>= unwrapGtkState . b + +instance MonadState GtkWindowState GtkState where + state = GtkState . state + +instance MonadIO GtkState where + liftIO = GtkState . liftIO + +runGtkState :: GtkState a -> GtkWindowState -> IO (a, GtkWindowState) +runGtkState (GtkState f) = runStateT f + +-- | This function acquires a lock on the 'GtkState' and begins evaluating the 'GtkState' +-- function. This function should be evaluated at the top level of the procedure that is evaluated +-- by an event handler. +lockGtkWindow :: GtkWindow -> GtkState a -> IO a +lockGtkWindow win f = case win of + GtkLockedWin{} -> error "lockGtkWindow: evaluated on an already locked 'GtkLockedWin' window." + GtkUnlockedWin mvar -> modifyMVar mvar $ liftM (\ (a, b) -> (b, a)) . runGtkState f + +-- | This function evaluates 'Happlets.GUI.GUI' functions within event handlers. It evaluates to a +-- 'GtkState' function, which means you are required to have first evaluated 'unlockGtkWindow'. This +-- function will then lock the 'Happlets.GUI.Happlet' and then evaluate the 'Happlets.GUI.GUI' +-- function. +gtkRunHapplet + :: Happlet model -> (GUIContinue -> GtkState ()) -> GtkGUI model void -> GtkState Bool +gtkRunHapplet happ cont f = do + logGUI <- mkLogger "gtkRunHapplet" True + env <- get + liftIO $ logGUI $ "locking Happlet, evaluating GUI function..." + ((env, keep), _) <- liftIO $ onHapplet happ $ \ model -> do + logGUI "evalGUI" + gui <- evalGUI f happ (GtkLockedWin env) model + let model = theGUIModel gui + case theGUIWindow gui of + GtkUnlockedWin{} -> error + "gtkRunHapplet: evalGUI evaluated on GtkLockedWin but returned GtkUnlockedWin" + GtkLockedWin env -> do + logGUI "runGtkState -- evaluate continuation" + ((), env) <- runGtkState (cont $ theGUIContinue gui) env + return ((env, guiIsLive gui), model) + state $ const (keep, env) + +-- | This function is intended to be passed as a parameter to 'gtkRunHapplet' by event handling +-- functions which check if the 'Happlets.GUI.GUI' function evaluated to 'Happlets.GUI.disable'. +checkGUIContinue + :: LogGUI + -> Lens' GtkWindowState (ConnectReact event) + -> GUIContinue + -> GtkState () +checkGUIContinue logGUI connection = \ case + GUIHalt -> forceDisconnect connection + GUIFail msg -> do + liftIO $ logGUI $ "GUI function evaluated to \"fail\" with message:\n " ++ show msg + forceDisconnect connection + GUIContinue -> return () + +-- | This function should be evaluated from within a 'GtkGUI' function when it is necessary to +-- update the 'GtkWindowState', usually this is for installing or removing event handlers. +runGtkStateGUI :: GtkState a -> GtkGUI model a +runGtkStateGUI f = getGUIState >>= \ gui -> case theGUIWindow gui of + GtkUnlockedWin{} -> error $ "runGtkStateGUI: " ++ + "Evaluated a GtkState function within a GtkGUI function on a locked GtkWindow." + -- The 'window' value passed to the 'evalGUI' function must be a 'GtkLockedWin' constructor. + GtkLockedWin env -> do + (a, env) <- liftIO $ runGtkState f env + putGUIState $ gui{ theGUIWindow = GtkLockedWin env } + return a + +-- | Create the window and install the permanent event handlers. +createWin :: Config -> IO GtkWindowState +createWin cfg = do + logGUI <- mkLogger "createWin" True + forM_ (configErrorsOnLoad cfg) (hPrint stderr) + logGUI $ "Gtk.windowNew" + window <- Gtk.windowNew + logGUI $ "Gtk.widgetSetHasWindow" + Gtk.widgetSetHasWindow window True + logGUI $ "Gtk.widgetSetAppPaintable" + Gtk.widgetSetAppPaintable window True + logGUI $ "Gtk.widgetSetDoubleBuffered window False" + Gtk.widgetSetDoubleBuffered window False + when (isJust $ cfg ^. backgroundTransparency) $ mkAlphaChannel logGUI $ Gtk.castToWidget window + logGUI $ "Gtk.windowSetTypeHint GtkWindowTtypeHintNormal" + Gtk.windowSetTypeHint window Gtk.WindowTypeHintNormal + logGUI $ "Gtk.windowSetDefaultSize " ++ show (cfg ^. recommendWindowSize) + uncurry (Gtk.windowSetDefaultSize window) $ cfg ^. recommendWindowSize + logGUI $ "Gtk.windowSetDecorated " ++ show (cfg ^. decorateWindow) + Gtk.windowSetDecorated window $ cfg ^. decorateWindow + this <- newEmptyMVar + live <- newEmptyMVar + let env = GtkWindowState + { currentConfig = cfg + , thisWindow = this + , gtkWindowLive = live + , gtkWindow = window + , theInitReaction = Disconnected + , theResizeReaction = Disconnected + , theVisibilityReaction = Disconnected + , theFocusReaction = Disconnected + , theMouseHandler = Disconnected + , theCursorHandler = Disconnected + , theKeyHandler = Disconnected + , theAnimatorThread = Disconnected + } + ((), env) <- flip runGtkState env $ do + installExposeEventHandler + installDeleteEventHandler + installInitEventHandler + putMVar this env + return env + +-- | Expose event handlers do not evaluate any 'GUI' functions. The expose event handler's only task +-- is to blit the canvas pixmap to the window's image buffer. +-- +-- The expose event handler installed here actually will remove itself and install another expose +-- event handler which will be used throughout the remainder of the windows lifetime. The reason +-- this is necessary due to some idiosyncratic behavior of Gtk+, namely that the first time the +-- expose event handler is called, the window's image buffer has not been properly allocated and the +-- event handler that does the blitting will be needing a pointer to an image buffer, so the +-- permanent event handler cannot be installed until the pointer to the image buffer becomes +-- available. +installExposeEventHandler :: GtkState () +installExposeEventHandler = do + logGUI <- mkLogger "installExposeEventHandler" True + env <- get + liftIO $ do + logGUI $ "Gtk.widgetAddEvents env [Gtk.StructureMask]" + Gtk.widgetAddEvents (gtkWindow env) [Gtk.StructureMask, Gtk.ExposureMask] + --------------------------------------- Expose Event ----------------------------------- + logGUI "Glib.on Gtk.exposeEvent -- for init handler" + initExposeEventMVar <- newEmptyMVar + (>>= (putMVar initExposeEventMVar)) $ Glib.on (gtkWindow env) Gtk.exposeEvent $ do + logGUI <- mkLogger "initExposeEventCallback" True + liftIO $ do + logGUI "Gtk.eventWindow >>= putMVar gtkDrawWindowMVar" + takeMVar initExposeEventMVar >>= Glib.signalDisconnect + logGUI "Glib.on window Gtk.exposeEvent" + Glib.on (gtkWindow env) Gtk.exposeEvent $ do + logGUI <- mkLogger "exposeEventCallback" False + canvas <- Gtk.eventWindow + region <- Gtk.eventRegion + liftIO $ withMVar (gtkWindowLive env) $ \ livest -> do + Gtk.gcSetClipRegion (theGtkGraphCtx livest) region + (w, h) <- Gtk.drawableGetSize (theGtkPixmap livest) + logGUI $ "Gtk.drawRectangle 0 0 " ++ show w ++ ' ' : show h + Gtk.drawRectangle canvas (theGtkGraphCtx livest) True 0 0 w h + --liftIO $ gdkBlit canvas (theGtkGraphCtx env) (V2 0 0) region >> return True + return True + ------------------------------------------------------------------------------------ + return True + +-- | The init event handler was responsible for pulling the init GUI function from the +-- 'GtkWindowState' and evaluating it, then installing a configure event handler. +installInitEventHandler :: GtkState () +installInitEventHandler = do + logGUI <- mkLogger "permanentHandlers" True + env <- get + liftIO $ do + ------------------------------------ Initializing Event -------------------------------- + logGUI "Glib.on Gtk.configureEvent -- for init handler" + initHandler <- newEmptyMVar + (>>= (putMVar initHandler)) $ Glib.on (gtkWindow env) Gtk.configureEvent $ do + logGUI <- mkLogger "initCallback" True + canvas <- Gtk.eventWindow + size <- Gtk.eventSize + let allocSize = dimsForAlloc size + let evt = sampCoord <$> uncurry V2 size + liftIO $ lockGtkWindow (GtkUnlockedWin $ thisWindow env) $ do + live <- gets gtkWindowLive + liftIO $ do + logGUI $ "newGtkWindowLive (dimsForAlloc " ++ + show size ++ " --> " ++ show allocSize ++ ")" + livest <- newGtkWindowLive (currentConfig env) canvas allocSize + logGUI "putMVar gtkWindowLive" + putMVar live livest + logGUI $ "initReaction " ++ show size + use initReaction >>= flip evalConnectReact evt + forceDisconnect initReaction + liftIO $ do + logGUI "Glib.signalDisconnect initCallback" + takeMVar initHandler >>= Glib.signalDisconnect + logGUI "installResizeEventHandler -- a permanent handler" + installResizeEventHandler + return False + +-- | This function installs the configure event handler, which is called whenever the window is +-- resized. +installResizeEventHandler :: GtkState () +installResizeEventHandler = do + logGUI <- mkLogger "installResizeEventHandler" True + env <- get + liftIO $ do + logGUI "Glib.on window Gtk.configureEvent" + void $ Glib.on (gtkWindow env) Gtk.configureEvent $ do + logGUI <- mkLogger "configureEventCallback" True + canvas <- Gtk.eventWindow + size <- Gtk.eventSize + let evt = sampCoord <$> uncurry V2 size + liftIO $ lockGtkWindow (GtkUnlockedWin $ thisWindow env) $ do + liftIO $ logGUI $ "resizeGtkDrawContext " ++ show size + resizeGtkDrawContext canvas size + liftIO $ logGUI "resizeReaction" + use resizeReaction >>= flip evalConnectReact evt + liftIO $ do + logGUI "Gtk.widgetQueueDraw" + Gtk.widgetQueueDraw (gtkWindow env) + return False + +-- | This event handler is responsible for cleaning up when a window close event occurs. Whether the +-- application quit or not when the window closes is configurable by parameters in the +-- 'Happlets.Config.Config' data structure. +installDeleteEventHandler :: GtkState () +installDeleteEventHandler = do + logGUI <- mkLogger "installDeleteEventHandler" True + env <- get + liftIO $ do + logGUI "Glib.on Gtk.deleteEvent" + Glib.on (gtkWindow env) Gtk.deleteEvent $ liftIO $ + lockGtkWindow (GtkUnlockedWin $ thisWindow env) $ do + logGUI <- mkLogger "deleteWindowCallback" True + let cfg = currentConfig env + if cfg ^. deleteWindowOnClose + then do + liftIO $ logGUI "Gtk.widgetDestroy -- willDeleteWindowOnClose is True" + disconnectAll + liftIO $ Gtk.widgetDestroy (gtkWindow env) + else liftIO $ do + logGUI $ "Gtk.widgetHideAll -- willDeleteWindowOnClose is False" + Gtk.widgetHideAll (gtkWindow env) + liftIO $ if not (cfg ^. quitOnWindowClose) + then logGUI "-- quitOnWindowClose is False" + else do + logGUI $ "Gtk.mainQuit -- quitOnWindowClose is True" + Gtk.mainQuit + return True + logGUI "-- done installing permanent event handlers" + +deleteWin :: GtkWindowState -> IO () +deleteWin env = do + logGUI <- mkLogger "deleteWin" True + logGUI "Gtk.widgetDestroy" + Gtk.widgetDestroy (gtkWindow env) + +--evalGtkDraw :: GtkDraw -> GtkState () +--evalGtkDraw (CairoRender draw) = get >>= \ env -> liftIO $ case theGtkPixmap env of +-- Just pixmap -> Gtk.renderWithDrawable pixmap draw +-- Nothing -> Gtk.widgetGetDrawWindow (gtkWindow env) >>= flip Gtk.renderWithDrawable draw + +-- | Compute rectangular dimensions for a window buffer allocation that are large enough to contain +-- the given rectangluar dimensions, but are also an even multiple of some unit value. When resizing +-- windows with 'resizeGtkDrawContext' this function is used to decide whether it is necessary to +-- re-allocate the window buffer or if the old window buffer is still large enough to contain the +-- new window dimensions. +dimsForAlloc :: (Int, Int) -> (Int, Int) +dimsForAlloc (w, h) = (step w, step h) where + factor = 32 + step a = (div (abs a) factor + 1) * factor + -- For 32-bit pixels, with a minimum alloctable rectangle size of 32*32 means the minimum buffer + -- allocation will be 32*32*32 = 32^3 = (2^5)^3 = 2^15 = 32768 bytes. + +-- | This function obtains a widget drawing window object and it's size, and allocates a new pixmap +-- buffer and GDK drawing context for it. This function conditionally calls 'newGtkWindowLive' if +-- 'dimsForAlloc' returns a different value than what is already allocated. This function also locks +-- the 'gtkWindowLive' MVar, so it is assumed the MVar is not empty. So this function must not be +-- called until the "initCallback" has been evaluated. +resizeGtkDrawContext :: Gtk.DrawWindow -> (Int, Int) -> GtkState () +resizeGtkDrawContext canvas size = do + logGUI <- mkLogger "resizeGtkDrawContext" True + env <- get + let cfg = currentConfig env + let newDims = dimsForAlloc size + liftIO $ modifyMVar_ (gtkWindowLive env) $ \ livest -> do + oldDims <- Gtk.drawableGetSize (theGtkPixmap livest) + if newDims == oldDims + then do + logGUI $ "-- will not re-allocate window buffer, old buffer size = " ++ + show oldDims ++ ", new buffer size = " ++ show newDims + return livest + else do + logGUI $ "gtkAllocNewPixmap " ++ show newDims + newGtkWindowLive cfg canvas newDims + +-- | Allocates a new 'GtkWindowLive', including the 'Gtk.Pixmap' buffer and 'Gtk.GC' graphics +-- context. The buffer allocated will be exactly the dimensions given without checking if the size +-- is valid, and invalid demensions will crash the thread. +newGtkWindowLive :: Config -> Gtk.DrawWindow -> (Int, Int) -> IO GtkWindowLive +newGtkWindowLive cfg canvas size@(w, h) = do + logGUI <- mkLogger "gtkAllocNewPixmap" True + let depth = Just $ if isJust $ cfg ^. backgroundTransparency then 32 else 24 + let grey = cfg ^. backgroundGreyValue + logGUI $ "Gtk.pixmapNew " ++ show size ++ ' ' : show depth + pixmap <- Gtk.pixmapNew (Just canvas) w h depth + --logGUI $ "Gtk.gcNew -- should be Gtk.DrawWindow of 'window'" + --graphCtx <- Gtk.gcNew canvas + --gcVals <- Gtk.gcGetValues graphCtx + --logGUI $ "Gtk.gcSetValues" + --Gtk.gcSetValues graphCtx gcVals + -- { Gtk.background = dToGrey grey + -- , Gtk.tile = Just pixmap + -- , Gtk.fill = Gtk.Tiled + -- } + gc <- liftIO $ Gtk.gcNewWithValues canvas Gtk.newGCValues + { Gtk.background = dToGrey grey + , Gtk.tile = Just pixmap + , Gtk.fill = Gtk.Tiled + } + return GtkWindowLive + { gtkDrawWindow = canvas + , theGtkPixmap = pixmap + , theGtkGraphCtx = gc + } + +disconnectAll :: GtkState () +disconnectAll = do + forceDisconnect visibilityReaction + forceDisconnect focusReaction + forceDisconnect mouseHandler + forceDisconnect cursorHandler + forceDisconnect keyHandler + forceDisconnect animatorThread + forceDisconnect resizeReaction + +---------------------------------------------------------------------------------------------------- + +-- | This is a type of 'Happlets.GUI.GUI' function where the @window@ type is 'GtkWindow' and the +-- @draw@ type is 'GtkDraw' (a Cairo 'Graphics.Rendering.Cairo.Render' function). +type GtkGUI model a = GUI GtkWindow model a + +-- | Creates a happlet and associates it with a window. +gtkNewWindow :: Config -> IO GtkWindow +gtkNewWindow cfg = do + logGUI <- mkLogger "gtkWindowNew" True + logGUI "createWin" + GtkUnlockedWin . thisWindow <$> createWin cfg + +gtkWindowVisible :: Bool -> GtkGUI model () +gtkWindowVisible visible = do + logGUI <- mkLogger ("gtkWindowVisible "++show visible) True + runGtkStateGUI $ get >>= \ env -> liftIO $ do + if visible + then do + logGUI "Gtk.widgetShow" + Gtk.widgetShowAll (gtkWindow env) + logGUI "Gtk.widgetQueueDraw" + Gtk.widgetQueueDraw (gtkWindow env) + else do + logGUI "Gtk.widgetHideAll" + Gtk.widgetHideAll (gtkWindow env) + +gtkAttachHapplet :: Bool -> GtkWindow -> Happlet model -> (PixSize -> GtkGUI model ()) -> IO () +gtkAttachHapplet showWin win happ init = do + logGUI <- mkLogger "gtkAttachHapplet" True + logGUI "lockGtkWindow" + lockGtkWindow win $ do + disconnectAll + initReaction .= ConnectReact + { doDisconnect = return () -- This function is disconnected automatically by the init callback. + , doReact = \ size -> do + logGUI <- mkLogger "initReaction" True + env <- get + liftIO $ logGUI $ "gtkRunHapplet " ++ show size + void $ gtkRunHapplet happ (const $ return ()) $ init size + when showWin $ liftIO $ do + logGUI "Gtk.widgetShowAll" + Gtk.widgetShowAll (gtkWindow env) + logGUI "Gtk.widgetQueueDraw" + Gtk.widgetQueueDraw (gtkWindow env) + return False + } + win <- gets gtkWindow + liftIO $ logGUI "Gtk.widgetShow" >> Gtk.widgetShow win + +-- | Change the happlet displayed in the current window. Remove the current Happlet event handlers +-- and re-install the event handlers for the given Happlet. +gtkSetHapplet :: Happlet newmodel -> (PixSize -> GtkGUI newmodel ()) -> GtkGUI oldmodel () +gtkSetHapplet newHapp init = do + logGUI <- mkLogger "windowSetHapplet" True + oldHapp <- askHapplet + if sameHapplet oldHapp newHapp + then liftIO $ logGUI "-- the Happlet given is the one that is already attached to this window" + else do + liftIO $ logGUI "disconnectAll -- on current window" + runGtkStateGUI disconnectAll + st <- getGUIState + (env, _) <- case theGUIWindow st of + GtkUnlockedWin{} -> error $ "gtkSetHapplet: " ++ + "Evaluated a GtkState function within a GtkGUI function on a locked GtkWindow." + -- The 'window' value passed to the 'evalGUI' function must be a 'GtkLockedWin' constructor. + GtkLockedWin env -> liftIO $ do + size <- Gtk.widgetGetDrawWindow (gtkWindow env) >>= Gtk.drawableGetSize + let evt = sampCoord <$> uncurry V2 size + logGUI $ "onHapplet -- run initializer " ++ show size + onHapplet newHapp $ + liftM (theGUIWindow &&& theGUIModel) . evalGUI (init evt) newHapp (GtkLockedWin env) + --logGUI "Gtk.widgetQueueDraw" + --Gtk.widgetQueueDraw $ gtkWindow win + --logGUI "Gtk.widgetShow" + --Gtk.widgetShow $ gtkWindow win + putGUIState $ st{ theGUIWindow = env } + void disable + +-- Set which function redraws the window. +evalRedraw :: (PixSize -> CairoRender a) -> GtkState a +evalRedraw redraw = do + logGUI <- mkLogger "evalRedraw" True + env <- get + liftIO $ withMVar (gtkWindowLive env) $ \ livest -> do + -- Obtain the size from the draw window, but will not draw to the draw window. + size <- fmap sampCoord . uncurry V2 <$> Gtk.drawableGetSize (gtkDrawWindow livest) + logGUI "Gtk.renderWithDrawable -- to theGtkPixmap" + a <- Gtk.renderWithDrawable (theGtkPixmap livest) $ runCairoRender $ redraw size + (w, h) <- Gtk.drawableGetSize (gtkDrawWindow livest) + region <- Gtk.regionRectangle $ Gtk.Rectangle 0 0 w h + logGUI "Gtk.drawWindowInvalidateRegion" + Gtk.drawWindowInvalidateRegion (gtkDrawWindow livest) region True + return a + +---------------------------------------------------------------------------------------------------- + +instance HappletWindow GtkWindow CairoRender where + windowChangeHapplet = gtkSetHapplet + onView = runGtkStateGUI . evalRedraw + +instance Happlet2DGraphics CairoRender where + clearScreen = unpackRGBA32Color >>> \ (r,g,b,a) -> CairoRender $ cairoClearCanvas r g b a + drawLine = cairoDrawLine + drawPath = cairoDrawPath + drawRect = cairoDrawRect + setPoint = error "TODO: canvasSetPoint has not yet been implemented in this Happlets back-end" + getPoint = error "TODO: canvasGetPoint has not yet been implemented in this Happlets back-end" + +-- | Push the graphics context by calling 'Cairo.save' before evaluating a given 'Cario.Render' +-- function. When evaluation completes, pop the graphics context by calling 'Cairo.restore'. +cairoPreserve :: CairoRender a -> CairoRender a +cairoPreserve f = CairoRender Cairo.save >> f <* CairoRender Cairo.restore + +cairoMoveTo :: Point2D RealApprox -> CairoRender () +cairoMoveTo = CairoRender . uncurry Cairo.moveTo . view pointXY . fmap unwrapRealApprox + +cairoLineTo :: Point2D RealApprox -> CairoRender () +cairoLineTo = CairoRender . uncurry Cairo.lineTo . view pointXY . fmap unwrapRealApprox + +cairoDrawLine :: LineColor -> LineWidth -> Line2D RealApprox -> CairoRender () +cairoDrawLine color width line = cairoPreserve $ do + CairoRender $ do + cairoSetColorRGBA32 color + Cairo.setLineCap Cairo.LineCapRound + Cairo.setLineWidth $ unwrapRealApprox width + cairoMoveTo $ line ^. line2DHead + cairoLineTo $ line ^. line2DTail + CairoRender $ Cairo.stroke + +cairoDrawPath :: LineColor -> LineWidth -> [Point2D RealApprox] -> CairoRender () +cairoDrawPath color width = + let run a ax = cairoPreserve $ do + CairoRender $ do + cairoSetColorRGBA32 color + Cairo.setLineCap Cairo.LineCapRound + Cairo.setLineWidth $ unwrapRealApprox width + Cairo.setLineJoin Cairo.LineJoinMiter + cairoMoveTo a + forM_ ax cairoLineTo + CairoRender Cairo.stroke + in \ case { [] -> return (); [a] -> run a [a]; a:ax -> run a ax; } + +cairoDrawRect :: LineColor -> LineWidth -> FillColor -> Rect2D RealApprox -> CairoRender () +cairoDrawRect lineColor width fillColor rect = cairoPreserve $ do + CairoRender $ cairoSetColorRGBA32 fillColor + cairoMoveTo $ rect ^. rect2DHead + let ((x0,y0),(x1,y1)) = view pointXY *** view pointXY $ + (unwrapRealApprox <$> rect) ^. rect2DPoints + CairoRender $ do + Cairo.rectangle x0 y0 x1 y1 + Cairo.fill + cairoSetColorRGBA32 lineColor + Cairo.setLineWidth $ unwrapRealApprox width + Cairo.setLineJoin Cairo.LineJoinMiter + Cairo.rectangle x0 y0 x1 y1 + Cairo.stroke + +--cairoSelectFont :: SelectFont -> GtkGUI model (Maybe FontExtents) +--cairoSelectFont font0 = runGtkStateGUI $ evalCairo $ do +-- let loop (bold,italic,oblique,syms) = \ case +-- [] -> (bold, italic, oblique, Strict.unwords $ syms []) +-- a:ax -> let w = Strict.toLower a in ax & case w of +-- w | w == Strict.pack "bold" -> loop (bold + 1, italic, oblique, syms) +-- w | w == Strict.pack "italic" -> loop (bold, italic + 1, oblique, syms) +-- w | w == Strict.pack "oblique" -> loop (bold, italic, oblique + 1, syms) +-- _ -> loop (bold, italic, oblique, syms . (a :)) +-- let zero = 0 :: Int +-- let one = 1 :: Int +-- let (bold,italic,oblique,font) = loop (0, 0, 0, id) $ Strict.words font0 +-- if italic > zero && oblique > zero || bold > one || italic > one || oblique > one +-- then return Nothing +-- else do +-- Cairo.selectFontFace font +-- (if italic > 0 then Cairo.FontSlantItalic else +-- if oblique > 0 then Cairo.FontSlantOblique else Cairo.FontSlantNormal) +-- (if bold > 0 then Cairo.FontWeightBold else Cairo.FontWeightNormal) +-- ext <- Cairo.fontExtents +-- return $ Just FontExtents +-- { fontExtentsAscent = RealApprox $ Cairo.fontExtentsAscent ext +-- , fontExtentsDescent = RealApprox $ Cairo.fontExtentsDescent ext +-- , fontExtentsHeight = RealApprox $ Cairo.fontExtentsHeight ext +-- , fontExtentsMaxXadvance = RealApprox $ Cairo.fontExtentsMaxXadvance ext +-- , fontExtentsMaxYadvance = RealApprox $ Cairo.fontExtentsMaxYadvance ext +-- } + +---------------------------------------------------------------------------------------------------- + +instance Managed GtkWindow where + windowVisible = gtkWindowVisible + visibleEvents = installEventHandler "visibleEvents" visibilityReaction + [Gtk.VisibilityNotifyMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Gtk.visibilityNotifyEvent" + vis <- Glib.on win Gtk.visibilityNotifyEvent $ + Gtk.eventVisibilityState >>= + liftIO . next . not . (== Gtk.VisibilityFullyObscured) >> + return False + return $ do + Glib.signalDisconnect vis + focusEvents = installEventHandler "focusEvents" focusReaction + [Gtk.FocusChangeMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Glib.focusInEvent" + focin <- Glib.on win Gtk.focusInEvent $ liftIO (next True) >> return False + logGUI "Glib.on Glib.focusOutEvent" + focout <- Glib.on win Gtk.focusOutEvent $ liftIO (next False) >> return False + return $ do + Glib.signalDisconnect focin + Glib.signalDisconnect focout + +instance CanResize GtkWindow where + resizeEvents = installEventHandler "resizeEvents" resizeReaction [] (\ _ _ _ -> return $ pure ()) + +data AnimationThreadControl + = AnimationThreadControl + { animationThreadAlive :: !Bool + , animationInitTime :: !UTCTime + } + +instance CanAnimate GtkWindow where + animationIsRunning = runGtkStateGUI $ + gets theAnimatorThread <&> \ case { Disconnected -> False; _ -> True; } + stepFrameEvents react = do + flip (installEventHandler "stepFrameEvents" animatorThread []) react $ \ logGUI env next -> do + --let rate = env & theAnimationFrameRate . currentConfig -- TODO: restore this!!! + let rate = 0.05 -- any slow rate + t0 <- getCurrentTime + t0ref <- newIORef AnimationThreadControl + { animationThreadAlive = True + , animationInitTime = t0 + } + logGUI "Glib.on Glib.timeoutAdd" + frame <- flip Glib.timeoutAdd (min 200 $ floor (1000.0 / rate)) $ do + AnimationThreadControl{animationThreadAlive=alive,animationInitTime=t0} <- readIORef t0ref + if not alive then return False else + diffUTCTime <$> getCurrentTime <*> pure t0 >>= next . realToFrac + -- + -- TODO: the 'next' function needs to be evaluated here at time 0, becuase 'timeoutAdd' does + -- not call it until after the first time step interval has passed. For slow animations, this + -- will cause a noticable delay between the time the 'stepFrameEvents' function is evaluated + -- and the first frame callback is evaluated. + return $ do + logGUI "Glib.signalDisconnect" + modifyIORef t0ref $ \ ctrl -> ctrl{ animationThreadAlive = False } + Glib.timeoutRemove frame + +instance CanKeyboard GtkWindow where + keyboardEvents = installEventHandler "keyboardEvents" keyHandler + [Gtk.KeyReleaseMask, Gtk.KeyPressMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Gtk.keyReleaseEvent" + press <- Glib.on win Gtk.keyReleaseEvent $ + handleKey False >>= liftIO . next >> return False + logGUI "Glib.on Gtk.keyPressEvent" + release <- Glib.on win Gtk.keyPressEvent $ + handleKey True >>= liftIO . next >> return False + return $ do + logGUI "Glib.signalDisconnect" + Glib.signalDisconnect press + Glib.signalDisconnect release + +instance CanMouse GtkWindow where + providedMouseDevices = return [] + mouseEvents = \ case + MouseButton -> installEventHandler "mouseButtonEvents" mouseHandler + [Gtk.ButtonPressMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Gtk.buttonPressEvent" + press <- Glib.on win Gtk.buttonPressEvent $ + handleMouse True >>= liftIO . next >> return False + release <- Glib.on win Gtk.buttonReleaseEvent $ + handleMouse False >>= liftIO . next >> return False + return $ do + logGUI "Glib.signalDisconnect" + Glib.signalDisconnect press + Glib.signalDisconnect release + MouseDrag -> installEventHandler "mouseDragEvents" mouseHandler + [Gtk.ButtonPressMask, Gtk.ButtonMotionMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Gtk.buttonPressEvent" + press <- Glib.on win Gtk.buttonPressEvent $ + handleMouse True >>= liftIO . next >> return False + logGUI "Glib.on Gtk.buttonReleaseEvent" + release <- Glib.on win Gtk.buttonReleaseEvent $ + handleMouse False >>= liftIO . next >> return False + logGUI "Glib.on Gtk.motionNotifyEvent" + button <- Glib.on win Gtk.motionNotifyEvent $ + handleCursor True >>= liftIO . next >> return False + return $ do + logGUI "Glib.signalDisconnect" + Glib.signalDisconnect press + Glib.signalDisconnect release + Glib.signalDisconnect button + MouseAll -> installEventHandler "mouseAllEvents" mouseHandler + [Gtk.PointerMotionMask, Gtk.ButtonMotionMask] $ \ logGUI env next -> do + let win = gtkWindow env + logGUI "Glib.on Gtk.motionNotifyEvent" + button <- newIORef False + press <- Glib.on win Gtk.buttonPressEvent $ + liftIO (writeIORef button False) >> + handleMouse True >>= liftIO . next >> return False + release <- Glib.on win Gtk.buttonReleaseEvent $ + liftIO (writeIORef button True) >> + handleMouse False >>= liftIO . next >> return False + motion <- Glib.on win Gtk.motionNotifyEvent $ + liftIO (readIORef button) >>= + handleCursor >>=liftIO . next >> return False + return $ do + logGUI "Glib.signalDisconnect" + Glib.signalDisconnect press + Glib.signalDisconnect release + Glib.signalDisconnect motion + +-- | This function enables an event handler, and takes a continuation which will be evaluated by +-- this function call to do the low-level work of install the event handler into the Gtk +-- window. This function also does the work of taking a 'Happlets.GUI.GUI' function to be evaluated +-- on each event, converting this function to a 'ConnectReact' function, and installing it into the +-- 'GtkWindow's internal state so that it can be actually evaluated every time the low-level event +-- handler is evaluated. The result is a function that can be used to instantiate any of the +-- "Happlets.GUI" module's event handler classes. +installEventHandler + :: String + -> Lens' GtkWindowState (ConnectReact event) + -> [Gtk.EventMask] + -> (LogGUI -> GtkWindowState -> (event -> IO Bool) -> IO (IO ())) + -> (event -> GtkGUI model ()) + -> GtkGUI model () +installEventHandler logString connectReact masks install react = do + logGUI <- mkLogger logString True + happ <- askHapplet + liftIO $ logGUI "runGtkStateGUI" + runGtkStateGUI $ do + env <- get + callback <- use connectReact + disconnect <- case callback of + ConnectReact{doDisconnect=disconnect} -> do + liftIO $ logGUI "-- event handler already installed" + return disconnect + Disconnected -> liftIO $ do + logGUI "-- install event handler" + disconnect <- install logGUI env $ \ event -> do + logGUI "lockGtkWindow" + lockGtkWindow (GtkUnlockedWin $ thisWindow env) $ do + stillAlive <- use connectReact >>= flip evalConnectReact event + unless stillAlive $ forceDisconnect connectReact + return stillAlive + logGUI $ "Gtk.widgetAddEvents " ++ show masks + Gtk.widgetAddEvents (gtkWindow env) masks + return $ liftIO $ do + logGUI $ "Gtk.widgetDelEvents " ++ show masks + Gtk.widgetDelEvents (gtkWindow env) masks + disconnect + liftIO $ logGUI "resizeReaction -- now enabled" + connectReact .= ConnectReact + { doReact = gtkRunHapplet happ (checkGUIContinue logGUI resizeReaction) . react + , doDisconnect = disconnect + } + +handleMouse :: Pressed -> Gtk.EventM Gtk.EButton Mouse +handleMouse upDown = do + logGUI <- mkLogger "handleMouse" True + (x, y) <- Gtk.eventCoordinates + button <- getMouseButton + mods <- packGtkModifiers <$> Gtk.eventModifierAll + let evt = Mouse "" upDown mods button (V2 (round x) (round y)) + liftIO $ logGUI $ "handleMouse " ++ show evt + return evt + +handleCursor :: Pressed -> Gtk.EventM Gtk.EMotion Mouse +handleCursor upDown = do + logGUI <- mkLogger "handleCursor" True + (x, y) <- Gtk.eventCoordinates + mods <- packGtkModifiers <$> Gtk.eventModifierAll + let evt = Mouse "" upDown mods MotionOnly (V2 (round x) (round y)) + liftIO $ logGUI $ "handleCursor " ++ show evt + return evt + +handleKey :: Pressed -> Gtk.EventM Gtk.EKey Keyboard +handleKey upDown = do + logGUI <- mkLogger "handleKey" True + key <- Gtk.eventKeyVal + mods <- packGtkModifiers <$> Gtk.eventModifierAll + let evt = RawKey upDown mods key + liftIO $ logGUI $ "handleKey " ++ show evt + return evt + +getMouseButton :: Gtk.EventM Gtk.EButton MouseButton +getMouseButton = Gtk.eventButton <&> \ case + Gtk.LeftButton -> LeftClick + Gtk.MiddleButton -> MiddleClick + Gtk.RightButton -> RightClick + Gtk.OtherButton{} -> SideClick + +packGtkModifiers :: [Gtk.Modifier] -> ModifierBits +packGtkModifiers = packModifiers . + ( (=<<) $ \ case + Gtk.Shift -> [Shift] + Gtk.Lock -> [CapsLock] + Gtk.Control -> [Ctrl] + Gtk.Alt -> [Alt1] + Gtk.Alt2 -> [Alt2] + Gtk.Super -> [Super1] + Gtk.Hyper -> [Super2] + _ -> [] + ) + +--screenMasksToGdkRegion :: [ScreenMask] -> (Int, Int) -> IO Gtk.Region +--screenMasksToGdkRegion masks (w, h) = do +-- logGUI <- mkLogger "screenMasksToGdkRegion" True +-- let center x w = let (a, r) = divMod w 2 in (x - a, x + a + r) +-- let int (SampCoord i) = fromIntegral i :: Int +-- let rect xa' ya' xb' yb' = +-- let xa = int $ min xa' xb' +-- xb = int $ max xa' xb' +-- ya = int $ min ya' yb' +-- yb = int $ max ya' yb' +-- w = xb - xa +-- h = yb - ya +-- in Gtk.Rectangle xa ya w h +-- region <- Gtk.regionNew +-- let union = Gtk.regionUnion region +-- let loop = \ case +-- [] -> return () +-- mask:masks -> case mask of +-- ScreenAll -> +-- Gtk.regionRectangle (Gtk.Rectangle 0 0 w h) >>= union +-- ScreenRect (V2 xa ya) (V2 xb yb) -> do +-- logGUI $ "Gtk.regionRectangle ScreenRect{ xa="++ +-- show xa++", ya="++show ya++", xb="++show xb++", yb="++show yb++" }" +-- Gtk.regionRectangle (rect xa ya xb yb) >>= union +-- loop masks +-- ScreenOval (V2 x y) w h -> do +-- let (xa, xb) = center x w +-- (ya, yb) = center y h +-- -- TODO: Gtk.regionPolygon with approximate oval shape if greater than a certain size. +-- logGUI $ "Gtk.regionRectangle " ++ ("ScreenOval{ x="++ +-- show xa++" y="++show ya++" xb="++show xb++" yb="++show yb++" }") +-- Gtk.regionRectangle (rect xa ya xb yb) >>= union +-- loop masks +-- ScreenTriangle (V2 xa ya) (V2 xb yb) (V2 xc yc) -> do +-- let points = [(int xa, int ya), (int xb, int yb), (int xc, int yc)] +-- logGUI $ "Gtk.regionPolygon "++show points +-- Gtk.regionPolygon points Gtk.WindingRule >>= union +-- loop masks +-- ScreenVertical x lo hi -> +-- Gtk.regionRectangle (rect x lo (x + 1) hi) >>= union >> loop masks +-- ScreenHorizontal y lo hi -> +-- Gtk.regionRectangle (rect lo y hi (y + 1)) >>= union >> loop masks +-- loop masks >> return region + +---- | Queues a redraw on the area of the window covered by the given list of +---- 'Happlets.Redraw.ScreenMask's. +--updateRegions :: Gtk.DrawWindow -> [ScreenMask] -> IO () +--updateRegions canvas masks = if null masks then return () else do +-- logGUI <- mkLogger "updateRegions" False +-- region <- Gtk.drawableGetSize canvas >>= screenMasksToGdkRegion masks +-- logGUI "Gtk.drawWindowInvalidateRegion" +-- Gtk.drawWindowInvalidateRegion canvas region True + +-- | Blit a 'Gtk.Pixmap' to some drawable canvas. +gdkBlit :: Gtk.DrawableClass canvas => canvas -> Gtk.Pixmap -> PixCoord -> IO () +--gdkBlit :: Gtk.DrawableClass canvas => canvas -> Gtk.Pixmap -> PixCoord -> [ScreenMask] -> IO () +gdkBlit canvas pixmap (V2 dx dy) = do + logGUI <- mkLogger "gdkBlit" True + --region <- screenMasksToGdkRegion masks (fromIntegral dx, fromIntegral dy) + (w, h) <- Gtk.drawableGetSize canvas + -- TODO: This creates an update region for the whole window. This needs to be made more efficient, + -- such that only the minimal updated region is redrawn. + region <- Gtk.regionNew + Gtk.regionRectangle (Gtk.Rectangle 0 0 w h) >>= Gtk.regionUnion region + logGUI $ "Gtk.gcNewWithValues " ++ show dx ++ ' ' : show dy + gc <- Gtk.gcNewWithValues canvas $ Gtk.newGCValues + { Gtk.tile = Just pixmap + , Gtk.fill = Gtk.Tiled + , Gtk.tsXOrigin = fromIntegral dx + , Gtk.tsYOrigin = fromIntegral dy + } + Gtk.gcSetClipRegion gc region + logGUI $ "Gtk.drawRectangle 0 0 " ++ show w ++ ' ' : show h + Gtk.drawRectangle canvas gc True 0 0 w h + --rects <- Gtk.regionGetRectangles region + --forM_ rects $ \ rect@(Gtk.Rectangle x y w h) -> do + -- logGUI $ "Gtk.drawRectangle canvas gc True (" ++ show rect ++ ")" + -- Gtk.drawRectangle canvas gc True (x + fromIntegral dx) (y + fromIntegral dy) w h + +---------------------------------------------------------------------------------------------------- + +-- | A 'GtkDrawing' is a function that produces a 'Diagrams.Core.Types.Diagram' from a +-- 'Diagrams.BoundingBox.BoundingBox'. Use the 'Diagrams.BoundingBox.BoundingBox' information to +-- inform the placement and scale of your diagram. +type GtkCairoDiagram = BoundingBox V2 Double -> Diagram Cairo + +-- | This is a 'Happlets.View.Redraw' type function specific to this Gtk+ back-end provider. +type GtkRedraw a = CairoRender a + +-- | This data type contains a pointer to an image buffer in memory, and also a function used to +-- perform some drawing to the pixel values. +data GtkImage + = GtkImage + { gtkPixmapMVar :: MVar Gtk.Pixmap + } + +instance CanBufferImages GtkWindow GtkImage CairoRender where + newImageBuffer (V2 (SampCoord w) (SampCoord h)) (CairoRender draw) = liftIO $ do + pixmap <- Gtk.pixmapNew (Nothing :: Maybe Gtk.Pixmap) + (fromIntegral w) (fromIntegral h) (Just 32) + Gtk.renderWithDrawable pixmap draw + mvar <- newMVar pixmap + return GtkImage + { gtkPixmapMVar = mvar + } + + resizeImageBuffer (GtkImage{gtkPixmapMVar=mvar}) (V2 w h) (CairoRender draw) = + liftIO $ modifyMVar mvar $ \ pixmap -> do + pixmap <- Gtk.pixmapNew (Just pixmap) (fromIntegral w) (fromIntegral h) (Just 32) + a <- Gtk.renderWithDrawable pixmap draw + return (pixmap, a) + + drawImage (GtkImage{gtkPixmapMVar=mvar}) (CairoRender draw) = + liftIO $ withMVar mvar $ flip Gtk.renderWithDrawable draw + + blitImage (GtkImage{gtkPixmapMVar=mvar}) offset = runGtkStateGUI $ do + gtkwin <- gets gtkWindow + canvas <- liftIO $ Gtk.widgetGetDrawWindow gtkwin + liftIO $ withMVar mvar $ \ pixmap -> gdkBlit canvas pixmap offset + + blitImageTo (GtkImage{gtkPixmapMVar=src}) (GtkImage{gtkPixmapMVar=targ}) offset = + liftIO $ withMVar src $ \ src -> withMVar targ $ \ targ -> gdkBlit targ src offset + +-- | This is a helpful function you can use for your 'Happlet.Control.controlRedraw' function to clear +-- the window with a background color, given by the four 'Prelude.Double' parameters for Red, Green, +-- Blue, and Alpha (in that order). +cairoClearCanvas :: Double -> Double -> Double -> Double -> Cairo.Render () +cairoClearCanvas r g b a = do + logGUI <- mkLogger "cairoClearCanvas" True + liftIO $ logGUI $ unwords $ show <$> [r,g,b,a] + op <- Cairo.getOperator + Cairo.setOperator Cairo.OperatorSource + Cairo.setSourceRGBA r g b a + Cairo.paint + Cairo.setOperator op + +-- | Use the Happlets-native color data type 'Happlets.Draw.Color.PackedRGBA32' to set the Cairo +-- "source" color in the Cairo context. +cairoSetColorRGBA32 :: PackedRGBA32 -> Cairo.Render () +cairoSetColorRGBA32 = unpackRGBA32Color >>> \ (r,g,b,a) -> Cairo.setSourceRGBA r g b a + +-- | Convert a 'GtkCairoDiagram', which is a type of 'Diagrams.Core.Types.Diagram', and convert it +-- to a Cairo 'Cairo.Render'-ing computation which can be used to set the 'controlView' of the +-- 'Controller'. +gtkCairoDiagram :: GtkCairoDiagram -> V2 Double -> Cairo.Render () +gtkCairoDiagram diagram size = snd $ renderDia Cairo + ( CairoOptions + { _cairoFileName = "" + , _cairoSizeSpec = dims size + , _cairoOutputType = RenderOnly + , _cairoBypassAdjust = True + } + ) (diagram $ fromCorners origin (P size)) + +---------------------------------------------------------------------------------------------------- + +-- | This is the Happlet back-end 'Happlets.Provider.Provider' which you must pass to +-- 'Happlets.GUI.runGUI' in the @main@ function of your Happlet program. +gtkHapplet :: Provider GtkWindow +gtkHapplet = Provider + { defaultConfig = Config + { theConfigErrorsOnLoad = [] + , theConfigFilePath = "" + , theRegisteredAppName = "Happlet" + , theWindowTitleBar = "Happlet" + , theBackgroundTransparency = Just 0.9 + , theBackgroundGreyValue = 1.0 + , theRecommendWindowPosition = (0, 30) + , theRecommendWindowSize = (800, 600) + , theAnimationFrameRate = 60.0 + , willDecorateWindow = True + , willQuitOnWindowClose = False + , willDeleteWindowOnClose = False + } + , doInitializeGUI = gtkInit + , doGUIEventLoopLaunch = gtkLaunchEventLoop + , doWindowNew = gtkNewWindow + , doWindowDelete = flip lockGtkWindow $ get >>= liftIO . deleteWin + , doWindowAttach = gtkAttachHapplet + } + +-- A static variable used to ensure the functions in this module only call 'gtkInit' once. +gtkInitCheck :: MVar Bool +gtkInitCheck = unsafePerformIO $ newMVar False +{-# NOINLINE gtkInitCheck #-} + +-- You must call this function prior to all evaluation of any GUI programming. This will call the +-- stateful IO functions that initialize the Gtk+ library. Be sure to call this only once. +gtkInit :: IO () +gtkInit = do + alreadyInitd <- readMVar gtkInitCheck + unless alreadyInitd $ do + logGUI <- mkLogger "gtkInit" True + logGUI "Gtk.initGUI" + Gtk.initGUI >>= mapM_ logGUI + modifyMVar_ gtkInitCheck $ return . const True + +-- | Launch the Gtk+ main event loop. This function will never return. If you fail to call this +-- function, your GUI will never run. +gtkLaunchEventLoop :: Config -> IO () +gtkLaunchEventLoop cfg = do + logGUI <- mkLogger "gtkEventLoop" True + let appName = cfg ^. registeredAppName + unless (Strict.null appName) $ do + logGUI $ "Glib.setProgramName " ++ show appName + Glib.setProgramName appName + logGUI $ "Glib.setApplicationName " ++ show appName + Glib.setApplicationName appName + logGUI "Gtk.mainGUI" + Gtk.mainGUI diff --git a/src/Happlets/Lib/Gtk/TestSuite.hs b/src/Happlets/Lib/Gtk/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Happlets/Lib/Gtk/TestSuite.hs @@ -0,0 +1,149 @@ +module Happlets.Lib.Gtk.TestSuite where + +import Happlets.Lib.Gtk + +import Control.Arrow + +import Linear.V2 + +import qualified Graphics.Rendering.Cairo as Cairo + +---------------------------------------------------------------------------------------------------- + +main :: IO () +main = happlet gtkHapplet $ do + registeredAppName .= "Happlets-Test" + windowTitleBar .= "Happlets Test" + recommendWindowSize .= (640, 480) + quitOnWindowClose .= True + + win <- newWindow + pulsecircle <- newHapplet PulseCircle + { thePulseCircleRadius = 20 + , thePulseCirclePosition = V2 0 0 + , thePulseCircleWindowSize = V2 640 480 + } + + redgrid <- newHapplet (RedGrid 64.0) + + let (changeToPulseCircle, changeToRedGrid) = + ( windowChangeHapplet pulsecircle $ pulseCircleGUI changeToRedGrid + , windowChangeHapplet redgrid $ redGridGUI changeToPulseCircle + ) + attachWindow True win pulsecircle $ pulseCircleGUI changeToRedGrid + launchGUIEventLoop + deleteWindow win + +---------------------------------------------------------------------------------------------------- + +newtype RedGrid = RedGrid { theRedGridScale :: RealApprox } + deriving (Eq, Ord, Show, Read) + +redGridScale :: Lens' RedGrid RealApprox +redGridScale = lens theRedGridScale $ \ a b -> a{ theRedGridScale = b } + +redGridDraw :: RealApprox -> PixSize -> CairoRender () +redGridDraw scale = fmap realToFrac >>> \ size@(V2 w h) -> + if scale <= 1 then clearScreen red else do + let (V2 centerX centerY) = (/ 2.0) <$> size + let around top center = + (takeWhile (>= 0) $ [1 ..] >>= \ i -> [center - scale * i :: RealApprox]) ++ + (takeWhile (< top) $ [0 ..] >>= \ i -> [center + scale * i :: RealApprox]) + let mkLine v2 top i = Line2D (Point2D $ v2 i 0) (Point2D $ v2 i top) + clearScreen (black & alphaChannel .~ 0.9) + forM_ (around w centerX) $ drawLine red 1.0 . mkLine V2 h + forM_ (around h centerY) $ drawLine red 1.0 . mkLine (flip V2) w + +redGridGUI :: GtkGUI RedGrid () -> PixSize -> GtkGUI RedGrid () +redGridGUI ctxSwitch _size = do + let draw = use redGridScale >>= onView . redGridDraw + resizeEvents $ const draw + mouseEvents MouseButton $ \ (Mouse _ _ _ button _) -> case button of + RightClick -> ctxSwitch + _ -> do + scale <- use redGridScale + redGridScale .= if scale <= 4.0 then 64.0 else scale / 2.0 + draw + +---------------------------------------------------------------------------------------------------- + +data PulseCircle + = PulseCircle + { thePulseCircleRadius :: !Double + , thePulseCirclePosition :: !(V2 Double) + , thePulseCircleWindowSize :: !PixSize + } + deriving (Eq, Ord, Show, Read) + +pulseCircleRadius :: Lens' PulseCircle Double +pulseCircleRadius = lens thePulseCircleRadius $ \ a b -> a{ thePulseCircleRadius = b } + +pulseCirclePosition :: Lens' PulseCircle (V2 Double) +pulseCirclePosition = lens thePulseCirclePosition $ \ a b -> a{ thePulseCirclePosition = b } + +pulseCircleWindowSize :: Lens' PulseCircle PixSize +pulseCircleWindowSize = lens thePulseCircleWindowSize $ \ a b -> a{ thePulseCircleWindowSize = b } + +type Radius = Double +type PenSize = Double +type Red = Double +type Green = Double +type Blue = Double +type Alpha = Double + +circle :: V2 Double -> Radius -> Red -> Green -> Blue -> Alpha -> CairoRender () +circle (V2 x y) radius red green blue alpha = CairoRender $ do + op <- Cairo.getOperator + Cairo.setOperator Cairo.OperatorSource + Cairo.setSourceRGBA red green blue alpha + Cairo.arc (x + 0.5) (y + 0.5) radius 0.0 (2.0 * pi) + Cairo.fill + Cairo.setOperator op + +pulseCircleGUI :: GtkGUI PulseCircle () -> PixSize -> GtkGUI PulseCircle () +pulseCircleGUI ctxSwitch initSize@(V2 (SampCoord w) (SampCoord h)) = do + -- Initialize the model such that the circle is placed in the middle of the window. + pulseCirclePosition .= V2 (realToFrac w / 2) (realToFrac h / 2) + pulseCircleWindowSize .= initSize + + -- Declare a function for drawing the model: + let drawDot clear + (PulseCircle{thePulseCircleRadius=oldR,thePulseCirclePosition=oldXY}) + (PulseCircle{thePulseCircleRadius=newR,thePulseCirclePosition=newXY}) = \ _size -> do + when clear $ clearScreen (black & alphaChannel .~ 0.9) + circle oldXY (max oldR newR + 1.0) 0.0 0.0 0.0 0.9 + circle newXY newR 0.0 0.0 1.0 1.0 + + -- Install the mouse event handling function. + mouseEvents MouseDrag $ \ (Mouse _ _ _ button newXY) -> case button of + RightClick -> ctxSwitch + _ -> do + old <- get + pulseCirclePosition .= (realToFrac <$> newXY) + new <- get + onView $ drawDot False old new + + -- On resize, simply redraw the window without modifying the model. We don't need to use the new + -- size information for the window. + resizeEvents $ \ newSize@(V2 newW newH) -> do + old <- get + let (V2 oldW oldH) = old ^. pulseCircleWindowSize + let (V2 x y ) = old ^. pulseCirclePosition + let f n new old = n * realToFrac new / realToFrac old + pulseCirclePosition .= V2 (f x newW oldW) (f y newH oldH) + pulseCircleWindowSize .= newSize + new <- get + onView $ drawDot True old new + + -- Install an animator thread which makes the radius of the circle as a function of time. + stepFrameEvents $ \ t -> do + old <- get + pulseCircleRadius .= 20 * sin (2*pi * realToFrac t) + 40 + new <- get + onView $ drawDot False old new + + -- Clear the window. If you don't do this, the behavior of what the initial window will look + -- like is not defined in the Happlets protocol. It could be a default solid color, or it could + -- be random garbage. + model <- get + onView $ drawDot True model model