hoodle-core 0.11 → 0.12

raw patch · 47 files changed

+2907/−897 lines, 47 filesdep +fsnotifydep +pureMD5dep +system-filepathdep ~hoodle-builderdep ~hoodle-parserdep ~hoodle-renderPVP ok

version bump matches the API change (PVP)

Dependencies added: fsnotify, pureMD5, system-filepath

Dependency ranges changed: hoodle-builder, hoodle-parser, hoodle-render, hoodle-types

API changes (from Hackage documentation)

Files

• LICENSE +681/−20
• csrc/XInput.h +110/−0
• csrc/c_initdevice.c +178/−23
• csrc/c_initdevice.h +5/−0
• hoodle-core.cabal +18/−10
• resource/menu.xml +10/−2
• src/Hoodle/Config.hs +20/−2
• src/Hoodle/Coroutine/ContextMenu.hs +97/−80
• src/Hoodle/Coroutine/Default.hs +110/−39
• src/Hoodle/Coroutine/Draw.hs +11/−35
• src/Hoodle/Coroutine/Eraser.hs +12/−11
• src/Hoodle/Coroutine/File.hs +120/−27
• src/Hoodle/Coroutine/Layer.hs +8/−7
• src/Hoodle/Coroutine/Link.hs +53/−23
• src/Hoodle/Coroutine/Mode.hs +7/−3
• src/Hoodle/Coroutine/Page.hs +1/−1
• src/Hoodle/Coroutine/Pen.hs +88/−45
• src/Hoodle/Coroutine/Scroll.hs +7/−5
• src/Hoodle/Coroutine/Select.hs +59/−35
• src/Hoodle/Coroutine/Select/Clipboard.hs +4/−3
• src/Hoodle/Coroutine/TextInput.hs +72/−12
• src/Hoodle/Coroutine/VerticalSpace.hs +3/−4
• src/Hoodle/Coroutine/Window.hs +3/−5
• src/Hoodle/Device.hsc +95/−45
• src/Hoodle/GUI.hs +10/−6
• src/Hoodle/GUI/Menu.hs +44/−31
• src/Hoodle/GUI/Reflect.hs +7/−9
• src/Hoodle/ModelAction/Clipboard.hs +4/−4
• src/Hoodle/ModelAction/ContextMenu.hs +19/−5
• src/Hoodle/ModelAction/File.hs +32/−6
• src/Hoodle/ModelAction/Pen.hs +47/−24
• src/Hoodle/ModelAction/Select.hs +13/−22
• src/Hoodle/ModelAction/Window.hs +53/−47
• src/Hoodle/Type/Canvas.hs +14/−7
• src/Hoodle/Type/Coroutine.hs +21/−19
• src/Hoodle/Type/Enum.hs +5/−1
• src/Hoodle/Type/Event.hs +74/−41
• src/Hoodle/Type/HoodleState.hs +32/−10
• src/Hoodle/Type/PageArrangement.hs +6/−4
• src/Hoodle/Type/Predefined.hs +4/−1
• src/Hoodle/Type/Widget.hs +95/−9
• src/Hoodle/Util.hs +2/−30
• src/Hoodle/View/Coordinate.hs +4/−1
• src/Hoodle/View/Draw.hs +190/−59
• src/Hoodle/Widget/Dispatch.hs +78/−0
• src/Hoodle/Widget/Layer.hs +156/−0
• src/Hoodle/Widget/PanZoom.hs +225/−124

@@ -1,25 +1,686 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.+Copyright (C) 2011-2013 Ian-Woo Kim -Copyright 2011-2013, Ian-Woo Kim. All rights reserved.+Hoodle 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. -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Hoodle 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. -* Redistributions of source code must retain the above copyright notice, this-  list of conditions and the following disclaimer.+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007 -* Redistributions in binary form must reproduce the above copyright notice,-  this list of conditions and the following disclaimer in the documentation-  and/or other materials provided with the distribution.+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+                            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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU 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 <http://www.gnu.org/licenses/>.++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:++    <program>  Copyright (C) <year>  <name of author>+    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+<http://www.gnu.org/licenses/>.++  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+<http://www.gnu.org/philosophy/why-not-lgpl.html>.

@@ -0,0 +1,110 @@+//+// WacomWebPlugin - An implementation of the Wacom Web API on Linux.+// Copyright (C) 2013  Zane Ashby <zane.a@demonastery.org>+//+// 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 <http://www.gnu.org/licenses/>.+//++//+// XInput Wrapper.+//++#ifndef __XINPUT_WRAPPER_H+#define __XINPUT_WRAPPER_H++// #include "common.h"+#include <stdlib.h>+#include <stdio.h>+#include <string.h>++#include <assert.h>++#include <stdbool.h>++#include <unistd.h>+#include <pthread.h>++#include <X11/Xlib.h>+#include <X11/extensions/XInput.h>+#include <X11/Xutil.h>++#ifdef DEBUG+#define debug printf+#else+#define debug(body, ...)+#endif+++// Helper macros, for returning results.+#define XINPUT(name, type) if (IS_IDENTIFIER(""#name)) { type##_TO_NPVARIANT(values->name, *result); return true; }+#define XINPUT_STRING(name) if (IS_IDENTIFIER(""#name)) { STRINGZ_TO_NPVARIANT(strdup(values->name), *result); return true; }++#define VALUATOR_ABSX     0+#define VALUATOR_ABSY     1+#define VALUATOR_PRESSURE 2+#define VALUATOR_TILTX    3+#define VALUATOR_TILTY    4++// extern NPClass BaseClass;++// Just about all of these values should be attainable from XInput.+typedef struct xinput_values_t {+  bool isWacom;+  bool isEraser;+  float pressure;+  long posX;+  long posY;+  float sysX;+  float sysY;+  long tabX;+  long tabY;+  float rotationDeg;+  float rotationRad;+  float tiltX;+  float tiltY;+  float tangentialPressure;+  long pointerType;+  char tabletModel[256];+  char tabletModelID[256];+} xinput_values_t;++// Any other global XInput wrapper state.+typedef struct xinput_state_t {+  int refcount;+  pthread_t thread;++  int screen_width, screen_height;++  // Store range of values for each valuator.+  float absx_min, absx_max;+  float absy_min, absy_max;+  float pressure_min, pressure_max;+  float tilt_min, tilt_max;++  int motionType;+  int buttonPressType;+  int buttonReleaseType;+  int proximityInType;+  int proximityOutType;+} xinput_state_t;++//+// Functions+//++void xinput_start();+void xinput_stop();+xinput_values_t *xinput_getValues();++#endif

@@ -2,10 +2,159 @@ #include <stdio.h> #include <string.h> -void initdevice( int* core, int* stylus, int* eraser, -                 char* corepointername, char* stylusname, char* erasername-               )++#include "XInput.h"++//+// Globals.+//++// Holds the values for the Wacom API.+xinput_values_t g_xinput_values = {+  .isWacom = true,+};++// Holds XInput wrapper state.+xinput_state_t g_xinput_state = {+  .refcount = 0,++  .thread = 0,++  .screen_width = 0,+  .screen_height = 0,++  // Valuator ranges.+  .absx_min = 0,+  .absx_min = 0,+  .absy_max = 1,+  .absy_max = 1,+  .pressure_min = 0,+  .pressure_max = 1,+  .tilt_min = 0,+  .tilt_max = 1,++  // XInput event types.+  .motionType = -1,+  .buttonPressType = -1,+  .buttonReleaseType = -1,+  .proximityInType = -1,+  .proximityOutType = -1,+};++//+// Functions.+//++static bool xinput_findDevices(Display *display, XDeviceInfo *stylus_info, XDeviceInfo *eraser_info) {+  int found = 0;++  int num;+  XDeviceInfo *devices = XListInputDevices(display, &num);++  Atom stylus = XInternAtom(display, "STYLUS", false);+  Atom eraser = XInternAtom(display, "ERASER", false);++  for (int i = 0; i < num; i++) {+    debug("Got device \"%s\"\n", devices[i].name);++    if (devices[i].type == stylus) {+      found++;++      // Fill tablet model here.+      snprintf(g_xinput_values.tabletModel, sizeof(g_xinput_values.tabletModel), "%s", devices[i].name);+      snprintf(g_xinput_values.tabletModelID, sizeof(g_xinput_values.tabletModelID), "%s", devices[i].name);++      debug("Found stylus.\n");++      memcpy(stylus_info, &devices[i], sizeof(XDeviceInfo));++      XAnyClassPtr any = (XAnyClassPtr)devices[i].inputclassinfo;++      for (int j = 0; j < devices[i].num_classes; j++) {+        if (any->class == ValuatorClass) {+          XValuatorInfoPtr v = (XValuatorInfoPtr)any;++          // X.+          g_xinput_state.absx_min = v->axes[VALUATOR_ABSX].min_value;+          g_xinput_state.absx_min = v->axes[VALUATOR_ABSX].max_value;+          debug("X valuator range: min=%d, max=%d\n", v->axes[VALUATOR_ABSX].min_value, v->axes[VALUATOR_ABSX].max_value);++          // Y.+          g_xinput_state.absy_min = v->axes[VALUATOR_ABSY].min_value;+          g_xinput_state.absy_min = v->axes[VALUATOR_ABSY].max_value;+          debug("Y valuator range: min=%d, max=%d\n", v->axes[VALUATOR_ABSY].min_value, v->axes[VALUATOR_ABSY].max_value);++          // Pressure.+          g_xinput_state.pressure_min = v->axes[VALUATOR_PRESSURE].min_value;+          g_xinput_state.pressure_max = v->axes[VALUATOR_PRESSURE].max_value;+          debug("Pressure valuator range: min=%d, max=%d\n", v->axes[VALUATOR_PRESSURE].min_value, v->axes[VALUATOR_PRESSURE].max_value);++          // Tilt. Assuming that the range is the same for X and Y...+          g_xinput_state.tilt_min = v->axes[VALUATOR_TILTX].min_value;+          g_xinput_state.tilt_max = v->axes[VALUATOR_TILTX].max_value;+          debug("Tilt valuator range: min=%d, max=%d\n", v->axes[VALUATOR_TILTX].min_value, v->axes[VALUATOR_TILTX].max_value);++          break;+        }++        any = (XAnyClassPtr)((char *)any + any->length);+      }+    } else if (devices[i].type == eraser) {+      found++;++      debug("Found eraser.\n");++      memcpy(eraser_info, &devices[i], sizeof(XDeviceInfo));+    }+  }++  XFreeDeviceList(devices);++  return (found == 2);+}+++void find_wacom( char* stylus_name, char* eraser_name) +{+  Display *display = XOpenDisplay(NULL); +  assert(display != NULL);++  g_xinput_state.screen_width = XWidthOfScreen(DefaultScreenOfDisplay(display));+  g_xinput_state.screen_height = XHeightOfScreen(DefaultScreenOfDisplay(display));++  XDeviceInfo stylus_info, eraser_info;++  if (!xinput_findDevices(display, &stylus_info, &eraser_info)) {+    fprintf(stderr, "Couldn't find device.\n");+  }+  else { +    printf("found stylus=%s \n", stylus_info.name ); +    printf("found eraser=%s \n", eraser_info.name ); +    strcpy(stylus_name, stylus_info.name);+    strcpy(eraser_name, eraser_info.name); +  }+  return ; +}++++void initdevice ( int* core+                , int* stylus+                , int* eraser+		, int* touch +                , char* corepointername+                , char* stylusname+                , char* erasername+		, char* touchname+                )+{+  // xinput_start(); ++  printf("initdevice : stylusname = %s\n", stylusname );+  printf("initdevice : erasername = %s\n", erasername ); +  printf("initdevice : touchname = %s\n", touchname );                      +   GList* dev_list;   GdkDevice* device;   dev_list = gdk_devices_list();@@ -30,6 +179,10 @@         // printf("got eraser\n");         (*eraser) = (int) device;       } +      if( !strcmp (device->name, touchname) ) { +        // printf("got eraser\n");+        (*touch) = (int) device;+      }      }      else {        if( !strcmp (device->name, corepointername) ) { @@ -43,24 +196,26 @@ }  -// void extEventCanvas( void* canvas ) {-/* Important note: we'd like ONLY the canvas window itself to receive-   XInput events, while its child window in the GDK hierarchy (also-   associated to the canvas widget) receives the core events.-   This way on_canvas_... will get both types of events -- otherwise,-   the proximity detection code in GDK is broken and we'll lose core-   events.-   -   Up to GTK+ 2.10, gtk_widget_set_extension_events() only sets-   extension events for the widget's main window itself; in GTK+ 2.11-   also traverses GDK child windows that belong to the widget-   and sets their extension events too. We want to avoid that.-   So we use gdk_input_set_extension_events() directly on the canvas.-*/-   -/*  // this causes GTK+ 2.11 bugs-  gtk_widget_set_extension_events(GTK_WIDGET(canvas),GDK_EXTENSION_EVENTS_ALL); -*/+void enable_touch( char* touch_name ) +{+  printf("enable touch: %s\n", touch_name ) ; +} -//  gdk_input_set_extension_events(GTK_WIDGET(canvas)->window, GDK_POINTER_MOTION_MASK | GDK_BUTTON_MOTION_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK, GDK_EXTENSION_EVENTS_ALL);-//}+void disable_touch( GdkDrawable *gdkwin, char* touch_name ) +{+  printf("disable touch: %s\n", touch_name ); +  /* Display *dpy = XOpenDisplay(NULL); +  XIEventMask eventmask ; +  Window win = GDK_DRAWABLE_XID(gdkwin) ; +  unsigned char mask[1] = { 0 } ; ++  eventmask.deviceid = 12 ; +  eventmask.make_len = sizeof(mask); +  eventmask.mask = mask ; + +  XISelectEvents (dpy,win,&eventmask,1); ++  XCloseDisplay(dpy); */ +  +}+

@@ -1,6 +1,11 @@ #include <gtk/gtk.h> #include <stdio.h> +void find_wacom( char* stylus_name, char* eraser_name ) ; + void initdevice( int* core, int* stylus, int* eraser,                   char* corepointername, char* stylusname, char* erasername );  +void enable_touch( char* touch_name ) ;++void disable_touch( char* touch_name ); 

@@ -1,11 +1,11 @@ Name:		hoodle-core-Version:	0.11+Version:	0.12 Synopsis:	Core library for hoodle Description: 	Hoodle is a pen notetaking program written in haskell.                  hoodle-core is the core library written in haskell and                  using gtk2hs Homepage:       http://ianwookim.org/hoodle-License: 	BSD3+License: 	GPL-3 License-file:	LICENSE Author:		Ian-Woo Kim Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>@@ -24,7 +24,7 @@  Library   hs-source-dirs: src-  ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans+  ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans    ghc-prof-options: -caf-all -auto-all    Build-Depends:   base == 4.*, @@ -40,11 +40,11 @@                    coroutine-object >= 0.2,                     transformers == 0.3.*,                    transformers-free == 1.0.*,-                   hoodle-types >= 0.2,-                   hoodle-parser >= 0.2,+                   hoodle-types >= 0.2.1,+                   hoodle-parser >= 0.2.1,                    xournal-parser >= 0.5.0.1,-                   hoodle-render >= 0.3.1,-                   hoodle-builder >= 0.2,+                   hoodle-render >= 0.3.2,+                   hoodle-builder >= 0.2.1,                    containers >= 0.4,                    template-haskell == 2.*,                    bytestring >= 0.9, @@ -63,7 +63,11 @@                    uuid >= 1.2.7,                     monad-loops >= 0.3,                     network, -                   poppler >= 0.12.2.2+                   poppler >= 0.12.2.2, +                   fsnotify >= 0.0.7, +                   system-filepath >= 0.4, +                   pureMD5 +   Exposed-Modules:                     Hoodle.Accessor                    Hoodle.Config@@ -121,14 +125,18 @@                    Hoodle.Util                    Hoodle.View.Coordinate                    Hoodle.View.Draw+                   Hoodle.Widget.Dispatch+                   Hoodle.Widget.Layer                     Hoodle.Widget.PanZoom   Other-Modules:                     Paths_hoodle_core   c-sources:                     csrc/c_initdevice.c+                   -- csrc/XInput.c   include-dirs:    csrc   install-includes:                     csrc/c_initdevice.h                    csrc/template-hsc-gtk2hs.h-  cc-options:      -Wno-pointer-to-int-cast-+                   csrc/XInput.h+  cc-options:      -Wno-pointer-to-int-cast -std=gnu99 -DDEBUG +  extra-libraries: X11 Xi dl pthread

@@ -20,6 +20,11 @@        <menuitem action="PRINTA" />                                <menuitem action="EXPORTA" />        <separator /> +       <menuitem action="SYNCA" /> +       <menuitem action="VERSIONA" />+       <menuitem action="SHOWREVA" />+       <menuitem action="SHOWIDA" />+       <separator />        <menuitem action="QUITA" />     </menu>     <menu action="EMA">@@ -105,7 +110,6 @@        <menuitem action="SELREGNA" />        <menuitem action="SELRECTA" />        <menuitem action="VERTSPA" />-       <menuitem action="HANDA" />        <separator />        <menu action="CLRA">           <menuitem action="BLACKA" />     @@ -141,11 +145,14 @@     </menu>     <menu action="OMA">        <menuitem action="UXINPUTA" />+       <menuitem action="HANDA" />        <menuitem action="SMTHSCRA" />        <menuitem action="POPMENUA" />         <menuitem action="EBDIMGA" />        <menuitem action="EBDPDFA" />-       <menuitem action="WIDGETTOGGLEA" />+       <menuitem action="FLWLNKA" />+       <menuitem action="TOGPANZOOMA" />+       <menuitem action="TOGLAYERA" />        <menuitem action="DCRDCOREA" />                                <menuitem action="ERSRTIPA" />                                <menuitem action="PRESSRSENSA" />                        @@ -214,6 +221,7 @@     <toolitem action="PENFINEA"       />         <toolitem action="PENMEDIUMA"       />                          <toolitem action="PENTHICKA"       />   + <!--   <placeholder name="PENDROPDOWN"   /> -->   <!--     <toolitem action="NOWIDTH"        /> -->      <separator />     <toolitem action="CLRPCKA"     />

@@ -39,12 +39,13 @@ getMaxUndo :: Config -> IO (Maybe Int) getMaxUndo c = C.lookup c "maxundo" -getPenDevConfig :: Config -> IO (Maybe String, Maybe String,Maybe String) +getPenDevConfig :: Config -> IO (Maybe String, Maybe String,Maybe String,Maybe String)  getPenDevConfig c = do    mcore <- C.lookup c "core"   mstylus <- C.lookup c "stylus"    meraser <- C.lookup c "eraser"-  return (mcore,mstylus,meraser)+  mtouch <- C.lookup c "touch"+  return (mcore,mstylus,meraser,mtouch)    getXInputConfig :: Config -> IO Bool  getXInputConfig c = do @@ -55,6 +56,23 @@                   "true" -> return True                   "false" -> return False                    _ -> error "cannot understand xinput in configfile"++getWidgetConfig :: Config -> IO (Bool, Bool) +getWidgetConfig c = do +    (mpanzoom :: Maybe String) <- C.lookup c "PanZoomWidget"+    (mlayer :: Maybe String) <- C.lookup c "LayerWidget"++    let panzoom = maybe True (parse "PanZoomWidget") mpanzoom +        layer = maybe True (parse "LayerWidget") mlayer+        +    print ("WidgetConfig =" ++ show (panzoom,layer) )+    return (panzoom,layer)+  where parse msg str = case str of+                          "true" -> True+                          "false" -> False +                          _ -> error ("cannot understand " ++ msg ++ " in configfile")++           {- getNetworkInfo :: Config -> IO (Maybe HoodleClipClientConfiguration)

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- |@@ -15,12 +16,17 @@ module Hoodle.Coroutine.ContextMenu where  -- from other packages++import Control.Concurrent+ import           Control.Applicative-import           Control.Category+-- import           Control.Category import           Control.Lens (view,set,(%~))-import           Control.Monad.State+import           Control.Monad.State hiding (mapM_,forM_) import           Data.Attoparsec  import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import           Data.Foldable (mapM_,forM_) import qualified Data.IntMap as IM import           Data.Monoid import           Data.UUID.V4 @@ -35,12 +41,13 @@ import           Data.Hoodle.BBox import           Data.Hoodle.Generic import           Data.Hoodle.Select-import           Data.Hoodle.Simple (SVG(..),Item(..),Link(..),hoodleID)+import           Data.Hoodle.Simple (SVG(..),Item(..),Link(..),hoodleID,defaultHoodle) import           Graphics.Hoodle.Render import           Graphics.Hoodle.Render.Item import           Graphics.Hoodle.Render.Type import           Graphics.Hoodle.Render.Type.HitTest import qualified Text.Hoodle.Parse.Attoparsec as PA+import           Text.Hoodle.Builder (builder) -- from this package  import           Hoodle.Accessor import           Hoodle.Coroutine.Commit @@ -60,21 +67,22 @@ import           Hoodle.Type.PageArrangement  import           Hoodle.Util ---import Prelude hiding ((.),id)+import Prelude hiding (mapM_)  + processContextMenu :: ContextMenuEvent -> MainCoroutine ()  processContextMenu (CMenuSaveSelectionAs ityp) = do    xst <- get-  case getSelectedItmsFromHoodleState xst of-    Nothing -> return ()-    Just hititms ->-      let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms -      in case ulbbox of -           Middle bbox -> -             case ityp of -               TypSVG -> exportCurrentSelectionAsSVG hititms bbox-               TypPDF -> exportCurrentSelectionAsPDF hititms bbox-           _ -> return () +  forM_ (getSelectedItmsFromHoodleState xst) +        (\hititms->  +           let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +           in case ulbbox of +                Middle bbox -> +                  case ityp of +                    TypSVG -> exportCurrentSelectionAsSVG hititms bbox+                    TypPDF -> exportCurrentSelectionAsPDF hititms bbox+                _ -> return () +        ) processContextMenu CMenuCut = cutSelection processContextMenu CMenuCopy = copySelection processContextMenu CMenuDelete = deleteSelection@@ -94,7 +102,7 @@ processContextMenu CMenuAutosavePage = do      xst <- get      pg <- getCurrentPageCurr -    maybe (return ()) liftIO $ do +    mapM_ liftIO $ do        hset <- view hookSet xst       customAutosavePage hset <*> pure pg  processContextMenu (CMenuLinkConvert nlnk) = @@ -121,36 +129,55 @@               commit . set hoodleModeState (SelectState nthdl)                 =<< (liftIO (updatePageAll (SelectState nthdl) xst))               invalidateAll -processContextMenu CMenuCreateALink = do -  liftIO $ putStrLn "create a link called"-  mfilename <- fileChooser FileChooserActionOpen Nothing-  case mfilename of -    Nothing -> return () -    Just fname -> do -      xst <- get -      case getSelectedItmsFromHoodleState xst of -        Nothing -> return () -        Just hititms -> -          let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms -          in case ulbbox of -               Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do -                 svg <- liftIO $ makeSVGFromSelection hititms bbox-                 uuid <- liftIO $ nextRandom-                 let uuidbstr = B.pack (show uuid) -                 deleteSelection -                 linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)  -               _ -> return () -processContextMenu CMenuCustom =  +processContextMenu CMenuCreateALink = +  fileChooser FileChooserActionOpen Nothing >>= mapM_ linkSelectionWithFile+processContextMenu CMenuAssocWithNewFile = do+  xst <- get +  let msuggestedact = view hookSet xst >>= fileNameSuggestionHook +  (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact +  +  fileChooser FileChooserActionSave msuggested >>=   +    mapM_ (\fp -> do +              b <- liftIO (doesFileExist fp)+              if b +                then okMessageBox "The file already exist!"+                else do +                  let action = mkIOaction $ \_ -> do                      +                        nhdl <- liftIO $ defaultHoodle   +                        (L.writeFile fp . builder) nhdl +                        createProcess (proc "hoodle" [fp]) +                        return (UsrEv ActionOrdered)+                  modify (tempQueue %~ enqueue action) +                  waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)+                  linkSelectionWithFile fp +                  return ()+          ) +processContextMenu CMenuCustom =  do     either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get    where action thdl = do               xst <- get -          case view gselSelected thdl of -            Nothing -> return () -            Just (_,tpg) -> do +          forM_ (view gselSelected thdl) +            (\(_,tpg) -> do                let hititms = (map rItem2Item . getSelectedItms) tpg  -              maybe (return ()) liftIO $ do -                hset <- view hookSet xst    -                customContextMenuHook hset <*> pure hititms+              mapM_ liftIO $ do hset <- view hookSet xst    +                                customContextMenuHook hset <*> pure hititms)+++--  | +linkSelectionWithFile :: FilePath -> MainCoroutine ()  +linkSelectionWithFile fname = do+  liftM getSelectedItmsFromHoodleState get >>=  +    mapM_ (\hititms -> +            let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +            in case ulbbox of +              Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do +                svg <- liftIO $ makeSVGFromSelection hititms bbox+                uuid <- liftIO $ nextRandom+                let uuidbstr = B.pack (show uuid) +                deleteSelection +                linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)  +              _ -> return () )+            -- |  exportCurrentSelectionAsSVG :: [RItem] -> BBox -> MainCoroutine () @@ -207,54 +234,44 @@                     menuitem3 <- menuItemNewWithLabel "Cut"                     menuitem4 <- menuItemNewWithLabel "Copy"                     menuitem5 <- menuItemNewWithLabel "Delete"+                    menuitem6 <- menuItemNewWithLabel "New File Linked Here"                     menuitem1 `on` menuItemActivate $   -                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG))+                      evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG)))                     menuitem2 `on` menuItemActivate $ -                      evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF))+                      evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF)))                     menuitem3 `on` menuItemActivate $ -                      evhandler (GotContextMenuSignal (CMenuCut))     +                      evhandler (UsrEv (GotContextMenuSignal (CMenuCut)))                     menuitem4 `on` menuItemActivate $    -                      evhandler (GotContextMenuSignal (CMenuCopy))+                      evhandler (UsrEv (GotContextMenuSignal (CMenuCopy)))                     menuitem5 `on` menuItemActivate $    -                      evhandler (GotContextMenuSignal (CMenuDelete))     +                      evhandler (UsrEv (GotContextMenuSignal (CMenuDelete)))+                    menuitem6 `on` menuItemActivate $ +                      evhandler (UsrEv (GotContextMenuSignal (CMenuAssocWithNewFile)))                     menuAttach menu menuitem1 0 1 1 2                      menuAttach menu menuitem2 0 1 2 3                     menuAttach menu menuitem3 1 2 0 1                                          menuAttach menu menuitem4 1 2 1 2                                          menuAttach menu menuitem5 1 2 2 3    -                    -                    maybe (return ()) (\mi -> menuAttach menu mi 1 2 4 5) =<< menuCreateALink evhandler sitms -                    +                    menuAttach menu menuitem6 1 2 3 4 +                    mapM_ (\mi -> menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms                      case sitms of                        sitm : [] -> do                          case sitm of                            RItemLink lnkbbx _msfc -> do                              let lnk = bbxed_content lnkbbx-                            maybe (return ()) -                                  (\urlpath -> do -                                    milnk <- menuOpenALink evhandler urlpath-                                    menuAttach menu milnk 0 1 3 4    -                                  )-                                  (urlParse ((B.unpack . link_location) lnk))+                            forM_ ((urlParse . B.unpack . link_location) lnk)+                                  (\urlpath -> do milnk <- menuOpenALink evhandler urlpath+                                                  menuAttach menu milnk 0 1 3 4 )                             case lnk of -                              Link i _typ lstr txt cmd rdr pos dim -> do -                                case urlParse (B.unpack lstr) of -                                  Nothing -> return ()-                                  Just (HttpUrl url) -> return ()-                                  Just (FileUrl file) -> do -                                    b <- doesFileExist file-                                    when b $ do -                                      bstr <- B.readFile file-                                      case parseOnly PA.hoodle bstr of -                                        Left str -> print str -                                        Right hdl -> do -                                          let uuid = view hoodleID hdl-                                              link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim--                                          menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) -                                          menuitemcvt `on` menuItemActivate $ do-                                            evhandler (GotContextMenuSignal (CMenuLinkConvert link))-                                          menuAttach menu menuitemcvt 0 1 4 5 +                              Link i _typ lstr txt cmd rdr pos dim ->  +                                convertLinkFromSimpleToDocID lnk >>=  +                                  mapM_ (\link -> do +                                    let LinkDocID _ uuid _ _ _ _ _ _ = link +                                    menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) +                                    menuitemcvt `on` menuItemActivate $ do+                                      evhandler (UsrEv (GotContextMenuSignal (CMenuLinkConvert link)))+                                    menuAttach menu menuitemcvt 0 1 4 5 +                                  )                                LinkDocID i lid file txt cmd rdr pos dim -> do                                  case (lookupPathFromId =<< view hookSet xstate) of                                   Nothing -> return () @@ -268,8 +285,8 @@                                           else do                                              let link = LinkDocID i lid (B.pack file') txt cmd rdr pos dim                                             menuitemcvt <- menuItemNewWithLabel ("Correct Path to " ++ show file') -                                            menuitemcvt `on` menuItemActivate $ do-                                              evhandler (GotContextMenuSignal (CMenuLinkConvert link))+                                            menuitemcvt `on` menuItemActivate $ +                                              evhandler (UsrEv (GotContextMenuSignal (CMenuLinkConvert link)))                                             menuAttach menu menuitemcvt 0 1 4 5                            _ -> return ()                        @@ -279,25 +296,25 @@                   Just ttl -> do                      custommenu <- menuItemNewWithLabel ttl                       custommenu `on` menuItemActivate $ -                      evhandler (GotContextMenuSignal (CMenuCustom))+                      evhandler (UsrEv (GotContextMenuSignal (CMenuCustom)))                     menuAttach menu custommenu 0 1 0 1                                   menuitem8 <- menuItemNewWithLabel "Autosave This Page Image"                 menuitem8 `on` menuItemActivate $ -                  evhandler (GotContextMenuSignal (CMenuAutosavePage))-                menuAttach menu menuitem8 1 2 3 4 +                  evhandler (UsrEv (GotContextMenuSignal (CMenuAutosavePage)))+                menuAttach menu menuitem8 1 2 4 5                                       runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0                  widgetShowAll menu                  menuPopup menu Nothing -                return ContextMenuCreated +                return (UsrEv ContextMenuCreated)          makeMenu evhdlr mn currcid cid            = when (currcid /= cid) $ do                n <- get               mi <- liftIO $ menuItemNewWithLabel ("Show here in cvs" ++ show cid)               liftIO $ mi `on` menuItemActivate $ -                evhdlr (GotContextMenuSignal (CMenuCanvasView cid pnum x y)) +                evhdlr (UsrEv (GotContextMenuSignal (CMenuCanvasView cid pnum x y)))               liftIO $ menuAttach mn mi 2 3 n (n+1)                put (n+1)      

@@ -1,11 +1,13 @@-{-# LANGUAGE ScopedTypeVariables, GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Default  -- Copyright   : (c) 2011-2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -17,14 +19,16 @@ import           Control.Applicative ((<$>)) import           Control.Category import           Control.Concurrent -import           Control.Lens (view,set,at,(.~),(%~))+import           Control.Lens (_1,over,view,set,at,(.~),(%~)) import           Control.Monad.Reader import           Control.Monad.State  import qualified Data.ByteString.Char8 as B import qualified Data.IntMap as M import           Data.IORef  import           Data.Maybe+import           Data.Time.Clock import           Graphics.UI.Gtk hiding (get,set)+import           System.Process  -- from hoodle-platform import           Control.Monad.Trans.Crtn.Driver import           Control.Monad.Trans.Crtn.Event @@ -65,15 +69,18 @@ import           Hoodle.Script import           Hoodle.Script.Hook import           Hoodle.Type.Canvas- import           Hoodle.Type.Coroutine import           Hoodle.Type.Enum import           Hoodle.Type.Event+import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Predefined import           Hoodle.Type.Undo import           Hoodle.Type.Window -import           Hoodle.Type.HoodleState+import           Hoodle.Type.Widget import           Hoodle.Widget.PanZoom+import           Hoodle.Widget.Layer+import           Hoodle.Widget.Dispatch  -- import Prelude hiding ((.), id) @@ -83,10 +90,10 @@               -> Maybe FilePath                -> Maybe Hook                -> Int -- ^ maxundo -              -> Bool -- ^ xinputbool +              -> (Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr)               -> Statusbar -- ^ status bar                -> IO (EventVar,HoodleState,UIManager,VBox)-initCoroutine devlst window mfname mhook maxundo xinputbool stbar = do +initCoroutine devlst window mfname mhook maxundo (xinputbool,usepz,uselyr) stbar = do    evar <- newEmptyMVar     putMVar evar Nothing    st0new <- set deviceList devlst  @@ -95,7 +102,9 @@             <$> emptyHoodleState    (ui,uicompsighdlr) <- getMenuUI evar       let st1 = set gtkUIManager ui st0new-      initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } +      initcvs = set (canvasWidgets.widgetConfig.doesUsePanZoomWidget) usepz+              . set (canvasWidgets.widgetConfig.doesUseLayerWidget) uselyr+              $ defaultCvsInfoSinglePage { _canvasId = 1 }        initcvsbox = CanvasSinglePage initcvs       st2 = set frameState (Node 1)              . updateFromCanvasInfoAsCurrentCanvas initcvsbox @@ -127,25 +136,24 @@   -- | initialization according to the setting -initialize :: MyEvent -> MainCoroutine ()+initialize :: AllEvent -> MainCoroutine () initialize ev = do       case ev of -      Initialized -> do -- additional initialization goes here-                        viewModeChange ToContSinglePage-                        -- pageZoomChange (Zoom 0.3)  -                        pageZoomChange FitWidth-                        xst <- get -                        let Just sbar = view statusBar xst -                        cxtid <- liftIO $ statusbarGetContextId sbar "test"-                        liftIO $ statusbarPush sbar cxtid "Hello there" -                        let ui = view gtkUIManager xst-                        liftIO $ toggleSave ui False-                        put (set isSaved True xst) +      UsrEv Initialized -> do -- additional initialization goes here+        viewModeChange ToContSinglePage+        pageZoomChange FitWidth+        xst <- get +        let Just sbar = view statusBar xst +        cxtid <- liftIO $ statusbarGetContextId sbar "test"+        liftIO $ statusbarPush sbar cxtid "Hello there" +        let ui = view gtkUIManager xst+        liftIO $ toggleSave ui False+        put (set isSaved True xst)        _ -> do ev' <- nextevent-              initialize ev'+              initialize (UsrEv ev')  -- |-guiProcess :: MyEvent -> MainCoroutine ()+guiProcess :: AllEvent -> MainCoroutine () guiProcess ev = do    initialize ev   changePage (const 0)@@ -183,27 +191,52 @@           (PenWork,PenButton3) -> do              updateXState (return . set isOneTimeSelectMode YesBeforeSelect)             modeChange ToSelectMode-            selectLassoStart cid pcoord+            selectLassoStart PenButton3 cid pcoord           (PenWork,EraserButton) -> eraserStart cid pcoord+          (PenWork,_) -> return ()            (EraserWork,_)      -> eraserStart cid pcoord            (HighlighterWork,_) -> highlighterStart cid pcoord           (VerticalSpaceWork,PenButton1) -> verticalSpaceStart cid pcoord            (VerticalSpaceWork,_) -> return () -    PenMove cid pcoord -> notifyLink cid pcoord+    TouchDown cid pcoord -> touchStart cid pcoord +    PenMove cid pcoord -> disableTouch >> notifyLink cid pcoord       _ -> defaultEventProcess r1 ++disableTouch :: MainCoroutine () +disableTouch = do +    xst <- get +    let devlst = view deviceList xst +    let b = view (settings.doesUseTouch) xst +    when b $ do         +      let nxst = set (settings.doesUseTouch) False xst +      doIOaction $ \_ -> do+        setToggleUIForFlag "HANDA" (settings.doesUseTouch) nxst+        let touchstr = dev_touch_str devlst+        -- ad hoc+        when (touchstr /= "touch") $ do +          readProcess "xinput" [ "disable", touchstr ] "" +          return ()+        -- +        return (UsrEv ActionOrdered)+      waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)+      put nxst+++ -- | selectMode :: MainCoroutine ()  selectMode = do    r1 <- nextevent    case r1 of -    PenDown cid _pbtn pcoord -> do +    PenDown cid pbtn pcoord -> do        ptype <- liftM (view (selectInfo.selectType)) get       case ptype of -        SelectRectangleWork -> selectRectStart cid pcoord -        SelectRegionWork -> selectLassoStart cid pcoord+        SelectRectangleWork -> selectRectStart pbtn cid pcoord +        SelectRegionWork -> selectLassoStart pbtn cid pcoord          _ -> return ()-    PenMove cid pcoord -> notifyLink cid pcoord +    PenMove cid pcoord -> disableTouch >> notifyLink cid pcoord +    TouchDown cid pcoord -> touchStart cid pcoord          PenColorChanged c -> do modify (penInfo.currentTool.penColor .~ c)                             selectPenColorChanged c     PenWidthChanged v -> do @@ -214,15 +247,14 @@   -- |-defaultEventProcess :: MyEvent -> MainCoroutine ()+defaultEventProcess :: UserEvent -> MainCoroutine () defaultEventProcess (UpdateCanvas cid) = invalidate cid    defaultEventProcess (Menu m) = menuEventProcess m defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v defaultEventProcess (VScrollBarStart cid v) = vscrollStart cid v  defaultEventProcess PaneMoveStart = paneMoveStart -defaultEventProcess (CanvasConfigure cid w' h') = -  doCanvasConfigure cid (CanvasDimension (Dim w' h'))+defaultEventProcess (CanvasConfigure cid w' h') = doCanvasConfigure cid (CanvasDimension (Dim w' h')) defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode defaultEventProcess ToSelectMode = modeChange ToSelectMode  defaultEventProcess ToSinglePage = viewModeChange ToSinglePage@@ -251,10 +283,14 @@         pgs = view gpages hdl          cpage = getPageFromGHoodleMap pgnum hdl         cbkg = view gbackground cpage-        nbkg -          | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty }-          | otherwise = cbkg -        npage = set gbackground nbkg cpage +        bstystr = convertBackgroundStyleToByteString bsty +        -- for the time being, I replace any background to solid background+        getnbkg :: RBackground -> RBackground +        getnbkg (RBkgSmpl c _ _) = RBkgSmpl c bstystr Nothing +        getnbkg (RBkgPDF _ _ _ _ _) = RBkgSmpl "white" bstystr Nothing +        getnbkg (RBkgEmbedPDF _ _ _) = RBkgSmpl "white" bstystr Nothing +        -- +        npage = set gbackground (getnbkg cbkg) cpage          npgs = set (at pgnum) (Just npage) pgs          nhdl = set gpages npgs hdl      modeChange ToViewAppendMode     @@ -269,6 +305,32 @@     Nothing -> liftIO $ writeIORef ref Nothing     Just fp -> liftIO $ writeIORef ref (Just (uuid ++ "," ++ fp)) defaultEventProcess (GotLink mstr (x,y)) = gotLink mstr (x,y)    +defaultEventProcess (Sync ctime) = do +  xst <- get+  case view (hoodleFileControl.lastSavedTime) xst of +    Nothing -> return ()+    Just otime -> do +      let dtime = diffUTCTime ctime otime+      if dtime < dtime_bound * 10 +        then return () +        else do +          let ioact = mkIOaction $ \evhandler -> do +                postGUISync (evhandler (UsrEv FileReloadOrdered))+                return (UsrEv ActionOrdered)+          modify (tempQueue %~ enqueue ioact)+defaultEventProcess FileReloadOrdered = fileReload +defaultEventProcess (CustomKeyEvent str) = +  if str == "[]:\"Super_L\"" +  then do+    xst <- liftM (over (settings.doesUseTouch) not) get +    put xst +    let action = mkIOaction $ \_evhandler -> do +          setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst+          return (UsrEv ActionOrdered)+    modify (tempQueue %~ enqueue action)+    waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)    +    toggleTouch+  else return () defaultEventProcess ev = -- for debugging                          do liftIO $ putStrLn "--- no default ---"                             liftIO $ print ev @@ -306,6 +368,11 @@ menuEventProcess MenuSaveAs = fileSaveAs menuEventProcess MenuReload = fileReload  menuEventProcess MenuExport = fileExport +menuEventProcess MenuStartSync = fileStartSync+menuEventProcess MenuVersionSave = fileVersionSave +menuEventProcess MenuShowRevisions = fileShowRevisions+menuEventProcess MenuShowUUID = fileShowUUID+--  menuEventProcess MenuCut = cutSelection menuEventProcess MenuCopy = copySelection menuEventProcess MenuPaste = pasteToSelection@@ -331,10 +398,12 @@   if b     then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases     else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases+menuEventProcess MenuUseTouch = toggleTouch menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" (settings.doesSmoothScroll) >> return () menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return () menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return () menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return ()+menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return ()   menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick @@ -361,14 +430,14 @@     modify (set hoodleModeState (ViewAppendState nhdl))     invalidateAll  menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground-menuEventProcess MenuWidgetToggle = togglePanZoom+menuEventProcess MenuTogglePanZoomWidget = (togglePanZoom . view (currentCanvas._1)) =<< get +menuEventProcess MenuToggleLayerWidget = (toggleLayer . view (currentCanvas._1)) =<< get  menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m    -- |  colorPick :: MainCoroutine ()  colorPick = do mc <- colorPickerBox "Pen Color" -               liftIO $ print mc                 maybe (return ())                        (\c->modify (penInfo.currentTool.penColor .~ c))                       mc @@ -385,7 +454,7 @@    modify (tempQueue %~ enqueue (action pcolor)) >> go    where      action pcolor = -      Left . ActionOrder $ +      mkIOaction $                 \_evhandler -> do                   dialog <- colorSelectionDialogNew msg                  csel <- colorSelectionDialogGetColor dialog@@ -401,8 +470,10 @@                               return (Just (colorConvert clr))                          _ -> return Nothing                   widgetDestroy dialog -                 return (ColorChosen mc)+                 return (UsrEv (ColorChosen mc))     go = do r <- nextevent                                case r of                ColorChosen mc -> return mc +              UpdateCanvas cid -> -- this is temporary+                invalidateInBBox Nothing Efficient cid >> go               _ -> go 

@@ -31,6 +31,8 @@ import           Hoodle.Type.Alias import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum+import           Hoodle.Type.Event import           Hoodle.Type.PageArrangement import           Hoodle.Type.HoodleState import           Hoodle.View.Draw@@ -115,7 +117,7 @@  -- |  invalidateAll :: MainCoroutine () -invalidateAll = invalidateAllInBBox Nothing Clear +invalidateAll = invalidateAllInBBox Nothing Clear >> liftIO (putStrLn "The SLOW invalidateAll Called")   -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () @@ -138,25 +140,6 @@                      paint                       xformfunc                       rndr -{-      --- | Drawing temporary gadgets more generally-invalidateTempGen :: CanvasId -> Surface -> Render () -> Render () -                     -> MainCoroutine ()-invalidateTempGen cid tempsurface xformfunc rndr = do -    xst <- get -    selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst -  where fsingle xstate cvsInfo = do -          let canvas = view drawArea cvsInfo-              pnum = PageNum . view currentPageNum $ cvsInfo -          geometry <- liftIO $ getCanvasGeometryCvsId cid xstate-          win <- liftIO $ widgetGetDrawWindow canvas-          liftIO $ renderWithDrawable win $ do   -                     xformfunc -                     setSourceSurface tempsurface 0 0 -                     setOperator OperatorSource -                     paint -                     rndr --}  -- | Drawing temporary gadgets with coordinate based on base page @@ -176,25 +159,18 @@                      paint                       xformfunc                       rndr -{-      --- | Drawing using layer buffer- invalidateWithBuf :: CanvasId -> MainCoroutine () -invalidateWithBuf = invalidateWithBufInBBox Nothing-  --- | Drawing using layer buffer in BBox   -invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () -invalidateWithBufInBBox mbbox cid =  -  invalidateGeneral cid mbbox drawBuf drawSelBuf drawContHoodleBuf drawContHoodleSelClearly--}- -- | check current canvas id and new active canvas id and invalidate if it's changed. - chkCvsIdNInvalidate :: CanvasId -> MainCoroutine ()  chkCvsIdNInvalidate cid = do    currcid <- liftM (getCurrentCanvasId) get    when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll)   --- --+-- | +waitSomeEvent :: (UserEvent -> Bool) -> MainCoroutine UserEvent +waitSomeEvent p = do +    r <- nextevent+    case r of +      UpdateCanvas cid -> -- this is temporary+                          invalidateInBBox Nothing Efficient cid >> waitSomeEvent p  +      _ -> if  p r then return r else waitSomeEvent p  

@@ -24,21 +24,22 @@ import Graphics.Hoodle.Render.Type.Item  import Graphics.Hoodle.Render.Util.HitTest -- +import Hoodle.Accessor+import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.Pen +import Hoodle.Device+import Hoodle.ModelAction.Page+import Hoodle.ModelAction.Eraser+import Hoodle.ModelAction.Layer+import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.Coroutine import Hoodle.Type.Canvas import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement-import Hoodle.Device import Hoodle.View.Coordinate import Hoodle.View.Draw-import Hoodle.Coroutine.Draw-import Hoodle.Coroutine.Commit-import Hoodle.Accessor-import Hoodle.ModelAction.Page-import Hoodle.ModelAction.Eraser-import Hoodle.ModelAction.Layer-import Hoodle.Coroutine.Pen  --  -- |@@ -63,7 +64,7 @@     xst <- get     boxAction (f r xst) . getCanvasInfo cid $ xst    where -    f :: (ViewMode a) => MyEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()+    f :: (ViewMode a) => UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()     f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact                                   (moveact xstate cvsInfo) upact     defact = eraserProcess cid pnum geometry itms (x0,y0)@@ -80,8 +81,8 @@               dim         = view gdimension page               pgnum       = view currentPageNum cvsInfo               currlayer = getCurrentLayer page-          let (newitms,maybebbox1) = St.runState (eraseHitted hittestitem) Nothing-              maybebbox = fmap (flip inflate 2.0) maybebbox1+          let (newitms,maybebbox) = St.runState (eraseHitted hittestitem) Nothing+              -- maybebbox = fmap (flip inflate 2.0) maybebbox1           newlayerbbox <- liftIO . updateLayerBuf dim maybebbox                            . set gitems newitms $ currlayer            let newpagebbox = adjustCurrentLayer newlayerbbox page 

@@ -17,22 +17,29 @@ module Hoodle.Coroutine.File where  -- from other packages+import           Control.Applicative ((<$>),(<*>))+import           Control.Concurrent import           Control.Lens (view,set,over,(%~)) import           Control.Monad.Loops import           Control.Monad.State hiding (mapM) import           Control.Monad.Trans.Either import           Data.ByteString (readFile) import           Data.ByteString.Base64 -import           Data.ByteString.Char8 as B (pack)+import           Data.ByteString.Char8 as B (pack,unpack) import qualified Data.ByteString.Lazy as L+import           Data.Digest.Pure.MD5 (md5) import           Data.Maybe import qualified Data.IntMap as IM+import           Data.Time.Clock+import           Data.UUID.V4 +import           Filesystem.Path.CurrentOS (decodeString, encodeString) import           Graphics.GD.ByteString  import           Graphics.Rendering.Cairo import           Graphics.UI.Gtk hiding (get,set) import           System.Directory import           System.Exit  import           System.FilePath+import qualified System.FSNotify as FS import           System.Process  -- from hoodle-platform import           Control.Monad.Trans.Crtn@@ -53,6 +60,7 @@ import           Hoodle.Coroutine.Commit import           Hoodle.Coroutine.Mode  import           Hoodle.Coroutine.Scroll+import           Hoodle.Coroutine.TextInput import           Hoodle.ModelAction.File import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page@@ -64,6 +72,7 @@ -- import           Hoodle.Type.Alias import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event hiding (TypSVG) import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement@@ -72,29 +81,20 @@ import Prelude hiding (readFile,concat,mapM)  --- | -waitSomeEvent :: (MyEvent -> Bool) -> MainCoroutine MyEvent -waitSomeEvent p = do -    r <- nextevent-    case r of -      UpdateCanvas cid -> -- this is temporary-                          invalidateInBBox Nothing Efficient cid >> waitSomeEvent p  -      _ -> if  p r then return r else waitSomeEvent p   - -- | okMessageBox :: String -> MainCoroutine ()  okMessageBox msg = modify (tempQueue %~ enqueue action)                     >> waitSomeEvent (\x->case x of GotOk -> True ; _ -> False)                     >> return ()    where -    action = Left . ActionOrder $ +    action = mkIOaction $                 \_evhandler -> do                   dialog <- messageDialogNew Nothing [DialogModal]                    MessageQuestion ButtonsOk msg                   _res <- dialogRun dialog                   widgetDestroy dialog -                 return GotOk +                 return (UsrEv GotOk)  -- |  okCancelMessageBox :: String -> MainCoroutine Bool @@ -105,7 +105,7 @@     p _ = False      q (OkCancel b) = b      q _ = False -    action = Left . ActionOrder $ +    action = mkIOaction $                 \_evhandler -> do                   dialog <- messageDialogNew Nothing [DialogModal]                    MessageQuestion ButtonsOkCancel msg @@ -114,7 +114,7 @@                            ResponseOk -> True                            _ -> False                  widgetDestroy dialog -                 return (OkCancel b)+                 return (UsrEv (OkCancel b))  -- |  fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) @@ -132,7 +132,7 @@               UpdateCanvas cid -> -- this is temporary                                   invalidateInBBox Nothing Efficient cid >> go                 _ -> go -    action win mrf = Left . ActionOrder $ \_evhandler -> do +    action win mrf = mkIOaction $ \_evhandler -> do        dialog <- fileChooserDialogNew Nothing (Just win) choosertyp                    [ ("OK", ResponseOk)                    , ("Cancel", ResponseCancel) ]@@ -150,7 +150,7 @@               ResponseCancel -> return Nothing                _ -> putStrLn "??? in fileOpen" >> return Nothing        widgetDestroy dialog-      return (FileChosen mr)+      return (UsrEv (FileChosen mr))  -- |  askIfSave :: MainCoroutine () -> MainCoroutine () @@ -195,13 +195,9 @@         -- this is rather temporary not to make mistake          if takeExtension filename == ".hdl"            then do -             let hdl = (rHoodle2Hoodle . getHoodle) xstate -             liftIO . L.writeFile filename . builder $ hdl-             put . set isSaved True $ xstate -             let ui = view gtkUIManager xstate-             liftIO $ toggleSave ui False-             S.afterSaveHook filename hdl-           else fileExtensionInvalid (".hdl","save") >> fileSaveAs +             put =<< (liftIO (saveHoodle xstate))+             (S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) xstate+          else fileExtensionInvalid (".hdl","save") >> fileSaveAs    -- | interleaving a monadic action between each pair of subsequent actions@@ -233,6 +229,45 @@         liftIO (renderjob hdl filename)   +-- | +fileStartSync :: MainCoroutine ()+fileStartSync = do +   +  xst <- get +  let mf = (,) <$> view (hoodleFileControl.hoodleFileName) xst <*> view (hoodleFileControl.lastSavedTime) xst +  -- liftIO $ print mf +  maybe (return ()) (\(filename,lasttime) -> action filename lasttime) mf  +  --  fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action +  where  +    action filename lasttime  = do +      let ioact = mkIOaction $ \evhandler ->do +            forkIO $ do +              FS.withManager $ \wm -> do +                origfile <- canonicalizePath filename +                let (filedir,_) = splitFileName origfile+                print filedir +                FS.watchDir wm (decodeString filedir) (const True) $ \ev -> do +                  let mchangedfile = case ev of +                        FS.Added fp _ -> Just (encodeString fp)+                        FS.Modified fp _ -> Just (encodeString fp)+                        FS.Removed fp _ -> Nothing +                  print mchangedfile +                  case mchangedfile of +                    Nothing -> return ()+                    Just changedfile -> do                       +                      let changedfilename = takeFileName changedfile +                          changedfile' = (filedir </> changedfilename)+                      if changedfile' == origfile +                        then do +                          ctime <- getCurrentTime +                          evhandler (UsrEv (Sync ctime))+                        else return () ++                let sec = 1000000+                forever (threadDelay (100 * sec))+            return (UsrEv ActionOrdered)+      modify (tempQueue %~ enqueue ioact) + -- | need to be merged with ContextMenuEventSVG exportCurrentPageAsSVG :: MainCoroutine () exportCurrentPageAsSVG = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action @@ -481,7 +516,7 @@             case r of                LaTeXInput input -> return input                _ -> go -    action = Left . ActionOrder $ +    action = mkIOaction $                 \_evhandler -> do                   dialog <- messageDialogNew Nothing [DialogModal]                    MessageQuestion ButtonsOkCancel "latex input"@@ -505,12 +540,12 @@                      case excode of                         ExitSuccess -> do                           svg <- readFile (tdir </> "latextest.svg")-                         return (LaTeXInput (Just (B.pack l,svg)))-                       _ -> return (LaTeXInput Nothing)+                         return (UsrEv (LaTeXInput (Just (B.pack l,svg))))+                       _ -> return (UsrEv (LaTeXInput Nothing))                     _ -> do                       widgetDestroy dialog-                     return (LaTeXInput Nothing)+                     return (UsrEv (LaTeXInput Nothing))     afteraction (latex,svg) = do        xstate <- get        let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate@@ -643,3 +678,61 @@   modeChange ToViewAppendMode   commit (set hoodleModeState (ViewAppendState nhdl) xst)   invalidateAll   +  +-- | +fileVersionSave :: MainCoroutine () +fileVersionSave = do +    hdl <- liftM (rHoodle2Hoodle . getHoodle ) get+    minput <- textInputDialog+    doIOaction $ \_evhandler -> do +          putStrLn "version save"+          tdir <- getTemporaryDirectory +          hdir <- getHomeDirectory+          uuid <- nextRandom+          let uuidstr = show uuid +              tempfile = tdir </> uuidstr <.> "hdl"+              hdlbstr = builder hdl +          L.writeFile tempfile hdlbstr+          ctime <- getCurrentTime +          let idstr = B.unpack (view hoodleID hdl)+              md5str = show (md5 hdlbstr)+              nfilename = "UUID_"++idstr++"_MD5Digest_"++md5str++"_ModTime_"++ show ctime <.> "hdl"+              vcsdir = hdir </> ".hoodle.d" </> "vcs"+          b <- doesDirectoryExist vcsdir +          unless b $ createDirectory vcsdir+          renameFile tempfile (vcsdir </> nfilename)  +          --+          let txtstr = maybe "" id minput       +          -- +          return (UsrEv (GotRevision md5str txtstr))+    -- modify (tempQueue %~ enqueue action) +    r <- waitSomeEvent (\x -> case x of GotRevision _ _ -> True ; _ -> False )+    let GotRevision md5str txtstr = r          +        nrev = Revision (B.pack md5str) (B.pack txtstr)+    modify (\xst -> let hdlmodst = view hoodleModeState xst +                    in case hdlmodst of +                         ViewAppendState rhdl -> +                           let nrhdl = over grevisions (<> [nrev]) rhdl +                           in set hoodleModeState (ViewAppendState nrhdl) xst +                         SelectState thdl -> +                           let nthdl = over gselRevisions (<> [nrev]) thdl+                           in set hoodleModeState (SelectState nthdl) xst)+    commit_ ++fileShowRevisions :: MainCoroutine ()+fileShowRevisions = do +  hdl <- liftM getHoodle get  +  let revs = view grevisions hdl+      revstrs = unlines $ map (\rev -> B.unpack (view revmd5 rev) ++ ":" ++ B.unpack (view revtxt rev)) revs+  okMessageBox revstrs+  +fileShowUUID :: MainCoroutine ()+fileShowUUID = do +  hdl <- liftM getHoodle get  +  let uuidstr = view ghoodleID hdl+  okMessageBox (B.unpack uuidstr)+  ++  +  +  

@@ -5,7 +5,7 @@ -- Module      : Hoodle.Coroutine.Layer  -- Copyright   : (c) 2011-2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -28,6 +28,7 @@ --  import Hoodle.Accessor import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.Draw import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.Type.Alias @@ -54,7 +55,7 @@ -- |   makeNewLayer :: MainCoroutine () -makeNewLayer = layerAction newlayeraction >>= commit +makeNewLayer = layerAction newlayeraction >>= commit >> invalidateAll    where newlayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 emptylyr = emptyRLayer @@ -64,7 +65,7 @@                   gotoNextLayer :: MainCoroutine ()-gotoNextLayer = layerAction nextlayeraction >>= put+gotoNextLayer = layerAction nextlayeraction >>= put >> invalidateAll    where nextlayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveRight lyrzipper @@ -72,7 +73,7 @@           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst    gotoPrevLayer :: MainCoroutine ()-gotoPrevLayer = layerAction prevlayeraction >>= put+gotoPrevLayer = layerAction prevlayeraction >>= put >> invalidateAll    where prevlayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveLeft lyrzipper @@ -81,7 +82,7 @@   gotoLayerAt :: Int -> MainCoroutine ()-gotoLayerAt n = layerAction gotoaction >>= put+gotoLayerAt n = layerAction gotoaction >>= put >> invalidateAll    where gotoaction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveTo n lyrzipper @@ -90,7 +91,7 @@   deleteCurrentLayer :: MainCoroutine ()-deleteCurrentLayer = layerAction deletelayeraction >>= commit+deleteCurrentLayer = layerAction deletelayeraction >>= commit >> invalidateAll    where deletelayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = deleteCurrent lyrzipper @@ -117,7 +118,7 @@         ResponseOk ->  do           liftIO $ widgetDestroy dialog           newnum <- liftIO (readIORef lref)-          liftIO $ putStrLn (show (newnum))+          -- liftIO $ putStrLn (show (newnum))           gotoLayerAt newnum         ResponseCancel -> liftIO $ widgetDestroy dialog         _ -> error "??? in fileOpen " 

@@ -18,10 +18,11 @@ module Hoodle.Coroutine.Link where  import           Control.Applicative-import           Control.Lens (view,(%~))-import           Control.Monad.State +import           Control.Lens (at,view,set,(%~))+import           Control.Monad.State (get,put,modify,liftIO,guard,when) import           Control.Monad.Trans.Maybe  import qualified Data.ByteString.Char8 as B +import           Data.Foldable (forM_) import           Data.Monoid (mconcat) import           Data.UUID.V4 (nextRandom) import           Graphics.UI.Gtk hiding (get,set) @@ -30,7 +31,9 @@ import           Control.Monad.Trans.Crtn.Event  import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.BBox+import           Data.Hoodle.Generic import           Data.Hoodle.Simple (SVG(..))+import           Data.Hoodle.Zipper import           Graphics.Hoodle.Render.Item  import           Graphics.Hoodle.Render.Type  import           Graphics.Hoodle.Render.Type.HitTest @@ -46,6 +49,7 @@ import           Hoodle.ModelAction.Select import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement@@ -53,7 +57,7 @@ import           Hoodle.View.Coordinate import           Hoodle.View.Draw ---import Prelude hiding (mapM_, mapM)+import Prelude hiding (mapM_)  makeTextSVGFromStringAt :: String                             -> CanvasId @@ -74,27 +78,53 @@ notifyLink :: CanvasId -> PointerCoord -> MainCoroutine ()  notifyLink cid pcoord = do      xst <- get -    (boxAction f . getCanvasInfo cid) xst +    (boxAction (f xst) . getCanvasInfo cid) xst    where -    f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine () -    f cvsInfo = do +    f :: forall b. (ViewMode b) => HoodleState -> CanvasInfo b -> MainCoroutine ()+    f xst cvsInfo = do        let cpn = PageNum . view currentPageNum $ cvsInfo           arr = view (viewInfo.pageArrangement) cvsInfo              +          mnotifyitem = view notifiedItem cvsInfo           canvas = view drawArea cvsInfo       geometry <- liftIO $ makeCanvasGeometry cpn arr canvas-      case (desktop2Page geometry . device2Desktop geometry) pcoord of-        Nothing -> return () -        Just (pnum,PageCoord (x,y)) -> do -          itms <- rItmsInCurrLyr    -          let lnks = filter isLinkInRItem itms           -              hlnks = hltFilteredBy (\itm->isPointInBBox (getBBox itm) (x,y)) lnks-              hitted = takeHitted hlnks -          when ((not.null) hitted) $ do  -            let lnk = head hitted -                bbx = getBBox lnk-                bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry-                                      . (pnum,) . PageCoord) bbx-            invalidateInBBox (Just bbx_desk) Efficient cid +      mresult <- +        case (desktop2Page geometry . device2Desktop geometry) pcoord of +          Nothing -> return Nothing +          Just (pnum,PageCoord (x,y)) -> do +            let hdl = getHoodle xst+                mpage = view (gpages.at (unPageNum pnum)) hdl+            case mpage of+              Nothing -> return Nothing+              Just page -> do +                let itms =  (view gitems . current . view glayers) page+                    lnks = filter isLinkInRItem itms           +                    hlnks = hltFilteredBy (\itm->isPointInBBox (getBBox itm) (x,y)) lnks+                    hitted = takeHitted hlnks +                case mnotifyitem of +                  Nothing -> if ((not.null) hitted) +                             then Just <$> newNotify cvsInfo geometry pnum (head hitted) Nothing  +                             else return Nothing +                  Just (opnum,obbx,_) -> do+                    let obbx_desk = xformBBox (unDeskCoord . page2Desktop geometry . (opnum,) . PageCoord) obbx   +                    if pnum == opnum &&  isPointInBBox obbx (x,y) +                      then return Nothing+                      else if ((not.null) hitted) +                           then Just <$> newNotify cvsInfo geometry pnum (head hitted) (Just obbx_desk)+                           else return (Just (Nothing,obbx_desk))+      forM_ mresult (\(mnewnotified,bbx_desk) -> do+                      let ncinfobox = (unboxSet notifiedItem mnewnotified . getCanvasInfo cid) xst +                      put (setCanvasInfo (cid,ncinfobox) xst)+                      invalidateInBBox (Just bbx_desk) Efficient cid )+    ----                                                                                      +    newNotify :: CanvasInfo a -> CanvasGeometry -> PageNum -> RItem -> Maybe BBox +                 -> MainCoroutine (Maybe (PageNum,BBox,RItem),BBox) +    newNotify cvsInfo geometry pnum lnk mobbx_desk = do        +      let bbx = getBBox lnk+          bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord) bbx+          nbbx_desk = maybe bbx_desk (\obbx_desk->unionBBox bbx_desk obbx_desk) mobbx_desk+      liftIO $ print (pnum,bbx)+      return (Just (pnum,bbx,lnk),nbbx_desk)+            -- | got a link address (or embedded image) from drag and drop              gotLink :: Maybe String -> (Int,Int) -> MainCoroutine () @@ -195,7 +225,7 @@               UpdateCanvas cid -> -- this is temporary                                    (invalidateInBBox Nothing Efficient cid) >> go                _ -> go -    action mfn = Left . ActionOrder $ +    action mfn = mkIOaction $                     \_evhandler -> do                       dialog <- messageDialogNew Nothing [DialogModal]                                  MessageQuestion ButtonsOkCancel "add link" @@ -211,13 +241,13 @@                                               <*> textBufferGetEndIter buf                          l <- textBufferGetText buf istart iend True                          widgetDestroy dialog-                         return (AddLink ((l,) <$> mfn))+                         return (UsrEv (AddLink ((l,) <$> mfn)))                        _ -> do                           widgetDestroy dialog-                         return (AddLink Nothing)+                         return (UsrEv (AddLink Nothing))                  -            +   

@@ -33,6 +33,7 @@ import           Hoodle.Type.Alias import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement@@ -40,11 +41,12 @@ -- import Prelude hiding (mapM_, mapM) -modeChange :: MyEvent -> MainCoroutine () +modeChange :: UserEvent -> MainCoroutine ()  modeChange command = do      case command of        ToViewAppendMode -> updateXState select2edit >> invalidateAll -      ToSelectMode     -> updateXState edit2select >> invalidateAll +                          -- invalidateAllInBBox Nothing Efficient -- invalidateAll +      ToSelectMode     -> updateXState edit2select >> invalidateAllInBBox Nothing Efficient -- invalidateAll        _ -> return ()     reflectPenModeUI     reflectPenColorUI@@ -74,7 +76,7 @@                           . gHoodle2GSelect $ hdl   -- | -viewModeChange :: MyEvent -> MainCoroutine () +viewModeChange :: UserEvent -> MainCoroutine ()  viewModeChange command = do      case command of        ToSinglePage -> updateXState cont2single >> invalidateAll @@ -113,6 +115,7 @@                                   (view horizAdjConnId cinfo)                                   (view vertAdjConnId cinfo)                                   (view canvasWidgets cinfo)+                                  (view notifiedItem cinfo)           return $ set currentCanvasInfo (CanvasSinglePage ncinfo) xstate          -------------------------------------         whensing xstate cinfo = do @@ -139,6 +142,7 @@                                       (view horizAdjConnId cinfo)                                       (view vertAdjConnId cinfo)                                       (view canvasWidgets cinfo) +                                      (view notifiedItem cinfo)               ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos))               ncinfo = over currentPageNum (const (unPageNum ncpn)) ncinfotemp           return . over currentCanvasInfo (const (CanvasContPage ncinfo)) $ xstate

@@ -43,7 +43,7 @@ changePage :: (Int -> Int) -> MainCoroutine ()  changePage modifyfn = updateXState changePageAction                        >> adjustScrollbarWithGeometryCurrent-                      >> invalidateAll +                      >> invalidateAllInBBox Nothing Efficient     where changePageAction xst = selectBoxAction (fsingle xst) (fcont xst)                                 . view currentCanvasInfo $ xst         fsingle xstate cvsInfo = do 

@@ -15,19 +15,23 @@ module Hoodle.Coroutine.Pen where  -- from other packages-import           Control.Category-import           Control.Lens (view,set)-import           Control.Monad-import           Control.Monad.State+import           Control.Applicative ((<$>),(<*>))+-- import           Control.Category+import           Control.Lens (view,set,at)+import           Control.Monad hiding (mapM_,forM_)+import           Control.Monad.State hiding (mapM_,forM_) -- import Control.Monad.Trans+import           Data.Foldable (mapM_,forM_) import           Data.Sequence hiding (filter)--- import qualified Data.Map as M import           Data.Maybe  import           Data.Time.Clock --- import           Graphics.UI.Gtk hiding (get,set,disconnect)+import           Graphics.Rendering.Cairo -- from hoodle-platform import           Data.Hoodle.Predefined import           Data.Hoodle.BBox+import           Data.Hoodle.Generic (gpages)+import           Data.Hoodle.Simple (Dimension(..))+import           Graphics.Hoodle.Render (renderStrk) -- from this package import           Hoodle.Accessor import           Hoodle.Device @@ -35,6 +39,7 @@ import           Hoodle.Coroutine.Draw import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Pen+import           Hoodle.Type.Alias import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine import           Hoodle.Type.Enum@@ -46,9 +51,42 @@ import           Hoodle.View.Coordinate import           Hoodle.View.Draw ---import Prelude hiding ((.), id)+import Prelude hiding (mapM_)  ++-- |+createTempRender :: PageNum -> CanvasGeometry -> Page EditMode -> a -> MainCoroutine (TempRender a) +createTempRender _pnum geometry _page x = do +    xst <- get+    let cinfobox = view currentCanvasInfo xst +        mcvssfc = view (unboxLens mDrawSurface) cinfobox +    let hdl = getHoodle xst+    let Dim cw ch = unCanvasDimension . canvasDim $ geometry+        +    srcsfc <- liftIO  $ maybe (fst <$> canvasImageSurface Nothing geometry hdl)+                              (\cvssfc -> do +                                sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) +                                renderWith sfc $ do +                                  setSourceSurface cvssfc 0 0 +                                  setOperator OperatorSource +                                  paint+                                return sfc) +                              mcvssfc++    -- (srcsfc,_) <- liftIO $ canvasImageSurface Nothing geometry hdl +                                  +    +    liftIO $ renderWith srcsfc $ do +      emphasisCanvasRender ColorRed geometry +    tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch)  -- (floor wsfc) (floor hsfc)+    let trdr = TempRender srcsfc tgtsfc (cw,ch) x+    return trdr +++++ -- | page switch if pen click a page different than the current page penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox  penPageSwitch pgn = do @@ -56,7 +94,7 @@     let cibox = view currentCanvasInfo xstate              ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox      put (set currentCanvasInfo ncibox xstate) -    invalidateAll +    invalidateAllInBBox Nothing Efficient     return ncibox           @@ -95,23 +133,29 @@         penAction _cinfo pnum geometry (x,y) = do            xstate <- get           let PointerCoord _ _ _ z = pcoord -          let currhdl = unView . view hoodleModeState $ xstate        +          let currhdl = getHoodle  xstate                pinfo = view penInfo xstate-          pdraw <-penProcess cid pnum geometry (empty |> (x,y,z)) ((x,y),z) -          case viewl pdraw of -            EmptyL -> return ()-            (x1,_y1,_z1) :< _rest -> do -              if x1 <= 1e-3      -- this is ad hoc but.. -                then do -                  liftIO $ putStrLn " horizontal line cured !" -                  invalidateAll-                else do  -                  (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw-                  commit . set hoodleModeState (ViewAppendState newhdl) -                    =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))-                  let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord-                      nbbox = xformBBox f bbox -                  invalidateAllInBBox (Just nbbox) BkgEfficient +              mpage = view (gpages . at (unPageNum pnum)) currhdl +          forM_ mpage $ \page -> do +            trdr <- createTempRender pnum geometry page (empty |> (x,y,z)) +            pdraw <-penProcess cid pnum geometry trdr ((x,y),z) +            surfaceFinish (tempSurfaceSrc trdr)+            surfaceFinish (tempSurfaceTgt trdr)            ++            case viewl pdraw of +              EmptyL -> return ()+              (x1,_y1,_z1) :< _rest -> do +                if x1 <= 1e-3      -- this is ad hoc but.. +                  then do +                    liftIO $ putStrLn " horizontal line cured !" +                    invalidateAll+                  else do  +                    (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw+                    commit . set hoodleModeState (ViewAppendState newhdl) +                      =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))+                    let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord+                        nbbox = xformBBox f bbox +                    invalidateAllInBBox (Just nbbox) BkgEfficient                            @@ -121,37 +165,36 @@ -- | now being changed penProcess :: CanvasId -> PageNum             -> CanvasGeometry-           -> Seq (Double,Double,Double) -> ((Double,Double),Double) +           -> TempRender (Seq (Double,Double,Double))+           -> ((Double,Double),Double)             -> MainCoroutine (Seq (Double,Double,Double))-penProcess cid pnum geometry pdraw ((x0,y0),z0) = do +penProcess cid pnum geometry trdr ((x0,y0),z0) = do      r <- nextevent     xst <- get      boxAction (fsingle r xst) . getCanvasInfo cid $ xst   where +    pdraw = tempInfo trdr      fsingle :: forall b. (ViewMode b) => -               MyEvent -> HoodleState -> CanvasInfo b +               UserEvent -> HoodleState -> CanvasInfo b                 -> MainCoroutine (Seq (Double,Double,Double))     fsingle r xstate cvsInfo =        penMoveAndUpOnly r pnum geometry -        (penProcess cid pnum geometry pdraw ((x0,y0),z0))+        (penProcess cid pnum geometry trdr ((x0,y0),z0))         (\(pcoord,(x,y)) -> do             let PointerCoord _ _ _ z = pcoord             let canvas = view drawArea cvsInfo-               msfc = view mDrawSurface cvsInfo -               ptype  = view (penInfo.penType) xstate-               pcolor = view (penInfo.currentTool.penColor) xstate -               pwidth = view (penInfo.currentTool.penWidth) xstate -               (pcr,pcg,pcb,pca) = convertPenColorToRGBA pcolor -               opacity = case ptype of -                  HighlighterWork -> predefined_highlighter_opacity -                  _ -> 1.0-               pcolRGBA = (pcr,pcg,pcb,pca*opacity) -           let pressureType = case view (penInfo.variableWidthPen) xstate of -                                True -> Pressure-                                False -> NoPressure-           liftIO $ drawCurvebitGen pressureType (canvas,msfc) geometry -                      pwidth pcolRGBA pnum ((x0,y0),z0) ((x,y),z)-           penProcess cid pnum geometry (pdraw |> (x,y,z)) ((x,y),z) )+               pinfo  = view penInfo xstate+           let xformfunc = cairoXform4PageCoordinate geometry pnum +               tmpstrk = createNewStroke pinfo pdraw+               renderfunc = do +                 xformfunc +                 renderStrk tmpstrk+           let (srcsfc,tgtsfc) = (,) <$> tempSurfaceSrc <*> tempSurfaceTgt $ trdr+           virtualDoubleBufferDraw srcsfc tgtsfc (return ()) renderfunc+           liftIO $ doubleBufferFlush tgtsfc cvsInfo+           ---                                +           let ntrdr = trdr { tempInfo = pdraw |> (x,y,z) }+           penProcess cid pnum geometry ntrdr ((x,y),z) )         (\_ -> return pdraw )  -- | @@ -180,7 +223,7 @@                                                                            -- | in page action  -penMoveAndUpOnly :: Monad m => MyEvent +penMoveAndUpOnly :: Monad m => UserEvent                      -> PageNum                      -> CanvasGeometry                      -> m a @@ -194,7 +237,7 @@     _ -> defact     -- | -penMoveAndUpInterPage :: Monad m => MyEvent +penMoveAndUpInterPage :: Monad m => UserEvent                        -> PageNum                        -> CanvasGeometry                        -> m a 

@@ -14,7 +14,7 @@  module Hoodle.Coroutine.Scroll where -import           Control.Lens (view,over)+import           Control.Lens (view,over,_1) import           Control.Monad import           Control.Monad.State  import           Control.Monad.Trans.Either@@ -22,6 +22,7 @@ import           Control.Monad.Trans.Crtn import           Data.Hoodle.BBox -- from this package+import           Hoodle.Type.Enum import           Hoodle.Type.Event  import           Hoodle.Type.Coroutine import           Hoodle.Type.Canvas@@ -68,14 +69,15 @@  -- |  adjustScrollbarWithGeometryCurrent :: MainCoroutine ()-adjustScrollbarWithGeometryCurrent = do-  xstate <- get+adjustScrollbarWithGeometryCurrent = adjustScrollbarWithGeometryCvsId . view (currentCanvas._1) =<<  get +{-  xstate <- get   geometry <- liftIO . getGeometry4CurrCvs $ xstate   let cinfobox = view currentCanvasInfo xstate   let (hadj,vadj) = unboxGet adjustments cinfobox        connidh = unboxGet horizAdjConnId cinfobox        connidv = unboxGet vertAdjConnId cinfobox   liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))  +-}  -- |  hscrollBarMoved :: CanvasId -> Double -> MainCoroutine ()         @@ -110,8 +112,8 @@       VScrollBarEnd cid' v -> do          when (cid /= cid') $            (lift . hoistEither . Left . Other) "something wrong in vscrollMove" -        smoothScroll cid geometry v0 v-        invalidateAll +        moveViewPortBy (invalidate cid) cid (\(x,_)->(x,v))          +        invalidate cid          return ()       VScrollBarStart cid' v -> vscrollStart cid' v        _ -> return ()       

@@ -47,6 +47,7 @@ import           Hoodle.Coroutine.Pen import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page+import           Hoodle.ModelAction.Pen import           Hoodle.ModelAction.Select import           Hoodle.ModelAction.Select.Transform import           Hoodle.Type.Alias@@ -61,6 +62,8 @@ --  import           Prelude hiding ((.), id) ++{- -- | createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode                           -> a @@ -72,7 +75,7 @@     (tempsurface,_) <- liftIO $ canvasImageSurface Nothing geometry hdl      let tempselection = TempSelectRender tempsurface (cw,ch) x     return tempselection -+-}  -- | For Selection mode from pen mode with 2nd pen button dealWithOneTimeSelectMode :: MainCoroutine ()     -- ^ main action @@ -93,21 +96,20 @@ --   choose either starting new rectangular selection or move previously  --   selected selection.  --   (dev note: need to be refactored with selectLassoStart)-selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine ()-selectRectStart cid = commonPenStart rectaction cid+selectRectStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()+selectRectStart pbtn cid = commonPenStart rectaction cid   where rectaction cinfo pnum geometry (x,y) = do           itms <- rItmsInCurrLyr           ctime <- liftIO $ getCurrentTime           let newSelectAction page =                  dealWithOneTimeSelectMode -                  (do tsel <- createTempSelectRender pnum geometry page [] +                  (do tsel <- createTempRender pnum geometry page []                        newSelectRectangle cid pnum geometry itms                                           (x,y) ((x,y),ctime) tsel-                      surfaceFinish (tempSurface tsel) +                      surfaceFinish (tempSurfaceSrc tsel)                        showContextMenu (pnum,(x,y))                   )                   (return ())  -          let                action (Right tpage) | hitInHandle tpage (x,y) =                  case getULBBoxFromSelected tpage of                    Middle bbox ->  @@ -117,8 +119,13 @@                                         bbox ((x,y),ctime) tpage)                           (checkIfHandleGrasped bbox (x,y))                   _ -> return () -              action (Right tpage) | hitInSelection tpage (x,y) = do-                startMoveSelect cid pnum geometry ((x,y),ctime) tpage+              action (Right tpage) | hitInSelection tpage (x,y) = +                case pbtn of+                  PenButton1 -> startMoveSelect cid pnum geometry ((x,y),ctime) tpage+                  PenButton3 -> do +                    waitSomeEvent (\e -> case e of PenUp _ _ -> True ; _ -> False) +                    showContextMenu (pnum,(x,y))                    +                  _ -> return ()                action (Right tpage) | otherwise = newSelectAction (hPage2RPage tpage)               action (Left page) = newSelectAction page           xstate <- get @@ -150,7 +157,7 @@           hittestbbox = hltEmbeddedByBBox bbox itms           hitteditms = takeHitted hittestbbox       page <- getCurrentPageCvsId cid-      let (fitms,sitms) = separateFS $ getDiffBBox (tempSelected tempselection) hitteditms +      let (fitms,sitms) = separateFS $ getDiffBBox (tempInfo tempselection) hitteditms        (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)       when ((not.null) fitms || (not.null) sitms) $ do          let xformfunc = cairoXform4PageCoordinate geometry pnum @@ -168,13 +175,13 @@                   mapM_ renderSelectedItem redrawee                  Bottom -> return ()               mapM_ renderSelectedItem sitms -        liftIO $ updateTempSelection tempselection renderfunc False+        liftIO $ updateTempRender tempselection renderfunc False       when willUpdate $  -        invalidateTemp cid (tempSurface tempselection) +        invalidateTemp cid (tempSurfaceSrc tempselection)                             (renderBoxSelection bbox)        newSelectRectangle cid pnum geometry itms orig                           (ncoord,ntime)-                         tempselection { tempSelectInfo = hitteditms }+                         tempselection { tempInfo = hitteditms }     upact xstate cinfo pcoord = do              let (_,(x,y)) = runIdentity $              skipIfNotInSamePage pnum geometry pcoord @@ -197,7 +204,8 @@       liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectitms)       put . set hoodleModeState (SelectState newthdl)              =<< (liftIO (updatePageAll (SelectState newthdl) xstate))-      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient   -- | prepare for moving selection @@ -209,13 +217,15 @@                    -> MainCoroutine ()  startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do       itmimage <- liftIO $ mkItmsNImg geometry tpage-    tsel <- createTempSelectRender pnum geometry+    tsel <- createTempRender pnum geometry               (hPage2RPage tpage)                itmimage      moveSelect cid pnum geometry (x,y) ((x,y),ctime) tsel -    surfaceFinish (tempSurface tsel)                  +    surfaceFinish (tempSurfaceSrc tsel)+    surfaceFinish (tempSurfaceTgt tsel)     surfaceFinish (imageSurface itmimage)-    invalidateAll +    -- invalidateAll +    invalidateAllInBBox Nothing Efficient   -- |  moveSelect :: CanvasId@@ -223,7 +233,7 @@               -> CanvasGeometry               -> (Double,Double)               -> ((Double,Double),UTCTime)-              -> TempSelectRender ItmsNImg+              -> TempRender ItmsNImg               -> MainCoroutine () moveSelect cid pnum geometry orig@(x0,y0)             (prev,otime) tempselection = do@@ -254,7 +264,7 @@             (b1',b2') = xform (sfunc (0,1))             (b1,b2) = (b1'-c1,b2'-c2)             xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 -        invalidateTempBasePage cid (tempSurface tempselection) pnum +        invalidateTempBasePage cid (tempSurfaceSrc tempselection) pnum            (drawTempSelectImage geometry tempselection xformmat)        moveSelect cid pnum geometry orig (ncoord,ntime) tempselection     upact :: (ViewMode a) => HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () @@ -295,7 +305,8 @@             return coroutineaction       xstate2 <- maybe (return xstate1) id maction        commit xstate2-      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient     ----     ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do        let offset = (x-x0,y-y0)@@ -309,7 +320,8 @@           commit . set hoodleModeState (SelectState newthdl)                  =<< (liftIO (updatePageAll (SelectState newthdl) xstate))         Left _ -> error "this is impossible, in moveSelect" -      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient          -- | prepare for resizing selection @@ -324,13 +336,15 @@ startResizeSelect handle cid pnum geometry bbox                    ((x,y),ctime) tpage = do       itmimage <- liftIO $ mkItmsNImg geometry tpage  -    tsel <- createTempSelectRender pnum geometry +    tsel <- createTempRender pnum geometry                (hPage2RPage tpage)                itmimage      resizeSelect handle cid pnum geometry bbox ((x,y),ctime) tsel -    surfaceFinish (tempSurface tsel)  +    surfaceFinish (tempSurfaceSrc tsel)  +    surfaceFinish (tempSurfaceTgt tsel)           surfaceFinish (imageSurface itmimage)-    invalidateAll +    -- invalidateAll +    invalidateAllInBBox Nothing Efficient  -- |  resizeSelect :: Handle @@ -339,7 +353,7 @@                 -> CanvasGeometry                 -> BBox                 -> ((Double,Double),UTCTime)-                -> TempSelectRender ItmsNImg+                -> TempRender ItmsNImg                 -> MainCoroutine () resizeSelect handle cid pnum geometry origbbox               (prev,otime) tempselection = do@@ -363,7 +377,7 @@             (b1',b2') = xform (sfunc (0,1))             (b1,b2) = (b1'-c1,b2'-c2)             xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 -        invalidateTemp cid (tempSurface tempselection) +        invalidateTemp cid (tempSurfaceSrc tempselection)                             (drawTempSelectImage geometry tempselection                                xformmat)       resizeSelect handle cid pnum geometry @@ -384,7 +398,8 @@           commit . set hoodleModeState (SelectState newthdl)                  =<< (liftIO (updatePageAll (SelectState newthdl) xstate))         Left _ -> error "this is impossible, in resizeSelect" -      invalidateAll+      -- invalidateAll+      invalidateAllInBBox Nothing Efficient       return ()        @@ -405,7 +420,8 @@       newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n       commit =<< liftIO (updatePageAll (SelectState newthdl)                         . set hoodleModeState (SelectState newthdl) $ xstate )-      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient            -- |  selectPenWidthChanged :: Double -> MainCoroutine () @@ -424,27 +440,34 @@       newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n                 commit =<< liftIO (updatePageAll (SelectState newthdl)                           . set hoodleModeState (SelectState newthdl) $ xstate )-      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient   -- | main mouse pointer click entrance in lasso selection mode.  --   choose either starting new rectangular selection or move previously  --   selected selection. -selectLassoStart :: CanvasId -> PointerCoord -> MainCoroutine ()-selectLassoStart cid = commonPenStart lassoAction cid +selectLassoStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()+selectLassoStart pbtn cid = commonPenStart lassoAction cid    where lassoAction cinfo pnum geometry (x,y) = do            itms <- rItmsInCurrLyr           ctime <- liftIO $ getCurrentTime           let newSelectAction page =                     dealWithOneTimeSelectMode -                  (do tsel <- createTempSelectRender pnum geometry page [] +                  (do tsel <- createTempRender pnum geometry page []                        newSelectLasso cinfo pnum geometry itms                                       (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel-                      surfaceFinish (tempSurface tsel)+                      surfaceFinish (tempSurfaceSrc tsel)+                      surfaceFinish (tempSurfaceTgt tsel)                       showContextMenu (pnum,(x,y))                   )                   (return ())            let action (Right tpage) | hitInSelection tpage (x,y) = -                startMoveSelect cid pnum geometry ((x,y),ctime) tpage+                case pbtn of+                  PenButton1 -> startMoveSelect cid pnum geometry ((x,y),ctime) tpage+                  PenButton3 -> do +                    waitSomeEvent (\e -> case e of PenUp _ _ -> True ; _ -> False) +                    showContextMenu (pnum,(x,y))                    +                  _ -> return ()                action (Right tpage) | hitInHandle tpage (x,y) =                  case getULBBoxFromSelected tpage of                    Middle bbox ->  @@ -481,7 +504,7 @@       let nlasso = lasso |> (x,y)       (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)       when willUpdate $ do -        invalidateTemp (view canvasId cinfo) (tempSurface tsel) (renderLasso geometry nlasso) +        invalidateTemp (view canvasId cinfo) (tempSurfaceSrc tsel) (renderLasso geometry nlasso)        newSelectLasso cinfo pnum geometry itms orig (ncoord,ntime) nlasso tsel     upact cinfo pcoord = do        xstate <- get @@ -520,6 +543,7 @@       liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectitms)       put . set hoodleModeState (SelectState newthdl)              =<< (liftIO (updatePageAll (SelectState newthdl) xstate))-      invalidateAll +      -- invalidateAll +      invalidateAllInBBox Nothing Efficient  

@@ -62,9 +62,10 @@           commit newxstate            let ui = view gtkUIManager newxstate           liftIO $ toggleCutCopyDelete ui False +          modeChange ToViewAppendMode            invalidateAll      _ -> return ()-        +    -- | @@ -90,12 +91,12 @@ -- | getClipFromGtk :: MainCoroutine (Maybe [Item]) getClipFromGtk = do -    let action = Left . ActionOrder $ +    let action = mkIOaction $                     \evhandler -> do                         hdltag <- liftIO $ atomNew "hoodle"                        clipbd <- liftIO $ clipboardGet hdltag                        liftIO $ clipboardRequestText clipbd (callback4Clip evhandler)-                       return ActionOrdered +                       return (UsrEv ActionOrdered)     modify (tempQueue %~ enqueue action)      go    where go = do r <- nextevent 

@@ -16,8 +16,10 @@  import           Control.Applicative import           Control.Lens (view,set,(%~))-import           Control.Monad.State +import           Control.Monad.State hiding (mapM_) import           Control.Monad.Trans.Either+import           Data.Attoparsec+import           Data.Foldable (mapM_) import           Graphics.Rendering.Cairo import           Graphics.Rendering.Pango.Cairo import           Graphics.UI.Gtk hiding (get,set)@@ -33,24 +35,58 @@ import           Graphics.Hoodle.Render.Type.HitTest import           System.Directory  import           System.FilePath +import qualified Text.Hoodle.Parse.Attoparsec as PA -- import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Select import           Hoodle.Coroutine.Draw - import           Hoodle.Coroutine.Mode import           Hoodle.Type.Canvas  import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event  import           Hoodle.Type.HoodleState +import           Hoodle.Util -- -import Prelude hiding (readFile)+import Prelude hiding (readFile,mapM_)  -- | +textInputDialog :: MainCoroutine (Maybe String) +textInputDialog = do +  doIOaction $ \_evhandler -> do +                 dialog <- messageDialogNew Nothing [DialogModal]+                   MessageQuestion ButtonsOkCancel "text input"+                 vbox <- dialogGetUpper dialog+                 txtvw <- textViewNew+                 boxPackStart vbox txtvw PackGrow 0 +                 widgetShowAll dialog+                 res <- dialogRun dialog +                 case res of +                   ResponseOk -> do +                     buf <- textViewGetBuffer txtvw +                     (istart,iend) <- (,) <$> textBufferGetStartIter buf+                                          <*> textBufferGetEndIter buf+                     l <- textBufferGetText buf istart iend True+                     widgetDestroy dialog+                     return (UsrEv (TextInput (Just l)))+                   _ -> do +                     widgetDestroy dialog+                     return (UsrEv (TextInput Nothing))+  let go = do r <- nextevent+              case r of +                TextInput input -> return input +                UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> go +                _ -> go +  go +++-- |  textInput :: MainCoroutine ()-textInput = do -    modify (tempQueue %~ enqueue action) +textInput = textInputDialog >>= mapM_ (\str->liftIO (makePangoTextSVG str) >>= svgInsert str)+    +{-+ modify (tempQueue %~ enqueue action)      minput <- go     case minput of        Nothing -> return () @@ -60,7 +96,7 @@             case r of                TextInput input -> return input                _ -> go -    action = Left . ActionOrder $ +    action = mkIOaction $                 \_evhandler -> do                   dialog <- messageDialogNew Nothing [DialogModal]                    MessageQuestion ButtonsOkCancel "text input"@@ -76,11 +112,13 @@                                           <*> textBufferGetEndIter buf                      l <- textBufferGetText buf istart iend True                      widgetDestroy dialog-                     return (TextInput (Just l))+                     return (UsrEv (TextInput (Just l)))                    _ -> do                       widgetDestroy dialog-                     return (TextInput Nothing)+                     return (UsrEv (TextInput Nothing))+-} + -- | svgInsert :: String -> (B.ByteString,BBox) -> MainCoroutine ()  svgInsert str (svgbstr,BBox (x0,y0) (x1,y1)) = do @@ -106,6 +144,27 @@     put nxstate2     invalidateAll    +-- |     +convertLinkFromSimpleToDocID :: Link -> IO (Maybe Link)+convertLinkFromSimpleToDocID (Link i _typ lstr txt cmd rdr pos dim) = do +    case urlParse (B.unpack lstr) of +      Nothing -> return Nothing+      Just (HttpUrl url) -> return Nothing+      Just (FileUrl file) -> do +        b <- doesFileExist file+        if b +          then do +            bstr <- B.readFile file+            case parseOnly PA.hoodle bstr of +              Left str -> return Nothing+              Right hdl -> do +                let uuid = view hoodleID hdl+                    link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim+                return (Just link)+          else return Nothing +convertLinkFromSimpleToDocID _ = return Nothing +    +     -- |    linkInsert :: B.ByteString                -> (B.ByteString,FilePath)@@ -118,10 +177,11 @@         hdl = getHoodle xstate          currpage = getPageFromGHoodleMap pgnum hdl         currlayer = getCurrentLayer currpage-    newitem <- (liftIO . cnstrctRItem . ItemLink) -                 (Link uuidbstr typ (B.pack fname)-                       (Just (B.pack str)) Nothing svgbstr -                      (x0,y0) (Dim (x1-x0) (y1-y0)))  +        lnk = Link uuidbstr "simple" (B.pack fname) (Just (B.pack str)) Nothing svgbstr +                  (x0,y0) (Dim (x1-x0) (y1-y0))+    nlnk <- liftIO $ convertLinkFromSimpleToDocID lnk >>= maybe (return lnk) return+    liftIO $ print nlnk+    newitem <- (liftIO . cnstrctRItem . ItemLink) nlnk     let otheritems = view gitems currlayer       let ntpg = makePageSelectMode currpage                   (otheritems :- (Hitted [newitem]) :- Empty)  

@@ -163,10 +163,9 @@     boxAction (f r xst) . getCanvasInfo cid $ xst    where      Dim w h = view gdimension pg    -    CvsCoord (_,y0_cvs) = -      (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0))-    -    f :: (ViewMode a) => MyEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()+    CvsCoord (_,y0_cvs) = (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0))+    -------------------------------------------------------------+    f :: (ViewMode a) => UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()     f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact                             (moveact xstate cvsInfo) upact     -------------------------------------------------------------  

@@ -29,6 +29,7 @@ import           Hoodle.ModelAction.Window import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement@@ -42,8 +43,7 @@                             -> CanvasDimension                              -> MainCoroutine ()  canvasConfigureGenUpdate updatefunc cid cdim -  = (updateXState $ selectBoxAction fsingle fcont . getCanvasInfo cid )-    >> updatefunc +  = updateXState (selectBoxAction fsingle fcont . getCanvasInfo cid ) >> updatefunc    where fsingle cinfo = do            xstate <- get            cinfo' <- liftIO $ updateCanvasDimForSingle cdim cinfo @@ -56,9 +56,7 @@           return $ setCanvasInfo (cid,CanvasContPage cinfo') xstate     -- | -doCanvasConfigure :: CanvasId -                     -> CanvasDimension -                     -> MainCoroutine () +doCanvasConfigure :: CanvasId -> CanvasDimension -> MainCoroutine ()  doCanvasConfigure = canvasConfigureGenUpdate canvasZoomUpdateAll  -- | 

@@ -17,32 +17,37 @@  module Hoodle.Device where -import Hoodle.Config-import Data.Configurator.Types import Control.Applicative  import Control.Monad.Reader+import Data.Configurator.Types+import Data.Int+import Foreign.C import Foreign.Marshal.Utils import Foreign.Ptr-import Foreign.C import Foreign.Storable import Graphics.UI.Gtk-import Data.Int+--+import Hoodle.Config  -- | --data PointerType = Core | Stylus | Eraser+data PointerType = Core | Stylus | Eraser | Touch                   deriving (Show,Eq,Ord)  -- |--data PenButton = PenButton1 | PenButton2 | PenButton3 | EraserButton+data PenButton = PenButton1 | PenButton2 | PenButton3 | EraserButton | TouchButton                deriving (Show,Eq,Ord)  -- |  -data DeviceList = DeviceList { dev_core :: CInt-                             , dev_stylus :: CInt-                             , dev_eraser :: CInt } +data DeviceList = DeviceList { dev_core       :: CInt +                             , dev_core_str   :: String+                             , dev_stylus     :: CInt+                             , dev_stylus_str :: String+                             , dev_eraser     :: CInt +                             , dev_eraser_str :: String+                             , dev_touch      :: CInt  +                             , dev_touch_str  :: String+                             }                  deriving Show                     -- | @@ -56,40 +61,73 @@                   deriving (Show,Eq,Ord)  -- | - foreign import ccall "c_initdevice.h initdevice" c_initdevice-  :: Ptr CInt -> Ptr CInt -> Ptr CInt -> CString -> CString -> CString -> IO ()+  :: Ptr CInt -- ^ core +  -> Ptr CInt -- ^ stylus+  -> Ptr CInt -- ^ eraser+  -> Ptr CInt -- ^ touch +  -> CString  -- ^ core +  -> CString  -- ^ stylus+  -> CString  -- ^ eraser+  -> CString  -- ^ touch +  -> IO () + -- | +foreign import ccall "c_initdevice.h find_wacom" c_find_wacom+  :: CString -> CString -> IO () +{- +-- | +foreign import ccall "c_initdevice.h enable_touch" c_enable_touch+  :: CString -> IO ()+     +-- | +foreign import ccall "c_initdevice.h disable_touch" c_disable_touch+  :: DrawWindow -> CString -> IO ()+-}++++-- |  initDevice :: Config -> IO DeviceList   initDevice cfg = do -  (mcore,mstylus,meraser) <- getPenDevConfig cfg -  putStrLn $ show mstylus -  putStrLn $ show meraser+  pstylusname_detect <- newCString "stylus" +  perasername_detect <- newCString "eraser" +  ptouchname_detect <- newCString "touch"+  -- c_find_wacom pstylusname_detect perasername_detect+  (mcore,mstylus,meraser,mtouch) <- getPenDevConfig cfg +  -- putStrLn $ show mstylus +  -- putStrLn $ show meraser+  -- putStrLn $ show mtouch   with 0 $ \pcore ->      with 0 $ \pstylus ->        with 0 $ \peraser -> do -        pcorename <- case mcore of -                       Nothing -> newCString "Core Pointer"-                       Just core -> newCString core-        pstylusname <- case mstylus of -                         Nothing -> newCString "stylus"-                         Just spen -> newCString spen-        perasername <- case meraser of -                         Nothing -> newCString "eraser"-                         Just seraser -> newCString seraser -                         -        c_initdevice pcore pstylus peraser pcorename pstylusname perasername-        -        core_val <- peek pcore-        stylus_val <- peek pstylus-        eraser_val <- peek peraser-        return $ DeviceList core_val stylus_val eraser_val+        with 0 $ \ptouch -> do +          (pcorename,corename) <- case mcore of +            Nothing -> (,) <$> newCString "Core Pointer" <*> pure "Core Pointer"+            Just core -> (,) <$> newCString core <*> pure core+          (pstylusname,stylusname) <- case mstylus of +            Nothing -> return (pstylusname_detect,"stylus")+            Just spen -> (,) <$> newCString spen <*> pure spen +          (perasername,erasername) <- case meraser of +            Nothing -> return (perasername_detect,"eraser")+            Just seraser -> (,) <$> newCString seraser <*> pure seraser+          (ptouchname,touchname) <- +            maybe (return (ptouchname_detect,"touch")) (\stouch->(,) <$> newCString stouch <*> pure stouch) +                  mtouch +                            ++          c_initdevice pcore pstylus peraser ptouch pcorename pstylusname perasername ptouchname++          core_val <- peek pcore+          stylus_val <- peek pstylus+          eraser_val <- peek peraser+          touch_val <- peek ptouch+          return $ DeviceList core_val corename stylus_val stylusname eraser_val erasername touch_val touchname                     -- |--getPointer :: DeviceList -> EventM t (Maybe PenButton,PointerCoord)+getPointer :: DeviceList -> EventM t (Maybe PenButton,Maybe PointerCoord) getPointer devlst = do      ptr <- ask      (_ty,btn,x,y,mdev,maxf) <- liftIO (getInfo ptr)@@ -99,16 +137,21 @@              | btn == 3 = Just PenButton3              | otherwise = Nothing      case mdev of -      Nothing -> return (rbtn,PointerCoord Core x y 1.0)+      Nothing -> -- return (rbtn,PointerCoord Core x y 1.0)+                 return (rbtn,Nothing)       Just dev -> case maxf of -                    Nothing -> return (rbtn,PointerCoord Core x y 1.0)+                    Nothing -> return (rbtn,Just (PointerCoord Core x y 1.0))+                               -- return (rbtn,Nothing)                     Just axf -> do -                      pcoord <- liftIO $ coord ptr x y dev axf -                      let rbtnfinal = case pointerType pcoord of -                                        Eraser -> Just EraserButton-                                        _ -> rbtn +                      mpcoord <- liftIO $ coord ptr x y dev axf +                      let rbtnfinal = case mpcoord of +                                        Nothing -> rbtn +                                        Just pcoord -> case pointerType pcoord of +                                                         Eraser -> Just EraserButton+                                                         Touch  -> Just TouchButton+                                                         _ -> rbtn                        -                      let tst = (rbtnfinal,pcoord)+                      let tst = (rbtnfinal,mpcoord)                       return tst    where      getInfo ptr = do @@ -146,20 +189,27 @@         else error ("eventCoordinates: none for event type "++show ty)      coord ptr x y device axf -          | device == dev_core devlst = return $ PointerCoord Core x y 1.0 +          | device == dev_core devlst = return $ Just (PointerCoord Core x y 1.0)           | device == dev_stylus devlst = do              (ptrax :: Ptr CDouble ) <- axf ptr              (wacomx :: Double) <- peekByteOff ptrax 0             (wacomy :: Double) <- peekByteOff ptrax 8             (wacomz :: Double) <- peekByteOff ptrax 16-            return $ PointerCoord Stylus wacomx wacomy wacomz+            return $ Just (PointerCoord Stylus wacomx wacomy wacomz)           | device == dev_eraser devlst = do              (ptrax :: Ptr CDouble ) <- axf ptr              (wacomx :: Double) <- peekByteOff ptrax 0             (wacomy :: Double) <- peekByteOff ptrax 8             (wacomz :: Double) <- peekByteOff ptrax 16 -            return $ PointerCoord Eraser wacomx wacomy wacomz -          | otherwise = return $ PointerCoord Core x y 1.0+            return $ Just (PointerCoord Eraser wacomx wacomy wacomz)+          | device == dev_touch devlst = do +            (ptrax :: Ptr CDouble ) <- axf ptr +            (touchx :: Double) <- peekByteOff ptrax 0+            (touchy :: Double) <- peekByteOff ptrax 8+            (touchz :: Double) <- peekByteOff ptrax 16 +            (touchw :: Double) <- peekByteOff ptrax 24+            return $ Just (PointerCoord Touch touchx touchy touchz)            +          | otherwise = return Nothing -- return $ PointerCoord Core x y 1.0  -- |      

@@ -16,8 +16,9 @@  import           Control.Exception (SomeException(..),catch) import           Control.Lens (view)-import           Control.Monad+import           Control.Monad hiding (mapM_) import           Control.Monad.Trans +import           Data.Foldable (mapM_) import qualified Data.IntMap as M import           Data.IORef import           Data.Maybe@@ -51,11 +52,14 @@   maxundo <- getMaxUndo cfg >>=                 \mmax -> maybe (return 50) (return . id) mmax   xinputbool <- getXInputConfig cfg +  (usepz,uselyr) <- getWidgetConfig cfg    statusbar <- statusbarNew -  (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo  xinputbool statusbar +  (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo +                          (xinputbool,usepz,uselyr) statusbar    setTitleFromFileName st0   -- need for refactoring   setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0 +  setToggleUIForFlag "HANDA" (settings.doesUseTouch) st0      setToggleUIForFlag "POPMENUA" (settings.doesUsePopUpMenu) st0    setToggleUIForFlag "EBDIMGA" (settings.doesEmbedImage) st0    setToggleUIForFlag "EBDPDFA" (settings.doesEmbedPDF) st0@@ -84,9 +88,9 @@       -- very dirty solution but..        minfo <- liftIO $ do          ref <- newIORef (Nothing :: Maybe String)-        view callBack st0 (GetHoodleFileInfo ref) +        view callBack st0 (UsrEv (GetHoodleFileInfo ref))         readIORef ref-      maybe (return ()) (selectionDataSetText >=> const (return ())) minfo+      mapM_ (selectionDataSetText >=> const (return ())) minfo   --   --    hbox <- hBoxNew False 0 @@ -99,11 +103,11 @@   boxPackEnd vbox statusbar PackNatural 0    boxPackStart vbox (view rootWindow st0) PackGrow 0    window `on` deleteEvent $ do-    liftIO $ eventHandler tref (Menu MenuQuit)+    liftIO $ eventHandler tref (UsrEv (Menu MenuQuit))     return True   widgetShowAll window   -- -  let mainaction = do eventHandler tref Initialized     +  let mainaction = do eventHandler tref (UsrEv Initialized)                       mainGUI    mainaction `catch` \(_e :: SomeException) -> do      homepath <- getEnv "HOME"

@@ -5,7 +5,7 @@ -- Module      : Hoodle.GUI.Menu  -- Copyright   : (c) 2011-2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -32,7 +32,7 @@  -- |  -justMenu :: MenuEvent -> Maybe MyEvent+justMenu :: MenuEvent -> Maybe UserEvent justMenu = Just . Menu   -- | @@ -98,9 +98,11 @@           , RadioActionEntry "SELREGNA" "Select Region"     (Just "mylasso")        Nothing Nothing 4           , RadioActionEntry "SELRECTA" "Select Rectangle" (Just "myrectselect")        Nothing Nothing 5           , RadioActionEntry "VERTSPA" "Vertical Space"    (Just "mystretch")        Nothing Nothing 6-          , RadioActionEntry "HANDA"   "Hand Tool"         (Just "myhand")        Nothing Nothing 7           ]             +--          , RadioActionEntry "HANDA"   "Hand Tool"         (Just "myhand")        Nothing Nothing 7++ -- |   colormods :: [RadioActionEntry]@@ -146,7 +148,7 @@ actionNewAndRegisterRef :: EventVar                                                        -> String -> String                             -> Maybe String -> Maybe StockId-                           -> Maybe MyEvent +                           -> Maybe UserEvent                             -> IO Action actionNewAndRegisterRef evar name label tooltip stockId myevent = do      a <- actionNew name label tooltip stockId @@ -154,7 +156,7 @@       Nothing -> return a        Just ev -> do          a `on` actionActivated $ do -          eventHandler evar ev+          eventHandler evar (UsrEv ev)         return a  -- | @@ -191,6 +193,10 @@   ldpreimg3a <- actionNewAndRegister "LDPREIMG3A" "Embed Predefined Image File 3" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage3)   printa  <- actionNewAndRegister "PRINTA" "Print" (Just "Just a Stub") Nothing (justMenu MenuPrint)   exporta <- actionNewAndRegister "EXPORTA" "Export" (Just "Just a Stub") Nothing (justMenu MenuExport)+  synca <- actionNewAndRegister "SYNCA" "Start Sync" (Just "Just a Stub") Nothing (justMenu MenuStartSync)  +  versiona <- actionNewAndRegister "VERSIONA" "Save Version" (Just "Just a Stub") Nothing (justMenu MenuVersionSave)+  showreva <- actionNewAndRegister "SHOWREVA" "Show Revisions" (Just "Just a Stub") Nothing (justMenu MenuShowRevisions)  +  showida <- actionNewAndRegister "SHOWIDA" "Show UUID" (Just "Just a Stub") Nothing (justMenu MenuShowUUID)       quita   <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just stockQuit) (justMenu MenuQuit)      -- edit menu@@ -251,7 +257,6 @@   -- selregna  <- actionNewAndRegister "SELREGNA" "Select Region" (Just "Just a Stub") (Just "mylasso") (justMenu MenuSelectRegion)   -- selrecta  <- actionNewAndRegister "SELRECTA" "Select Rectangle" (Just "Just a Stub") (Just "myrectselect") (justMenu MenuSelectRectangle)   -- vertspa   <- actionNewAndRegister "VERTSPA" "Vertical Space" (Just "Just a Stub") (Just "mystretch") (justMenu MenuVerticalSpace)-  -- handa     <- actionNewAndRegister "HANDA" "Hand Tool" (Just "Just a Stub") (Just "myhand") (justMenu MenuHandTool)    clra      <- actionNewAndRegister "CLRA" "Color" (Just "Just a Stub") Nothing Nothing   clrpcka   <- actionNewAndRegister "CLRPCKA" "Color Picker.." (Just "Just a Stub") (Just stockSelectColor) (justMenu MenuColorPicker )    penopta   <- actionNewAndRegister "PENOPTA" "Pen Options" (Just "Just a Stub") Nothing (justMenu MenuPenOptions)@@ -268,27 +273,35 @@   -- options menu    uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing    uxinputa `on` actionToggled $ do -    eventHandler evar (Menu MenuUseXInput)+    eventHandler evar (UsrEv (Menu MenuUseXInput))+  -- handa <- actionNewAndRegister "HANDA" "Use Touch" (Just "Use touch") (Just "myhand") (justMenu MenuUseTouch)    +  handa     <- toggleActionNew "HANDA" "Use Touch" (Just "Toggle touch") (Just "myhand") +  handa `on` actionToggled $ do +    eventHandler evar (UsrEv (Menu MenuUseTouch))   smthscra <- toggleActionNew "SMTHSCRA" "Smooth Scrolling" (Just "Just a stub") Nothing   smthscra `on` actionToggled $ do -    eventHandler evar (Menu MenuSmoothScroll)+    eventHandler evar (UsrEv (Menu MenuSmoothScroll))   popmenua <- toggleActionNew "POPMENUA" "Use Popup Menu" (Just "Just a stub") Nothing   popmenua `on` actionToggled $ do -    eventHandler evar (Menu MenuUsePopUpMenu)    +    eventHandler evar (UsrEv (Menu MenuUsePopUpMenu))   ebdimga <- toggleActionNew "EBDIMGA" "Embed PNG/JPG Image" (Just "Just a stub") Nothing   ebdimga `on` actionToggled $ do -    eventHandler evar (Menu MenuEmbedImage)+    eventHandler evar (UsrEv (Menu MenuEmbedImage))   ebdpdfa <- toggleActionNew "EBDPDFA" "Embed PDF" (Just "Just a stub") Nothing   ebdpdfa `on` actionToggled $ do -    eventHandler evar (Menu MenuEmbedPDF)+    eventHandler evar (UsrEv (Menu MenuEmbedPDF))+  flwlnka <- toggleActionNew "FLWLNKA" "Follow Links" (Just "Just a stub") Nothing+  flwlnka `on` actionToggled $ do +    eventHandler evar (UsrEv (Menu MenuFollowLinks))       -- temporary implementation (later will be as submenus with toggle action. appropriate reflection)-  widgettogglea <- actionNewAndRegister "WIDGETTOGGLEA" "Toggle Pan/Zoom Widget"  (Just "Just a stub") Nothing (justMenu MenuWidgetToggle)+  togpanzooma <- actionNewAndRegister "TOGPANZOOMA" "Toggle Pan/Zoom Widget"  (Just "Just a stub") Nothing (justMenu MenuTogglePanZoomWidget)+  toglayera <- actionNewAndRegister "TOGLAYERA" "Toggle Layer Widget"  (Just "Just a stub") Nothing (justMenu MenuToggleLayerWidget)        dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents)   ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip)   pressrsensa <- toggleActionNew "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing    pressrsensa `on` actionToggled $ do -    eventHandler evar (Menu MenuPressureSensitivity)+    eventHandler evar (UsrEv (Menu MenuPressureSensitivity))     @@ -319,7 +332,8 @@   mapM_ (actionGroupAddAction agr)            [ undoa, redoa, cuta, copya, pastea, deletea ]    mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing)   -        [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, ldpreimg2a, ldpreimg3a, opena, savea, saveasa, reloada, recenta, printa, exporta, quita+        [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, ldpreimg2a, ldpreimg3a, opena, savea, saveasa+        , reloada, recenta, printa, exporta, synca, versiona, showreva, showida, quita         , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma         , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera         , hsplita, vsplita, delcvsa@@ -329,7 +343,7 @@         , texta, linka, shpreca, rulera, clra, clrpcka, penopta          , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta         , setdefopta, relauncha-        , widgettogglea+        , togpanzooma, toglayera         , dcrdcorea, ersrtipa, pghilta, mltpgvwa         , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea          , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa @@ -337,12 +351,8 @@         , defaulta                  ]      -  actionGroupAddAction agr uxinputa -  actionGroupAddAction agr smthscra-  actionGroupAddAction agr popmenua -  actionGroupAddAction agr ebdimga-  actionGroupAddAction agr ebdpdfa-  actionGroupAddAction agr pressrsensa+  mapM_ (actionGroupAddAction agr) +    [uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, pressrsensa]   -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar)   mpgmodconnid <-      actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar) -- const (return ()))@@ -372,7 +382,8 @@         , defaulta                  ]        enabledActions = -        [ opena, savea, saveasa, reloada, quita, pastea, fstpagea, prvpagea, nxtpagea, lstpagea+        [ opena, savea, saveasa, reloada, versiona, showreva, showida, quita+        , pastea, fstpagea, prvpagea, nxtpagea, lstpagea         , clra, penopta, zooma, nrmsizea, pgwdtha, texta           ]   --@@ -393,8 +404,8 @@   actionSetSensitive ra3 True    Just ra4 <- actionGroupGetAction agr "VERTSPA"   actionSetSensitive ra4 True-  Just ra5 <- actionGroupGetAction agr "HANDA"-  actionSetSensitive ra5 False+  -- Just ra5 <- actionGroupGetAction agr "HANDA"+  -- actionSetSensitive ra5 False   Just ra6 <- actionGroupGetAction agr "CONTA"   actionSetSensitive ra6 True   Just _ra7 <- actionGroupGetAction agr "PENA"@@ -406,7 +417,9 @@   toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons    toolbarSetIconSize (castToToolbar toolbar2) IconSizeSmallToolbar     +  -- Just pendropdown <- uiManagerGetWidget ui "/ui/toolbar2/PENDROPDOWN"   +     let uicomponentsignalhandler = set penModeSignal mpenmodconnid                                   . set pageModeSignal mpgmodconnid                                   $ defaultUIComponentSignalHandler @@ -439,13 +452,13 @@  -- |  assignViewMode :: EventVar -> RadioAction -> IO ()-assignViewMode evar a = viewModeToMyEvent a >>= eventHandler evar+assignViewMode evar a = viewModeToUserEvent a >>= eventHandler evar . UsrEv      -- |  assignPenMode :: EventVar -> RadioAction -> IO () assignPenMode evar a = do      v <- radioActionGetCurrentValue a-    eventHandler evar (AssignPenMode (int2PenType v))+    eventHandler evar (UsrEv (AssignPenMode (int2PenType v)))         -- | @@ -453,13 +466,13 @@ assignColor evar a = do      v <- radioActionGetCurrentValue a     let c = int2Color v-    eventHandler evar (PenColorChanged c)+    eventHandler evar (UsrEv (PenColorChanged c))  -- |  assignPoint :: EventVar -> RadioAction -> IO ()   assignPoint evar a = do      v <- radioActionGetCurrentValue a-    eventHandler evar (PenWidthChanged v)+    eventHandler evar (UsrEv (PenWidthChanged v))   -- | @@ -467,7 +480,7 @@ assignBkgStyle evar a = do      v <- radioActionGetCurrentValue a      let sty = int2BkgStyle v -    eventHandler evar (BackgroundStyleChanged sty) +    eventHandler evar (UsrEv (BackgroundStyleChanged sty))  -- |  int2PenType :: Int -> Either PenType SelectType @@ -478,7 +491,7 @@ int2PenType 4 = Right SelectRegionWork int2PenType 5 = Right SelectRectangleWork int2PenType 6 = Left VerticalSpaceWork-int2PenType 7 = Right SelectHandToolWork+-- int2PenType 7 = Right SelectHandToolWork int2PenType _ = error "No such pentype"  -- | @@ -489,7 +502,7 @@ penType2Int (Left VerticalSpaceWork)    = 6 penType2Int (Right SelectRegionWork)    = 4  penType2Int (Right SelectRectangleWork) = 5 -penType2Int (Right SelectHandToolWork)  = 7 +-- penType2Int (Right SelectHandToolWork)  = 7    -- | 

@@ -14,14 +14,14 @@  module Hoodle.GUI.Reflect where -import Control.Lens (view,Simple,Lens,(%~))+import Control.Lens (view,Simple,Lens) import qualified Control.Monad.State as St import Control.Monad.Trans  import           Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) ---import Control.Monad.Trans.Crtn.Event-import Control.Monad.Trans.Crtn.Queue+-- import Control.Monad.Trans.Crtn.Event+-- import Control.Monad.Trans.Crtn.Queue -- import Hoodle.GUI.Menu  import Hoodle.Type.Canvas@@ -121,12 +121,10 @@   where update xst wpma mconnid  = do            (f xst) #              (maybe (return ()) $ \v -> do-              let action = Left . ActionOrder $ -                    \_evhandler -> do -                      blockWhile mconnid -                        (Gtk.set wpma [radioActionCurrentValue := v ] )-                      return ActionOrdered-              St.modify (tempQueue %~ enqueue action)+              doIOaction $ \_evhandler -> do +                    blockWhile mconnid +                      (Gtk.set wpma [radioActionCurrentValue := v ] )+                    return (UsrEv ActionOrdered)               go)          where go = do r <- nextevent                        case r of

@@ -54,12 +54,12 @@   -- |-callback4Clip :: (MyEvent -> IO ()) -> Maybe String -> IO ()-callback4Clip callbk Nothing = callbk (GotClipboardContent Nothing)+callback4Clip :: (AllEvent -> IO ()) -> Maybe String -> IO ()+callback4Clip callbk Nothing = callbk (UsrEv (GotClipboardContent Nothing)) callback4Clip callbk (Just str) = do     let r = do let bstr = C8.pack str                 bstr' <- B64.decode bstr                Se.decode bstr'      case r of -      Left _err -> callbk (GotClipboardContent Nothing)-      Right cnt -> callbk (GotClipboardContent (Just cnt))+      Left _err -> callbk (UsrEv (GotClipboardContent Nothing))+      Right cnt -> callbk (UsrEv (GotClipboardContent (Just cnt)))

@@ -30,13 +30,14 @@ import Hoodle.Util  -- |-menuOpenALink :: (MyEvent -> IO ()) -> UrlPath -> IO MenuItem+menuOpenALink :: (AllEvent -> IO ()) -> UrlPath -> IO MenuItem menuOpenALink evhandler urlpath = do      let urlname = case urlpath of                      FileUrl fp -> fp                      HttpUrl url -> url      menuitemlnk <- menuItemNewWithLabel ("Open "++urlname) -    menuitemlnk `on` menuItemActivate $ do+    menuitemlnk `on` menuItemActivate $ openLinkAction urlpath +    {- do       case urlpath of          FileUrl fp -> do            let cmdargs = [fp]@@ -45,20 +46,33 @@         HttpUrl url -> do            let cmdargs = [url]           createProcess (proc "xdg-open" cmdargs)  -          return () +          return () -}     return menuitemlnk  +-- | +openLinkAction :: UrlPath -> IO () +openLinkAction urlpath = +    case urlpath of +      FileUrl fp -> do +        let cmdargs = [fp]+        createProcess (proc "hoodle" cmdargs)  +        return () +      HttpUrl url -> do +        let cmdargs = [url]+        createProcess (proc "xdg-open" cmdargs)  +        return () +       -- | -menuCreateALink :: (MyEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem)+menuCreateALink :: (AllEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem) menuCreateALink evhandler sitems =    if (length . filter isLinkInRItem) sitems > 0   then return Nothing    else do mi <- menuItemNewWithLabel "Create a link to..."            mi `on` menuItemActivate $ -            evhandler (GotContextMenuSignal CMenuCreateALink)+            evhandler (UsrEv (GotContextMenuSignal CMenuCreateALink))           return (Just mi)           

@@ -20,15 +20,16 @@ import           Control.Applicative import           Control.Lens (view,set) import           Data.Attoparsec -import           Data.Maybe -import           Graphics.UI.Gtk hiding (get,set) import           Data.ByteString.Base64  import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.IntMap as IM+import           Data.Maybe  import           Data.Monoid ((<>))+import           Data.Time.Clock+import           Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage-import           Graphics.Hoodle.Render.Background import           System.Directory (canonicalizePath) import           System.FilePath (takeExtension) import           System.Process@@ -36,8 +37,10 @@ import           Data.Hoodle.Generic import           Data.Hoodle.Simple import           Graphics.Hoodle.Render+import           Graphics.Hoodle.Render.Background import           Graphics.Hoodle.Render.Type.Background  import           Graphics.Hoodle.Render.Type.Hoodle+import           Text.Hoodle.Builder (builder) import qualified Text.Hoodle.Parse.Attoparsec as PA import qualified Text.Hoodle.Migrate.V0_1_1_to_V0_2 as MV import qualified Text.Xournal.Parse.Conduit as XP@@ -70,8 +73,11 @@         r <- checkVersionAndMigrate bstr          case r of            Left err -> putStrLn err >> return xstate -          Right h -> constructNewHoodleStateFromHoodle h xstate -                     >>= return . set (hoodleFileControl.hoodleFileName) (Just fname)+          Right h -> do +            nxstate <- constructNewHoodleStateFromHoodle h xstate +            ctime <- getCurrentTime+            return . set (hoodleFileControl.hoodleFileName) (Just fname)+                   . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate       ".xoj" -> do            XP.parseXojFile fname >>= \x -> case x of               Left str -> do@@ -80,7 +86,9 @@             Right xojcontent -> do                hdlcontent <- mkHoodleFromXournal xojcontent                nxstate <- constructNewHoodleStateFromHoodle hdlcontent xstate -              return $ set (hoodleFileControl.hoodleFileName) (Just fname) nxstate               +              ctime <- getCurrentTime +              return . set (hoodleFileControl.hoodleFileName) (Just fname) +                     . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate                      ".pdf" -> do          let doesembed = view (settings.doesEmbedPDF) xstate         mhdl <- makeNewHoodleWithPDF doesembed fname @@ -197,7 +205,23 @@     in Page dim bkg [emptyLayer]                     +-- | +saveHoodle :: HoodleState -> IO HoodleState +saveHoodle xstate = do +    let hdl = (rHoodle2Hoodle . getHoodle) xstate +    case view (hoodleFileControl.hoodleFileName) xstate of +      Nothing -> return xstate +      Just filename -> do +        L.writeFile filename . builder $ hdl+        ctime <- getCurrentTime +        let ui = view gtkUIManager xstate+        toggleSave ui False+        return (set isSaved True . set (hoodleFileControl.lastSavedTime) (Just ctime) $ xstate )+              +++ -- | this function must be moved to GUI.Reflect toggleSave :: UIManager -> Bool -> IO () toggleSave ui b = do @@ -207,3 +231,5 @@         y:_ -> return y     Just savea <- actionGroupGetAction agr "SAVEA"     actionSetSensitive savea b++

@@ -15,12 +15,13 @@ module Hoodle.ModelAction.Pen where  import           Control.Lens (view,set,over)+import           Control.Monad (when) import           Control.Monad.Identity (runIdentity) import           Data.Foldable import qualified Data.IntMap as IM--- import qualified Data.Map as M import           Data.Sequence hiding (take, drop) import           Data.Strict.Tuple hiding (uncurry)+import           Graphics.Rendering.Cairo -- from hoodle-platform  import           Data.Hoodle.BBox import           Data.Hoodle.Generic@@ -35,6 +36,49 @@ import           Hoodle.Type.PageArrangement -- +data TempRender a = TempRender { tempSurfaceSrc :: Surface  +                               , tempSurfaceTgt :: Surface +                               , widthHeight :: (Double,Double)+                               , tempInfo :: a +                               } +++-- | update the content of temp selection. should not be often updated+updateTempRender :: TempRender a -> Render () -> Bool -> IO ()+updateTempRender temprender renderfunc isFullErase = +  renderWith (tempSurfaceSrc temprender) $ do +    when isFullErase $ do +      let (cw,ch) = widthHeight temprender+      setSourceRGBA 0.5 0.5 0.5 1+      rectangle 0 0 cw ch +      fill +    renderfunc    +++createNewStroke :: PenInfo -> Seq (Double,Double,Double) -> Stroke +createNewStroke pinfo pdraw = +  let ptype = view penType pinfo+      pcolor = view (currentTool.penColor) pinfo+      pcolname = convertPenColorToByteString pcolor +      pwidth = view (currentTool.penWidth) pinfo+      pvwpen = view variableWidthPen pinfo+      ptool = case ptype of +                  PenWork -> "pen" +                  HighlighterWork -> "highlighter"+                  _ -> error "error in addPDraw"+      +      newstroke = +        case pvwpen of +          False -> Stroke { stroke_tool = ptool +                          , stroke_color = pcolname +                          , stroke_width = pwidth+                          , stroke_data = map (\(x,y,_)->x:!:y) . toList $ pdraw } +          True -> VWStroke { stroke_tool = ptool+                           , stroke_color = pcolname                 +                           , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw }+  in newstroke ++ -- |  addPDraw :: PenInfo              -> RHoodle@@ -43,36 +87,15 @@             -> IO (RHoodle,BBox)                         -- ^ new hoodle and bbox in page coordinate addPDraw pinfo hdl (PageNum pgnum) pdraw = do -    let ptype = view penType pinfo-        pcolor = view (currentTool.penColor) pinfo-        pcolname = convertPenColorToByteString pcolor -        pwidth = view (currentTool.penWidth) pinfo-        pvwpen = view variableWidthPen pinfo-        currpage = getPageFromGHoodleMap pgnum hdl+    let currpage = getPageFromGHoodleMap pgnum hdl         currlayer = getCurrentLayer currpage         dim = view gdimension currpage-        ptool = case ptype of -                  PenWork -> "pen" -                  HighlighterWork -> "highlighter"-                  _ -> error "error in addPDraw"-        newstroke = -          case pvwpen of -            False -> Stroke { stroke_tool = ptool -                            , stroke_color = pcolname -                            , stroke_width = pwidth-                            , stroke_data = map (\(x,y,_)->x:!:y) . toList $ pdraw-                          } -            True -> VWStroke { stroke_tool = ptool-                             , stroke_color = pcolname                 -                             , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw-                             }-                                           +        newstroke = createNewStroke pinfo pdraw                  newstrokebbox = runIdentity (makeBBoxed newstroke)         bbox = getBBox newstrokebbox     newlayerbbox <- updateLayerBuf dim (Just bbox)                     . over gitems (++[RItemStroke newstrokebbox])                      $ currlayer-     let newpagebbox = adjustCurrentLayer newlayerbbox currpage          newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl) ) hdl      return (newhdlbbox,bbox)

@@ -40,6 +40,7 @@ import           Graphics.Hoodle.Render.Util.HitTest -- from this package import           Hoodle.ModelAction.Layer+import           Hoodle.ModelAction.Pen  import           Hoodle.ModelAction.Select.Transform import           Hoodle.Type.Alias import           Hoodle.Type.Enum@@ -334,12 +335,7 @@   where BBox (x1,y1) (x2,y2) = getBBox lnk  -data TempSelectRender a = TempSelectRender { tempSurface :: Surface  -                                           , widthHeight :: (Double,Double)-                                           , tempSelectInfo :: a -                                           } --type TempSelection = TempSelectRender [RItem]+type TempSelection = TempRender [RItem]  data ItmsNImg = ItmsNImg { itmNimg_itms :: [RItem]                          , itmNimg_mbbx :: Maybe BBox @@ -366,16 +362,16 @@  -- |  drawTempSelectImage :: CanvasGeometry -                    -> TempSelectRender ItmsNImg +                    -> TempRender ItmsNImg                      -> Matrix -- ^ transformation matrix                     -> Render () drawTempSelectImage geometry tempselection xformmat = do -    let sfc = imageSurface (tempSelectInfo tempselection)+    let sfc = imageSurface (tempInfo tempselection)         CanvasDimension (Dim cw ch) = canvasDim geometry          invxformmat = invert xformmat          newvbbox = BBox (transformPoint invxformmat (0,0))                          (transformPoint invxformmat (cw,ch))-        mbbox = itmNimg_mbbx (tempSelectInfo tempselection)+        mbbox = itmNimg_mbbx (tempInfo tempselection)         newmbbox = case unIntersect (Intersect (Middle newvbbox) `mappend` fromMaybe mbbox) of                       Middle bbox -> Just bbox                       _ -> Just newvbbox@@ -387,24 +383,19 @@   +{- -- |  tempSelected :: TempSelection -> [RItem]-tempSelected = tempSelectInfo +tempSelected = tempInfo +-} +{-  mkTempSelection :: Surface -> (Double,Double) -> [RItem] -> TempSelection-mkTempSelection sfc (w,h) = TempSelectRender sfc (w,h)  +mkTempSelection sfc (w,h) = TempRender sfc (w,h)  +-} --- | update the content of temp selection. should not be often updated-updateTempSelection :: TempSelectRender a -> Render () -> Bool -> IO ()-updateTempSelection tempselection  renderfunc isFullErase = -  renderWith (tempSurface tempselection) $ do -    when isFullErase $ do -      let (cw,ch) = widthHeight tempselection-      setSourceRGBA 0.5 0.5 0.5 1-      rectangle 0 0 cw ch -      fill -    renderfunc    -    ++ -- |  getNewCoordTime :: ((Double,Double),UTCTime)                     -> (Double,Double)

@@ -21,6 +21,8 @@ import           Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) import           System.FilePath++ -- from this package import           Hoodle.Device import           Hoodle.Type.Canvas@@ -31,9 +33,6 @@ import           Hoodle.Util --  --- -- | set frame title according to file name setTitleFromFileName :: HoodleState -> IO ()  setTitleFromFileName xstate = do @@ -66,7 +65,7 @@     scrolledWindowSetHAdjustment scrwin hadj      scrolledWindowSetVAdjustment scrwin vadj      -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic -    return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing defaultCanvasWidgets+    return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing defaultCanvasWidgets Nothing    -- | only connect events @@ -82,51 +81,62 @@         hadj = _horizAdjustment cinfo          vadj = _vertAdjustment cinfo  +    widgetSetCanFocus canvas True +    widgetGrabFocus canvas     +         _sizereq <- canvas `on` sizeRequest $ return (Requisition 800 400)         +    _keyevent <- canvas `on` keyPressEvent $ tryEvent $ do +      m <- eventModifier+      n <- eventKeyName +      let keystr = show m ++ ":" ++ show n+      -- liftIO $ putStrLn (show m ++ ":" ++ show n)+      liftIO $ (callback (UsrEv (CustomKeyEvent keystr)))     _bpevent <- canvas `on` buttonPressEvent $ tryEvent $ do -                 (mbtn,p) <- getPointer dev-                 let pbtn = maybe PenButton1 id mbtn-                 liftIO (callback (PenDown cid pbtn p))+                 liftIO $ widgetGrabFocus canvas +                 (mbtn,mp) <- getPointer dev+                 case mp of +                   Nothing -> return ()+                   Just p -> do +                     let pbtn = maybe PenButton1 id mbtn+                     case pbtn of +                       TouchButton -> liftIO (callback (UsrEv (TouchDown cid p)))+                       _ -> liftIO (callback (UsrEv (PenDown cid pbtn p)))     _confevent <- canvas `on` configureEvent $ tryEvent $ do +                          (w,h) <- eventSize -                   liftIO $ callback -                     (CanvasConfigure cid (fromIntegral w) (fromIntegral h))+                   liftIO $ callback (UsrEv (CanvasConfigure cid (fromIntegral w) (fromIntegral h)))     _brevent <- canvas `on` buttonReleaseEvent $ tryEvent $ do -                 (_,p) <- getPointer dev-                 liftIO (callback (PenUp cid p))+                 (mbtn,mp) <- getPointer dev+                 case mp of +                   Nothing -> return () +                   Just p -> do+                     let pbtn = maybe PenButton1 id mbtn+                     case pbtn of +                       TouchButton -> (liftIO . callback . UsrEv) (TouchUp cid p)+                       _ -> (liftIO . callback . UsrEv) (PenUp cid p)+    _focus <- canvas `on` focusInEvent $ tryEvent $ liftIO $ widgetGrabFocus canvas      _exposeev <- canvas `on` exposeEvent $ tryEvent $ do -                  liftIO $ callback (UpdateCanvas cid) +      liftIO $ widgetGrabFocus canvas       +      (liftIO . callback . UsrEv) (UpdateCanvas cid)      canvas `on` motionNotifyEvent $ tryEvent $ do -      (_,p) <- getPointer dev-      liftIO $ callback (PenMove cid p)+      (mbtn,mp) <- getPointer dev+      case mp of +        Nothing -> return ()+        Just p -> do +          let pbtn = maybe PenButton1 id mbtn      +          case pbtn of +            TouchButton -> (liftIO . callback . UsrEv) (TouchMove cid p) +            _ -> (liftIO . callback . UsrEv) (PenMove cid p)      -- drag and drop setting     dragDestSet canvas [DestDefaultMotion, DestDefaultDrop] [ActionCopy]     dragDestAddTextTargets canvas     canvas `on` dragDataReceived $ \_dc pos _i _ts -> do        s <- selectionDataGetText -      liftIO $ callback (GotLink s pos)+      (liftIO . callback . UsrEv) (GotLink s pos)       -      {--      liftIO . putStrLn $ case s of -        Nothing -> "didn't understand the drop"-        Just s -> "understood. here it is : <" ++ s ++ ">" ++ " and pos is <" ++ show pos ++ ">" -    -}-    {-     -    dragSourceSet canvas [Button1] [ActionCopy]-    dragSourceAddTextTargets canvas-    canvas `on` dragBegin $ \dc -> do -      liftIO $ putStrLn "dragging"-    -}    --    {--    canvas `on` enterNotifyEvent $ tryEvent $ do -      win <- liftIO $ widgetGetDrawWindow canvas-      liftIO $ drawWindowSetCursor win (Just cursorDot)-      return ()-    -}  -    widgetAddEvents canvas [PointerMotionMask,Button1MotionMask]      +    widgetAddEvents canvas [PointerMotionMask,Button1MotionMask,KeyPressMask]           let ui = view gtkUIManager xstate      agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->                       case x of @@ -139,18 +149,18 @@          else widgetSetExtensionEvents canvas [ExtensionEventsNone]     hadjconnid <- afterValueChanged hadj $ do                      v <- adjustmentGetValue hadj -                    callback (HScrollBarMoved cid v)+                    (callback . UsrEv) (HScrollBarMoved cid v)     vadjconnid <- afterValueChanged vadj $ do                      v <- adjustmentGetValue vadj     -                    callback (VScrollBarMoved cid v)+                    (callback . UsrEv) (VScrollBarMoved cid v)     Just vscrbar <- scrolledWindowGetVScrollbar scrwin     _bpevtvscrbar <- vscrbar `on` buttonPressEvent $ do                        v <- liftIO $ adjustmentGetValue vadj -                      liftIO (callback (VScrollBarStart cid v))+                      liftIO ((callback . UsrEv) (VScrollBarStart cid v))                       return False     _brevtvscrbar <- vscrbar `on` buttonReleaseEvent $ do                        v <- liftIO $ adjustmentGetValue vadj -                      liftIO (callback (VScrollBarEnd cid v))+                      liftIO ((callback . UsrEv) (VScrollBarEnd cid v))                       return False     return $ cinfo { _horizAdjConnId = Just hadjconnid                    , _vertAdjConnId = Just vadjconnid }@@ -204,9 +214,7 @@  constructFrame :: HoodleState -> WindowConfig                    -> IO (HoodleState,Widget,WindowConfig)-constructFrame hst wcfg = do -  putStrLn "in constructFrame"-  constructFrame' (CanvasSinglePage defaultCvsInfoSinglePage) hst wcfg +constructFrame hst wcfg = constructFrame' (CanvasSinglePage defaultCvsInfoSinglePage) hst wcfg    @@ -217,8 +225,6 @@                    -> IO (HoodleState,Widget,WindowConfig) constructFrame' template oxstate (Node cid) = do      let ocmap = getCanvasInfoMap oxstate --             (cinfobox,_cmap,xstate) <- case M.lookup cid ocmap of        Just cinfobox' -> return (cinfobox',ocmap,oxstate)       Nothing -> do @@ -236,10 +242,10 @@     let callback = view callBack xstate''      hpane' <- hPanedNew     hpane' `on` buttonPressEvent $ do -      liftIO (callback PaneMoveStart)+      liftIO ((callback . UsrEv) PaneMoveStart)       return False      hpane' `on` buttonReleaseEvent $ do -      liftIO (callback PaneMoveEnd)+      liftIO ((callback . UsrEv) PaneMoveEnd)       return False            panedPack1 hpane' win1 True False     panedPack2 hpane' win2 True False@@ -251,10 +257,10 @@     let callback = view callBack xstate''          vpane' <- vPanedNew      vpane' `on` buttonPressEvent $ do -      liftIO (callback PaneMoveStart)+      liftIO ((callback . UsrEv) PaneMoveStart)       return False      vpane' `on` buttonReleaseEvent $ do -      liftIO (callback PaneMoveEnd)+      liftIO ((callback . UsrEv) PaneMoveEnd)       return False      panedPack1 vpane' win1 True False     panedPack2 vpane' win2 True False

@@ -52,7 +52,8 @@ , vertAdjConnId , adjustments  , canvasWidgets-, testWidgetPosition+, notifiedItem+-- , panZoomWidgetPosition , currentTool  , penWidth , penColor@@ -92,6 +93,7 @@ import           Data.Hoodle.Simple (Dimension(..)) import           Data.Hoodle.BBox import           Data.Hoodle.Predefined +import           Graphics.Hoodle.Render.Type.Item -- import           Hoodle.Type.Enum  import           Hoodle.Type.PageArrangement@@ -161,6 +163,7 @@                                , _horizAdjConnId :: Maybe (ConnectId Adjustment)                                , _vertAdjConnId :: Maybe (ConnectId Adjustment)                                , _canvasWidgets :: CanvasWidgets+                               , _notifiedItem :: Maybe (PageNum,BBox,RItem)                                 }  -- |     @@ -179,6 +182,7 @@                , _horizAdjConnId = _horizAdjConnId                , _vertAdjConnId = _vertAdjConnId                 , _canvasWidgets = _canvasWidgets+               , _notifiedItem = _notifiedItem                }  -- |     @@ -195,6 +199,7 @@              , _horizAdjConnId = Nothing              , _vertAdjConnId =  Nothing              , _canvasWidgets = defaultCanvasWidgets+             , _notifiedItem = Nothing               }  -- | @@ -244,11 +249,13 @@   where getter = (,) <$> view horizAdjustment <*> view vertAdjustment          setter f (h,v) = set horizAdjustment h . set vertAdjustment v $ f   --- | +-- | lens for canavs widgets canvasWidgets :: Simple Lens (CanvasInfo a) CanvasWidgets  canvasWidgets = lens _canvasWidgets (\f a -> f { _canvasWidgets = a } ) -+-- | lens for notified item+notifiedItem :: Simple Lens (CanvasInfo a) (Maybe (PageNum,BBox,RItem))+notifiedItem = lens _notifiedItem (\f a -> f { _notifiedItem = a })  -- | data CanvasInfoBox = CanvasSinglePage (CanvasInfo SinglePage) @@ -287,12 +294,12 @@   -- | -unboxSet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b -> CanvasInfoBox-unboxSet l (CanvasSinglePage a) b = CanvasSinglePage (set l b a)-unboxSet l (CanvasContPage a) b = CanvasContPage (set l b a) +unboxSet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> b -> CanvasInfoBox -> CanvasInfoBox+unboxSet l b (CanvasSinglePage a) = CanvasSinglePage (set l b a)+unboxSet l b (CanvasContPage a) = CanvasContPage (set l b a)   unboxLens :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> Simple Lens CanvasInfoBox b-unboxLens l = lens (unboxGet l) (unboxSet l) +unboxLens l = lens (unboxGet l) (flip (unboxSet l))   -- |  boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b) 

@@ -21,7 +21,7 @@ -- from other packages  import           Control.Applicative import           Control.Concurrent-import           Control.Lens ((^.),(.~))+import           Control.Lens ((^.),(.~),(%~)) -- import           Control.Monad.Error import           Control.Monad.Reader  import           Control.Monad.State@@ -42,17 +42,11 @@  -- | data MainOp i o where -  DoEvent :: MainOp MyEvent () +  DoEvent :: MainOp AllEvent ()  -doEvent :: (Monad m) => MyEvent -> CObjT MainOp m () +doEvent :: (Monad m) => AllEvent -> CObjT MainOp m ()  doEvent ev = request (Arg DoEvent ev) >> return () -{--instance (Monad m) => MonadState HoodleState (EStT HoodleState m) where-  get = lift get-  put = lift . put --}- -- | type MainCoroutine = MainObjB                       @@ -62,29 +56,32 @@ type MainObj = SObjT MainOp (EStT HoodleState WorldObjB)  -- | -nextevent :: MainCoroutine MyEvent +nextevent :: MainCoroutine UserEvent  nextevent = do Arg DoEvent ev <- request (Res DoEvent ())-               return ev +               case ev of+                 SysEv sev -> sysevent sev >> nextevent +                 UsrEv uev -> return uev  +sysevent :: SystemEvent -> MainCoroutine () +sysevent ev = liftIO $ print ev + -- | -type WorldObj = SObjT (WorldOp MyEvent DriverB) DriverB  +type WorldObj = SObjT (WorldOp AllEvent DriverB) DriverB    -- | -type WorldObjB = SObjBT (WorldOp MyEvent DriverB) DriverB +type WorldObjB = SObjBT (WorldOp AllEvent DriverB) DriverB   -- |  world :: HoodleState -> MainObj () -> WorldObj ()--- world :: HoodleState -> (ReaderT (Arg MainOp) MainCoroutine ()) -> WorldObj () world xstate initmc = ReaderT staction     where      staction req = runStateT erract xstate >> return ()-      -- where erract = go initmc req        where erract = do r <- runEitherT (go initmc req)                          case r of                            Left e -> liftIO (errorlog (show e)) -                          Right _r' -> return () --  return r' +                          Right _r' -> return ()      go :: MainObj() -          -> Arg (WorldOp MyEvent DriverB) +          -> Arg (WorldOp AllEvent DriverB)            -> EStT HoodleState WorldObjB ()      go mcobj (Arg GiveEvent ev) = do        Right mcobj' <- liftM (fmap fst) (mcobj <==| doEvent ev)@@ -113,10 +110,10 @@   -- | -type Driver a = D.Driver MyEvent IO a -- SObjT MainOp IO a +type Driver a = D.Driver AllEvent IO a -- SObjT MainOp IO a   -- | -type DriverB = SObjBT (D.DrvOp MyEvent) IO  +type DriverB = SObjBT (D.DrvOp AllEvent) IO    -- |  type EventVar = MVar (Maybe (Driver ()))@@ -127,6 +124,11 @@ -- |  maybeError :: String -> Maybe a -> MainCoroutine a maybeError str = maybe (lift . hoistEither . Left . Other $ str) return +++-- | +doIOaction :: ((AllEvent -> IO ()) -> IO AllEvent) -> MainCoroutine ()+doIOaction action = modify (tempQueue %~ enqueue (mkIOaction action))   

@@ -21,8 +21,12 @@ --  import           Data.Hoodle.Predefined --- | page add direction+-- | drawing efficiency+data DrawFlag = Clear | BkgEfficient | Efficient+              deriving (Eq,Ord,Show) ++-- | page add direction data AddDirection = PageBefore | PageAfter                   deriving (Show,Eq,Ord,Enum) 

@@ -3,20 +3,25 @@ -- Module      : Hoodle.Type.Event  -- Copyright   : (c) 2011-2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC --+-- GUI events in hoodle application+-- -----------------------------------------------------------------------------  module Hoodle.Type.Event where  -- from other package+import Control.Monad import Data.ByteString  import Data.IORef+import Data.Time.Clock import Graphics.UI.Gtk -- from hoodle-platform+import           Control.Monad.Trans.Crtn.Event  import Data.Hoodle.Simple -- from this package import Hoodle.Device @@ -25,43 +30,57 @@ import Hoodle.Type.PageArrangement  -- | +data AllEvent = UsrEv UserEvent | SysEv SystemEvent+              deriving Show  -data MyEvent = Initialized-             | CanvasConfigure Int Double Double -             | UpdateCanvas Int-             | PenDown Int PenButton PointerCoord-             | PenMove Int PointerCoord-             | PenUp   Int PointerCoord -             | PenColorChanged PenColor-             | PenWidthChanged Int -             | AssignPenMode (Either PenType SelectType) -             | BackgroundStyleChanged BackgroundStyle -             | HScrollBarMoved Int Double-             | VScrollBarMoved Int Double -             | VScrollBarStart Int Double-             | VScrollBarEnd   Int Double-             | PaneMoveStart -             | PaneMoveEnd -             | ToViewAppendMode-             | ToSelectMode-             | ToSinglePage-             | ToContSinglePage-             | Menu MenuEvent -             | ActionOrdered-             | GotOk-             | OkCancel Bool -             | FileChosen (Maybe FilePath)-             | ColorChosen (Maybe PenColor) -             | GotClipboardContent (Maybe [Item])-             | ContextMenuCreated-             | GotContextMenuSignal ContextMenuEvent-             | LaTeXInput (Maybe (ByteString,ByteString))-             | TextInput (Maybe String) -             | AddLink (Maybe (String,FilePath))-             | EventDisconnected-             | GetHoodleFileInfo (IORef (Maybe String))-             | GotLink (Maybe String) (Int,Int)-             deriving Show+-- | +data SystemEvent = TestSystemEvent +                 deriving Show ++-- | +data UserEvent = Initialized+               | CanvasConfigure Int Double Double +               | UpdateCanvas Int+               | PenDown Int PenButton PointerCoord+               | PenMove Int PointerCoord+               | PenUp   Int PointerCoord +               | TouchDown Int PointerCoord+               | TouchMove Int PointerCoord+               | TouchUp Int PointerCoord +               | PenColorChanged PenColor+               | PenWidthChanged Int +               | AssignPenMode (Either PenType SelectType) +               | BackgroundStyleChanged BackgroundStyle +               | HScrollBarMoved Int Double+               | VScrollBarMoved Int Double +               | VScrollBarStart Int Double+               | VScrollBarEnd   Int Double+               | PaneMoveStart +               | PaneMoveEnd +               | ToViewAppendMode+               | ToSelectMode+               | ToSinglePage+               | ToContSinglePage+               | Menu MenuEvent +               | GotOk+               | OkCancel Bool +               | FileChosen (Maybe FilePath)+               | ColorChosen (Maybe PenColor) +               | GotClipboardContent (Maybe [Item])+               | ContextMenuCreated+               | GotContextMenuSignal ContextMenuEvent+               | LaTeXInput (Maybe (ByteString,ByteString))+               | TextInput (Maybe String) +               | AddLink (Maybe (String,FilePath))+               | EventDisconnected+               | GetHoodleFileInfo (IORef (Maybe String))+               | GotLink (Maybe String) (Int,Int)+               | Sync UTCTime +               | FileReloadOrdered+               | CustomKeyEvent String +               | GotRevision String String+               | ActionOrdered                 +               deriving Show                        instance Show (IORef a) where                         show _ = "IORef"@@ -82,6 +101,10 @@                | MenuEmbedPredefinedImage3                                 | MenuPrint                 | MenuExport +               | MenuStartSync+               | MenuVersionSave+               | MenuShowRevisions+               | MenuShowUUID                | MenuQuit                 | MenuUndo                 | MenuRedo @@ -130,7 +153,7 @@                | MenuSelectRegion                | MenuSelectRectangle                | MenuVerticalSpace-               | MenuHandTool+               --   | MenuHandTool                | MenuPenOptions                | MenuEraserOptions                 | MenuHighlighterOptions@@ -143,11 +166,14 @@                | MenuSetAsDefaultOption                | MenuRelaunch                | MenuUseXInput+               | MenuUseTouch                 | MenuSmoothScroll                | MenuUsePopUpMenu                | MenuEmbedImage                | MenuEmbedPDF-               | MenuWidgetToggle+               | MenuFollowLinks+               | MenuTogglePanZoomWidget+               | MenuToggleLayerWidget                | MenuDiscardCoreEvents                 | MenuEraserTip                 | MenuPressureSensitivity@@ -182,15 +208,22 @@                       | CMenuAutosavePage                       | CMenuLinkConvert Link                       | CMenuCreateALink +                      | CMenuAssocWithNewFile                       | CMenuCustom                       deriving (Show, Ord, Eq)   -- | -viewModeToMyEvent :: RadioAction -> IO MyEvent-viewModeToMyEvent a = do +viewModeToUserEvent :: RadioAction -> IO UserEvent+viewModeToUserEvent a = do      v <- radioActionGetCurrentValue a     case v of        1 -> return ToSinglePage       0 -> return ToContSinglePage       _ -> return ToSinglePage++-- | +mkIOaction :: ((AllEvent -> IO ()) -> IO AllEvent) -> Either (ActionOrder AllEvent) AllEvent+mkIOaction = Left . ActionOrder  ++ 

@@ -47,12 +47,15 @@ , statusBar --  , hoodleFileName +, lastSavedTime -- , doesUseXInput +, doesUseTouch , doesSmoothScroll  , doesUsePopUpMenu , doesEmbedImage , doesEmbedPDF+, doesFollowLinks --  , penModeSignal , pageModeSignal@@ -132,7 +135,7 @@                 , _rootContainer :: Box                 , _rootOfRootWindow :: Window                 , _currentPenDraw :: PenDraw-                , _callBack ::  MyEvent -> IO ()+                , _callBack ::  AllEvent -> IO ()                 , _deviceList :: DeviceList                 , _penInfo :: PenInfo                 , _selectInfo :: SelectInfo @@ -146,7 +149,7 @@                 , _isOneTimeSelectMode :: IsOneTimeSelectMode                 , _lastTimeCanvasConfigure :: Maybe UTCTime                  , _hookSet :: Maybe Hook-                , _tempQueue :: Queue (Either (ActionOrder MyEvent) MyEvent)+                , _tempQueue :: Queue (Either (ActionOrder AllEvent) AllEvent)                 , _tempLog :: String -> String                  , _statusBar :: Maybe Statusbar                 } @@ -193,7 +196,7 @@ currentPenDraw = lens _currentPenDraw (\f a -> f { _currentPenDraw = a } )  -- | lens for callBack-callBack :: Simple Lens HoodleState (MyEvent -> IO ())+callBack :: Simple Lens HoodleState (AllEvent -> IO ()) callBack = lens _callBack (\f a -> f { _callBack = a } )  -- | lens for deviceList@@ -251,7 +254,7 @@ hookSet = lens _hookSet (\f a -> f { _hookSet = a } )  -- | lens for tempQueue-tempQueue :: Simple Lens HoodleState (Queue (Either (ActionOrder MyEvent) MyEvent))+tempQueue :: Simple Lens HoodleState (Queue (Either (ActionOrder AllEvent) AllEvent)) tempQueue = lens _tempQueue (\f a -> f { _tempQueue = a } )  -- | lens for tempLog@@ -264,12 +267,20 @@  -- |  data HoodleFileControl = -  HoodleFileControl { _hoodleFileName :: Maybe FilePath } +  HoodleFileControl { _hoodleFileName :: Maybe FilePath +                    , _lastSavedTime  :: Maybe UTCTime +                    }   -- | lens for currFileName hoodleFileName :: Simple Lens HoodleFileControl (Maybe FilePath) hoodleFileName = lens _hoodleFileName (\f a -> f { _hoodleFileName = a } ) +-- | lens for last saved time+lastSavedTime :: Simple Lens HoodleFileControl (Maybe UTCTime) +lastSavedTime = lens _lastSavedTime (\f a -> f { _lastSavedTime = a } )+++ -- |  data UIComponentSignalHandler =    UIComponentSignalHandler{ _penModeSignal :: Maybe (ConnectId RadioAction)@@ -298,10 +309,12 @@ -- | A set of Hoodle settings  data Settings =    Settings { _doesUseXInput :: Bool +           , _doesUseTouch :: Bool             , _doesSmoothScroll :: Bool             , _doesUsePopUpMenu :: Bool             , _doesEmbedImage :: Bool             , _doesEmbedPDF :: Bool +           , _doesFollowLinks :: Bool             }     @@ -309,6 +322,10 @@ doesUseXInput :: Simple Lens Settings Bool doesUseXInput = lens _doesUseXInput (\f a -> f { _doesUseXInput = a } ) +-- | flag for touch+doesUseTouch :: Simple Lens Settings Bool+doesUseTouch = lens _doesUseTouch (\f a -> f { _doesUseTouch = a } )+ -- | flag for smooth scrolling  doesSmoothScroll :: Simple Lens Settings Bool doesSmoothScroll = lens _doesSmoothScroll (\f a -> f { _doesSmoothScroll = a } )@@ -325,6 +342,11 @@ doesEmbedPDF :: Simple Lens Settings Bool doesEmbedPDF = lens _doesEmbedPDF (\f a -> f { _doesEmbedPDF = a } ) +-- | flag for embedding pdf background as base64 in hdl file +doesFollowLinks :: Simple Lens Settings Bool+doesFollowLinks = lens _doesFollowLinks (\f a -> f { _doesFollowLinks = a } )++ -- | default hoodle state  emptyHoodleState :: IO HoodleState  emptyHoodleState = do@@ -366,7 +388,9 @@  emptyHoodleFileControl :: HoodleFileControl  emptyHoodleFileControl = -  HoodleFileControl { _hoodleFileName = Nothing } +  HoodleFileControl { _hoodleFileName = Nothing +                    , _lastSavedTime = Nothing +                    }    defaultUIComponentSignalHandler :: UIComponentSignalHandler@@ -383,10 +407,12 @@ defaultSettings =    Settings    { _doesUseXInput = False+  , _doesUseTouch = True   , _doesSmoothScroll = False   , _doesUsePopUpMenu = True    , _doesEmbedImage = True    , _doesEmbedPDF = True +  , _doesFollowLinks = True   }     @@ -462,8 +488,6 @@   let cid = unboxGet canvasId cinfobox        cmap = getCanvasInfoMap xstate       cmap' = M.insert cid cinfobox cmap -      -- implement the following later-      -- page = gcast (unboxGet currentPage cinfobox) :: Page EditMode    in xstate { _currentCanvas = (cid,cinfobox)             , _cvsInfoMap = cmap' } @@ -501,13 +525,11 @@   -- | - getPageMapFromHoodleModeState :: HoodleModeState -> M.IntMap (Page EditMode) getPageMapFromHoodleModeState = either (view gpages) (view gselAll) . hoodleModeStateEither            -- | - showCanvasInfoMapViewPortBBox :: HoodleState -> IO () showCanvasInfoMapViewPortBBox xstate = do    let cmap = getCanvasInfoMap xstate

@@ -108,15 +108,17 @@ xformViewPortFitInSize :: Dimension -> (BBox -> BBox) -> ViewPortBBox -> ViewPortBBox xformViewPortFitInSize (Dim w h) f (ViewPortBBox bbx) =    let BBox (x1,y1) (x2,y2) = f bbx +      xmargin = if 0.5*((x2-x1)-w) > 0 then 0.5*((x2-x1)-w) else 0+      ymargin = if 0.5*((y2-y1)-h) > 0 then 0.5*((y2-y1)-h) else 0        (x1',x2')          | x2>w && w-(x2-x1)>0  = (w-(x2-x1),w) -        | x2>w && w-(x2-x1)<=0 = (0,x2-x1)     -        | x1<0 = (0,x2-x1)+        | x2>w && w-(x2-x1)<=0 = (-xmargin,-xmargin+x2-x1) -- (0,x2-x1)     +        | x1< (-xmargin) = (-xmargin,-xmargin+x2-x1) -- (0,x2-x1)         | otherwise            = (x1,x2)       (y1',y2')          | y2>h && h-(y2-y1)>0  = (h-(y2-y1),h)-        | y2>h && h-(y2-y1)<=0 = (0,y2-y1)-        | y1 <0 = (0,y2-y1)+        | y2>h && h-(y2-y1)<=0 = (-ymargin,-ymargin+y2-y1) -- (0,y2-y1)+        | y1 < (-ymargin) =  (-ymargin,-ymargin+y2-y1) --  (0,y2-y1)         | otherwise            = (y1,y2)   in ViewPortBBox (BBox (x1',y1') (x2',y2') )       

@@ -16,8 +16,11 @@  -- |  +millisec = 1000000000+ dtime_bound :: NominalDiffTime -dtime_bound = realToFrac (picosecondsToDiffTime 100000000000)+dtime_bound = realToFrac (picosecondsToDiffTime (50*millisec))+  -- realToFrac (picosecondsToDiffTime 100000000000)  -- |  

@@ -12,40 +12,126 @@ --  ----------------------------------------------------------------------------- -module Hoodle.Type.Widget where+module Hoodle.Type.Widget +( +-- * types+  WidgetItem(..)+, CanvasWidgets      +, WidgetConfig+, LayerWidgetConfig +-- * lenses +, panZoomWidgetPosition+, panZoomWidgetTouchIsZoom+, panZoomWidgetConfig +, layerWidgetConfig+, layerWidgetPosition+, layerWidgetShowContent+, widgetConfig +, doesUsePanZoomWidget+, doesUseLayerWidget+-- * defaults +, defaultCanvasWidgets+, defaultLWConfig +, defaultWidgetConfig+-- * utility+, allWidgets+) where  import Control.Lens (Simple,Lens,lens)  --  import Hoodle.Type.PageArrangement  + -- | +data WidgetItem = PanZoomWidget | LayerWidget+                deriving (Show,Eq,Ord)++-- | +allWidgets = [PanZoomWidget, LayerWidget] +++-- | +data PanZoomWidgetConfig = PZWConfig { _panZoomWidgetPosition :: CanvasCoordinate+                                     , _panZoomWidgetTouchIsZoom :: Bool  +                                     } +                           +-- | +panZoomWidgetPosition :: Simple Lens PanZoomWidgetConfig CanvasCoordinate+panZoomWidgetPosition = lens _panZoomWidgetPosition (\f a -> f { _panZoomWidgetPosition = a })++-- | +panZoomWidgetTouchIsZoom :: Simple Lens PanZoomWidgetConfig Bool +panZoomWidgetTouchIsZoom = lens _panZoomWidgetTouchIsZoom (\f a -> f { _panZoomWidgetTouchIsZoom = a})++-- |+data LayerWidgetConfig = LWConfig { _layerWidgetPosition :: CanvasCoordinate+                                  , _layerWidgetShowContent :: Bool+                                  }+-- | +layerWidgetPosition :: Simple Lens LayerWidgetConfig CanvasCoordinate +layerWidgetPosition = lens _layerWidgetPosition (\f a -> f { _layerWidgetPosition = a })+                         +-- | +layerWidgetShowContent :: Simple Lens LayerWidgetConfig Bool+layerWidgetShowContent = lens _layerWidgetShowContent (\f a -> f { _layerWidgetShowContent = a})+++-- |  data CanvasWidgets = -  CanvasWidgets { _testWidgetPosition :: CanvasCoordinate+  CanvasWidgets { _panZoomWidgetConfig :: PanZoomWidgetConfig+                , _layerWidgetConfig :: LayerWidgetConfig                  , _widgetConfig :: WidgetConfig                  }     -- | -testWidgetPosition :: Simple Lens CanvasWidgets CanvasCoordinate-testWidgetPosition = lens _testWidgetPosition (\f a -> f { _testWidgetPosition = a} )+panZoomWidgetConfig :: Simple Lens CanvasWidgets PanZoomWidgetConfig +panZoomWidgetConfig = lens _panZoomWidgetConfig (\f a -> f { _panZoomWidgetConfig = a }) +-- | +layerWidgetConfig :: Simple Lens CanvasWidgets LayerWidgetConfig +layerWidgetConfig = lens _layerWidgetConfig (\f a -> f { _layerWidgetConfig = a })++ -- | default hoodle widgets defaultCanvasWidgets :: CanvasWidgets defaultCanvasWidgets =    CanvasWidgets-  { _testWidgetPosition = CvsCoord (100,100)+  { _panZoomWidgetConfig = defaultPZWConfig +  , _layerWidgetConfig = defaultLWConfig    , _widgetConfig = defaultWidgetConfig    }    +-- | +defaultPZWConfig :: PanZoomWidgetConfig +defaultPZWConfig = +  PZWConfig { _panZoomWidgetPosition = CvsCoord (100,100) +            , _panZoomWidgetTouchIsZoom = False +            } +-- | +defaultLWConfig :: LayerWidgetConfig +defaultLWConfig = +  LWConfig { _layerWidgetPosition = CvsCoord (100,300) +           , _layerWidgetShowContent = False +           } -data WidgetConfig = WidgetConfig { _doesUsePanZoom :: Bool } +data WidgetConfig = WidgetConfig { _doesUsePanZoomWidget :: Bool +                                 , _doesUseLayerWidget :: Bool +                                 }   -- | flag for pan zoom widget -doesUsePanZoom :: Simple Lens WidgetConfig Bool -doesUsePanZoom = lens _doesUsePanZoom (\f a -> f {_doesUsePanZoom = a})+doesUsePanZoomWidget :: Simple Lens WidgetConfig Bool +doesUsePanZoomWidget = lens _doesUsePanZoomWidget (\f a -> f {_doesUsePanZoomWidget = a}) +-- | flag for layer widget +doesUseLayerWidget :: Simple Lens WidgetConfig Bool +doesUseLayerWidget = lens _doesUseLayerWidget (\f a -> f {_doesUseLayerWidget = a}) ++ -- | default widget configuration  defaultWidgetConfig :: WidgetConfig -defaultWidgetConfig = WidgetConfig { _doesUsePanZoom = True } +defaultWidgetConfig = WidgetConfig { _doesUsePanZoomWidget = False+                                   , _doesUseLayerWidget = False+                                   }    -- | widget config lens 

@@ -30,29 +30,7 @@ --  import Data.Hoodle.Simple -- -import Debug.Trace----- for test--- import Blaze.ByteString.Builder--- import Text.Hoodle.Builder --{--testPage :: Page Edit -> IO () -testPage page = do-    let pagesimple = toPage bkgFromBkgPDF . tpageBBoxMapPDFFromTPageBBoxMapPDFBuf $ page -    L.putStrLn . toLazyByteString . Text.Hoodle.Builder.fromPage $ pagesimple --}--             -{--testHoodle :: HoodleState -> IO () -testHoodle hdlstate = do-  let hdlsimple :: Hoodle = case hdlstate of-                               ViewAppendState hdl -> xournalFromTHoodleSimple (gcast hdl :: THoodleSimple)-                               SelectState thdl -> xournalFromTHoodleSimple (gcast thdl :: THoodleSimple)-  L.putStrLn (builder hdlsimple)--}+-- import Debug.Trace  (#) :: a -> (a -> b) -> b  (#) = flip ($)@@ -123,7 +101,7 @@                  return (b,rem)            r = parseOnly p (B.pack str)       in case r of -           Left _ -> Nothing -- Just (FileUrl str) +           Left _ -> Nothing              Right (b,f) -> case b of                              N -> Just (FileUrl f)                             F -> Just (FileUrl (unEscapeString f))@@ -131,9 +109,3 @@                             HS -> Just (HttpUrl ("https://" ++ f))      -{--timeShow :: String -> IO () -timeShow msg = -  putStrLn . (msg ++) . (formatTime defaultTimeLocale "%Q") -    =<< getCurrentTime --}

@@ -144,11 +144,13 @@ core2Desktop geometry = canvas2Desktop geometry . CvsCoord   -- |- wacom2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate wacom2Desktop geometry (x,y) = let Dim w h = unScreenDimension (screenDim geometry)                                in screen2Desktop geometry . ScrCoord $ (w*x,h*y)                                    +touch2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate+touch2Desktop = wacom2Desktop + -- |  wacom2Canvas :: CanvasGeometry -> (Double,Double) -> CanvasCoordinate                       @@ -163,6 +165,7 @@     Core -> core2Desktop geometry (x,y)     Stylus -> wacom2Desktop geometry (x,y)     Eraser -> wacom2Desktop geometry (x,y)+    Touch -> touch2Desktop geometry (x,y) device2Desktop _geometry NoPointerCoord = error "NoPointerCoordinate device2Desktop"           -- | 

@@ -5,7 +5,7 @@ -- Module      : Hoodle.View.Draw  -- Copyright   : (c) 2011-2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -17,22 +17,24 @@ import Control.Applicative  import Control.Monad.Trans import Control.Monad.Trans.Maybe-import Graphics.UI.Gtk hiding (get,set)-import Graphics.Rendering.Cairo-import Control.Category ((.))+-- import           Control.Category ((.)) import           Control.Lens (view,set,at) import Control.Monad (when)-import Data.Foldable+import Data.Foldable hiding (elem) import qualified Data.IntMap as M-import Data.Maybe hiding (fromMaybe)-import Data.Monoid-import Data.Sequence+import           Data.Maybe hiding (fromMaybe)+import           Data.Monoid+import           Data.Sequence+import           Graphics.UI.Gtk hiding (get,set)+import           Graphics.Rendering.Cairo+import           Graphics.Rendering.Pango.Cairo -- from hoodle-platform  import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Predefined import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..),Stroke(..))+import Data.Hoodle.Zipper (currIndex,current) import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Highlight import Graphics.Hoodle.Render.Type@@ -48,11 +50,8 @@ import Hoodle.Util import Hoodle.View.Coordinate -- -import Prelude hiding ((.),id,mapM_,concatMap,foldr)+import Prelude hiding (mapM_,concatMap,foldr) --- | -data DrawFlag = Clear | BkgEfficient | Efficient-              deriving (Eq,Ord,Show)                         -- |  type family DrawingFunction v :: * -> * @@ -80,11 +79,9 @@                       -> IO (Hoodle a) }                      -- | - type instance DrawingFunction SinglePage = SinglePageDraw  -- | - type instance DrawingFunction ContinuousPage = ContPageDraw  -- | @@ -116,15 +113,16 @@                         -> Render () -- pre-render before source paint                          -> Render () -- post-render after source paint                          -> m ()-virtualDoubleBufferDraw sfc sfc2 pre post = -    renderWith sfc2 $ do +virtualDoubleBufferDraw srcsfc tgtsfc pre post = +    renderWith tgtsfc $ do        pre-      setSourceSurface sfc 0 0 +      setSourceSurface srcsfc 0 0        setOperator OperatorSource        paint       setOperator OperatorOver       post             +-- |  doubleBufferFlush :: ViewMode a => Surface -> CanvasInfo a -> IO ()  doubleBufferFlush sfc cinfo = do        let canvas = view drawArea cinfo @@ -158,7 +156,8 @@ 	      rndr  	  Just sfc -> do  	    r <- renderWith sfc $ do -	      clipBBox (fmap (flip inflate (-1.0)) mbbox')+	      -- clipBBox (fmap (flip inflate (-1.0)) mbbox') -- temporary+              clipBBox mbbox'                setSourceRGBA 0.5 0.5 0.5 1               rectangle 0 0 cw ch                fill@@ -189,15 +188,16 @@    -- |  drawCurvebitGen  :: PressureMode -                    -> (DrawingArea, Maybe Surface)+                    -> DrawingArea                     -> CanvasGeometry                      -> Double                      -> (Double,Double,Double,Double)                      -> PageNum +                    -> Seq (Double,Double,Double)                     -> ((Double,Double),Double)                      -> ((Double,Double),Double)                      -> IO () -drawCurvebitGen pmode (canvas,_msfc) geometry wdth (r,g,b,a) pnum ((x0,y0),z0) ((x,y),z) = do +drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum pdraw ((x0,y0),z0) ((x,y),z) = do    win <- widgetGetDrawWindow canvas   renderWithDrawable win $ do     cairoXform4PageCoordinate geometry pnum @@ -205,9 +205,15 @@     case pmode of        NoPressure -> do          setLineWidth wdth-        moveTo x0 y0-        lineTo x y-        stroke+        case viewl pdraw of +          EmptyL -> return ()+          (xo,yo,_) :< rest -> do +            moveTo xo yo+            mapM_ (\(x',y',_)-> lineTo x' y') rest +            lineTo x y+            stroke+        -- moveTo x0 y0+        -- lineTo x y       Pressure -> do          let wx0 = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z0             wy0 = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z0@@ -236,9 +242,6 @@                 pg <- render (pnum,page) mbboxnew flag                 -- Start Widget                 when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)  -                -- widget test-                -- let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew -                -- renderTestWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)                 -- End Widget                 resetClip                  return pg @@ -263,6 +266,7 @@   rectangle 0 0 cw ch    stroke +-- | highlight current page emphasisPageRender :: CanvasGeometry -> (PageNum,Page EditMode) -> Render () emphasisPageRender geometry (pn,pg) = do      save@@ -275,7 +279,19 @@     stroke     restore  +-- | highlight notified item (like link)+emphasisNotifiedRender :: CanvasGeometry -> (PageNum,BBox,RItem) -> Render ()+emphasisNotifiedRender geometry (pn,BBox (x1,y1) (x2,y2),_) = do +    save+    identityMatrix +    cairoXform4PageCoordinate geometry pn +    setSourceRGBA 1.0 1.0 0 0.1 +    rectangle x1 y1 (x2-x1) (y2-y1)+    fill +    restore  ++ -- | drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page EditMode))                     -> DrawingFunction ContinuousPage EditMode@@ -308,11 +324,11 @@                 let npgs = foldr rfunc pgs ndrawpgs                           where rfunc (k,pg) m = M.adjust (const pg) k m                  let nhdl = set gpages npgs hdl  -                maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg +                mapM_ (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg +                mapM_ (emphasisNotifiedRender geometry) (view notifiedItem cinfo)                  when isCurrentCvs (emphasisCanvasRender ColorRed geometry)                 let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew                 -                when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $-                  renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo) +                drawWidgets allWidgets hdl cinfo mbbox_canvas                  resetClip                  return nhdl            doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -364,10 +380,10 @@                                     lift (selpagerender (PageNum n,tpage))                  let nthdl2 = set gselSelected r nthdl                 maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg +                mapM_ (emphasisNotifiedRender geometry) (view notifiedItem cinfo)                                  when isCurrentCvs (emphasisCanvasRender ColorGreen geometry)                   let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew                 -                when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $-                  renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)+                drawWidgets allWidgets hdl cinfo mbbox_canvas                 resetClip                  return nthdl2             doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -528,34 +544,6 @@   rectangle (0.5*(x1+x2)-hsize*0.6) (y2-hsize*0.6) (1.2*hsize) (1.2*hsize)   fill -renderPanZoomWidget :: Maybe BBox -> CanvasCoordinate -> Render () -renderPanZoomWidget mbbox (CvsCoord (x,y)) = do -  identityMatrix -  clipBBox mbbox -  setSourceRGBA 0.5 0.5 0.2 0.3 -  rectangle x y 100 100 -  fill -  setSourceRGBA 0.2 0.2 0.7 0.5-  rectangle (x+10) (y+10) 40 80-  fill -  setSourceRGBA 0.2 0.7 0.2 0.5 -  rectangle (x+50) (y+10) 40 80-  fill -  setSourceRGBA 0.7 0.2 0.2 0.5-  rectangle (x+30) (y+30) 40 40 -  fill  -  setSourceRGBA 0.5 0.5 0.5 0.5-  rectangle (x+90) y 10 10-  fill-  setSourceRGBA 0 0 0 0.7 -  setLineWidth 1-  moveTo (x+90) y -  lineTo (x+100) (y+10)-  stroke -  moveTo (x+90) (y+10)-  lineTo (x+100) y-  stroke-  resetClip    -- | @@ -598,4 +586,147 @@   renderWith sfc renderfunc    return (sfc, Dim w_cvs h_cvs) +---------------------------------------------------+--                Widgets                        --+---------------------------------------------------++-- | +drawWidgets :: ViewMode a => +               [WidgetItem] -> Hoodle EditMode -> CanvasInfo a -> Maybe BBox -> Render () +drawWidgets witms hdl cinfo mbbox = do  +  when (PanZoomWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo) $+    renderPanZoomWidget (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo)+      mbbox (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo) +  when (LayerWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseLayerWidget) cinfo) +    (drawLayerWidget hdl cinfo mbbox (view (canvasWidgets.layerWidgetConfig.layerWidgetPosition) cinfo))+++-- | +renderPanZoomWidget :: Bool -> Maybe BBox -> CanvasCoordinate -> Render () +renderPanZoomWidget b mbbox (CvsCoord (x,y)) = do +  identityMatrix +  clipBBox mbbox +  setSourceRGBA 0.5 0.5 0.2 0.3 +  rectangle x y 100 100 +  fill +  setSourceRGBA 0.2 0.2 0.7 0.5+  rectangle (x+10) (y+10) 40 80+  fill +  setSourceRGBA 0.2 0.7 0.2 0.5 +  rectangle (x+50) (y+10) 40 80+  fill +  setSourceRGBA 0.7 0.2 0.2 (if b then 1.0 else 0.5)+  rectangle (x+30) (y+30) 40 40 +  fill  +  setSourceRGBA 0.5 0.5 0.5 0.5+  rectangle x y 10 10+  fill+  setSourceRGBA 0 0 0 0.7 +  setLineWidth 1+  moveTo x y +  lineTo (x+10) (y+10)+  stroke +  moveTo x (y+10)+  lineTo (x+10) y+  stroke+  resetClip ++drawLayerWidget :: ViewMode a => +                   Hoodle EditMode +                   -> CanvasInfo a +                   -> Maybe BBox +                   -> CanvasCoordinate +                   -> Render ()+drawLayerWidget hdl cinfo mbbox cvscoord = do     +    let cpn = view currentPageNum cinfo+        lc = view (canvasWidgets.layerWidgetConfig) cinfo +    runMaybeT $ do +      pg <- MaybeT . return $ view (gpages.at cpn) hdl+      let lyrs = view glayers pg+          n = currIndex lyrs +          l = current lyrs +          LyBuf msfc = view gbuffer l+      lift $ renderLayerWidget (show n) mbbox cvscoord +      when (view layerWidgetShowContent lc) $ do +        sfc <- MaybeT . return $ msfc +        lift $ renderLayerContent mbbox (view gdimension pg) sfc cvscoord+    return () ++renderLayerContent :: Maybe BBox -> Dimension -> Surface -> CanvasCoordinate -> Render ()+renderLayerContent mbbox (Dim w h) sfc (CvsCoord (x,y)) = do +  identityMatrix +  clipBBox mbbox +  let sx = 200 / w+  rectangle (x+100) y 200 (h*200/w)+  setLineWidth 0.5 +  setSourceRGBA 0 0 0 1 +  stroke +  translate (x+100) (y) +  scale sx sx +  setSourceSurface sfc 0 0 +  paint +  ++-- | +renderLayerWidget :: String -> Maybe BBox -> CanvasCoordinate -> Render () +renderLayerWidget str mbbox (CvsCoord (x,y)) = do +  identityMatrix +  clipBBox mbbox +  setSourceRGBA 0.5 0.5 0.2 0.3 +  rectangle x y 100 100 +  fill +  rectangle x y 10 10+  fill+  setSourceRGBA 0 0 0 0.7 +  setLineWidth 1+  moveTo x y +  lineTo (x+10) (y+10)+  stroke +  moveTo x (y+10)+  lineTo (x+10) y+  stroke+  -- upper right+  setSourceRGBA 0 0 0 0.4+  moveTo (x+80) y +  lineTo (x+100) y+  lineTo (x+100) (y+20)+  fill +  -- lower left+  setSourceRGBA 0 0 0 0.1+  moveTo x (y+80)+  lineTo x (y+100)+  lineTo (x+20) (y+100)+  fill +  -- middle right+  setSourceRGBA 0 0 0 0.3+  moveTo (x+90) (y+40)+  lineTo (x+100) (y+50)+  lineTo (x+90) (y+60)+  fill+  -- +  identityMatrix +  l1 <- createLayout "layer"+  updateLayout l1 +  (_,reclog) <- liftIO $ layoutGetExtents l1+  let PangoRectangle _ _ w1 h1 = reclog +  moveTo (x+15) y+  let sx1 = 50 / w1 +      sy1 = 20 / h1 +  scale sx1 sy1 +  layoutPath l1+  setSourceRGBA 0 0 0 0.4+  fill+  -- +  identityMatrix+  l <- createLayout str +  updateLayout l +  (_,reclog) <- liftIO $ layoutGetExtents l+  let PangoRectangle _ _ w h = reclog +  moveTo (x+30) (y+20)+  let sx = 40 / w +      sy = 60 / h +  scale sx sy +  layoutPath l +  setSourceRGBA 0 0 0 0.4+  fill 

@@ -0,0 +1,78 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.Default +-- Copyright   : (c) 2011-2013 Ian-Woo Kim+--+-- License     : GPL-3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Widget.Dispatch where++import Control.Applicative ((<|>))+import Control.Lens (view,set,over)+import Control.Monad.State hiding (forM_)+import Control.Monad.Trans.Maybe+import qualified Data.ByteString.Char8 as B+import Data.Foldable (forM_)+import Data.Time +import Graphics.Rendering.Cairo +-- +import Data.Hoodle.BBox+import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Util.HitTest+import Graphics.Hoodle.Render.Type.Item+-- +import Hoodle.Device +import Hoodle.ModelAction.ContextMenu+import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.HoodleState+import Hoodle.Type.Widget+import Hoodle.Type.PageArrangement+import Hoodle.Util+import Hoodle.View.Coordinate +import Hoodle.View.Draw +import Hoodle.Widget.Layer+import Hoodle.Widget.PanZoom+-- +-- import Prelude hiding (forM_)++widgetCheckPen :: CanvasId +               -> PointerCoord +               -> MainCoroutine ()    -- ^ default action +               -> MainCoroutine ()+widgetCheckPen cid pcoord defact = get >>= \xst -> boxAction (chk xst) (getCanvasInfo cid xst) +  where +    chk :: (ViewMode a) => HoodleState -> CanvasInfo a -> MainCoroutine () +    chk xstate cinfo = do +      let cvs = view drawArea cinfo+          pnum = (PageNum . view currentPageNum) cinfo +          arr = view (viewInfo.pageArrangement) cinfo+      geometry <- liftIO $ makeCanvasGeometry pnum arr cvs +      let triplet = (cid,cinfo,geometry)+      m <- runMaybeT $ +             (lift . startPanZoomWidget PenMode triplet <=< MaybeT . return . checkPointerInPanZoom triplet) pcoord+             <|> +             (lift . startLayerWidget triplet <=< MaybeT . return . checkPointerInLayer triplet) pcoord+             <|> +             (do guard (view (settings.doesFollowLinks) xstate)   +                 (pnum,bbox,ritem) <- (MaybeT . return . view notifiedItem) cinfo+                 (pnum',PageCoord (x,y)) <- (MaybeT . return . desktop2Page geometry . device2Desktop geometry) pcoord +                 guard (pnum == pnum') +                 guard (isPointInBBox bbox (x,y))+                 case ritem of+                   RItemLink lnkbbx _ -> do +                     forM_ ((urlParse . B.unpack .  link_location . bbxed_content) lnkbbx)+                           (liftIO . openLinkAction)+                     liftIO $ putStrLn "I am in" +                     MaybeT (return (Just ()))+                   _ -> MaybeT (return Nothing))+      case m of        +        Nothing -> defact +        Just _ -> return ()

@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Widget.Layer+-- Copyright   : (c) 2013 Ian-Woo Kim+--+-- License     : GPL-3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Layer widget+-- +-----------------------------------------------------------------------------++module Hoodle.Widget.Layer where++import Control.Lens (view,set,over)+import Control.Monad.State +import Control.Monad.Trans+import           Data.List (delete)+import           Data.Sequence+import           Data.Time+import           Graphics.Rendering.Cairo+--+import           Data.Hoodle.BBox+import           Data.Hoodle.Simple +import           Graphics.Hoodle.Render.Util.HitTest+--+import           Hoodle.Coroutine.Draw+import           Hoodle.Coroutine.Layer+import           Hoodle.Coroutine.Pen+import           Hoodle.Device+import           Hoodle.ModelAction.Select+import           Hoodle.Type.Canvas+import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum+import           Hoodle.Type.Event+import           Hoodle.Type.HoodleState +import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Widget+import           Hoodle.View.Coordinate+import           Hoodle.View.Draw++-- |+data LWAction = Close | ToggleShowContent | Move (CanvasCoordinate,CanvasCoordinate)++checkPointerInLayer :: ViewMode a => +                       (CanvasId,CanvasInfo a,CanvasGeometry) +                    -> PointerCoord +                    -> Maybe LWAction -- (Maybe (CanvasCoordinate,CanvasCoordinate))+checkPointerInLayer (cid,cinfo,geometry) pcoord +  | b =  +    let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord+        owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.layerWidgetConfig.layerWidgetPosition) cinfo+        obbox = BBox (x0,y0) (x0+100,y0+100) +        closebbox = BBox (x0,y0) (x0+10,y0+10)+        r | isPointInBBox closebbox (x,y) = Just Close+          | hitLassoPoint (fromList [(x0+90,y0+40),(x0+100,y0+50),(x0+90,y0+60)]) (x,y) = Just ToggleShowContent     +        +          | isPointInBBox obbox (x,y)     = Just (Move (oxy,owxy))+          | otherwise                     = Nothing   +    in r+  | otherwise = Nothing +  where b = view (canvasWidgets.widgetConfig.doesUseLayerWidget) cinfo ++startLayerWidget :: ViewMode a =>+                    (CanvasId,CanvasInfo a,CanvasGeometry)+                 -> LWAction -- Maybe (CanvasCoordinate,CanvasCoordinate)+                 -> MainCoroutine () +startLayerWidget (cid,cinfo,geometry) Close = toggleLayer cid +startLayerWidget (cid,cinfo,geometry) ToggleShowContent = do +    liftIO $ putStrLn "ToggleShowContent hitted"+    modify (over (currentCanvasInfo . unboxLens (canvasWidgets.layerWidgetConfig.layerWidgetShowContent)) not)+    invalidate cid +startLayerWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do +    xst <- get +    let hdl = getHoodle xst+    (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface Nothing geometry hdl)+    -- need to draw other widgets here                             +    let otherwidgets = delete LayerWidget allWidgets +    liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) +    -- end : need to draw other widgets here ^^^+    tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)+    ctime <- liftIO getCurrentTime +    let CvsCoord (x0,y0) = owxy +        CvsCoord (x,y) = oxy +        act +          | hitLassoPoint (fromList [(x0+80,y0),(x0+100,y0),(x0+100,y0+20)]) (x,y) = gotoNextLayer+          | hitLassoPoint (fromList [(x0,y0+80),(x0,y0+100),(x0+20,y0+100)]) (x,y) = gotoPrevLayer +          | otherwise = manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy ctime +    act+    liftIO $ surfaceFinish srcsfc +    liftIO $ surfaceFinish tgtsfc+  +-- | main event loop for layer widget+manipulateLW :: CanvasId +             -> CanvasGeometry +             -> (Surface,Surface) +             -> CanvasCoordinate +             -> CanvasCoordinate +             -> UTCTime +             -> MainCoroutine () +manipulateLW cid geometry (srcsfc,tgtsfc) +             owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do +    r <- nextevent+    case r of +      PenMove _ pcoord -> do +        processWithDefTimeInterval+          (manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy) +          (\ctime -> moveLayerWidget cid geometry (srcsfc,tgtsfc) owxy oxy pcoord +                     >> manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy ctime)+          otime +      PenUp _ pcoord -> invalidate cid +      _ -> return ()++moveLayerWidget :: CanvasId +                   -> CanvasGeometry +                   -> (Surface,Surface) +                   -> CanvasCoordinate +                   -> CanvasCoordinate +                   -> PointerCoord+                   -> MainCoroutine ()+moveLayerWidget cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do +    let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord +    xst <- get +    let CanvasDimension (Dim cw ch) = canvasDim geometry +        cinfobox = getCanvasInfo cid xst +        nposx | xw+x-x0 < -50 = -50 +              | xw+x-x0 > cw-50 = cw-50 +              | otherwise = xw+x-x0+        nposy | yw+y-y0 < -50 = -50 +              | yw+y-y0 > ch-50 = ch-50 +              | otherwise = yw+y-y0                             +        nwpos = CvsCoord (nposx,nposy) +        changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a +        changeact cinfo =  +          set (canvasWidgets.layerWidgetConfig.layerWidgetPosition) nwpos $ cinfo+        ncinfobox = selectBox changeact changeact  cinfobox+    put (setCanvasInfo (cid,ncinfobox) xst)+    let hdl = getHoodle xst ++    -- +    xst2 <- get +    let cinfobox = getCanvasInfo cid xst2 +    liftIO $ boxAction (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) +                                    (drawLayerWidget hdl cinfo Nothing nwpos) +                                 >> doubleBufferFlush tgtsfc cinfo) cinfobox+  +-- | +toggleLayer :: CanvasId -> MainCoroutine () +toggleLayer cid = do +  modify (\xst -> +            let ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseLayerWidget)) not +                             . getCanvasInfo cid ) xst +            in setCanvasInfo (cid,ncinfobox) xst)+  invalidateInBBox Nothing Efficient cid

@@ -3,7 +3,7 @@ -- Module      : Hoodle.Widget.PanZoom -- Copyright   : (c) 2013 Ian-Woo Kim ----- License     : BSD3+-- License     : GPL-3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,9 +18,11 @@ import           Control.Lens (view,set,over) import           Control.Monad.Identity  import           Control.Monad.State +import           Data.List (delete) import           Data.Time.Clock  import           Graphics.Rendering.Cairo --- import           Graphics.UI.Gtk hiding (get,set) +import           Graphics.UI.Gtk hiding (get,set) +import           System.Process -- from hoodle-platform  import           Data.Hoodle.BBox import           Data.Hoodle.Simple@@ -28,6 +30,7 @@ -- from this package  import           Hoodle.Accessor import           Hoodle.Coroutine.Draw+import           Hoodle.Coroutine.File import           Hoodle.Coroutine.Page import           Hoodle.Coroutine.Pen  import           Hoodle.Coroutine.Scroll@@ -35,6 +38,7 @@ import           Hoodle.ModelAction.Page  import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event import           Hoodle.Type.HoodleState  import           Hoodle.Type.PageArrangement @@ -45,50 +49,66 @@  data PanZoomMode = Moving | Zooming | Panning Bool -widgetCheckPen :: CanvasId -> PointerCoord -               -> MainCoroutine () -               -> MainCoroutine ()-widgetCheckPen cid pcoord act = do -    xst <- get-    let cinfobox = getCanvasInfo cid xst -        b = view (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) cinfobox-    if b then boxAction (f xst) cinfobox else act -  where -    f xst cinfo = do -      let cvs = view drawArea cinfo-          pnum = (PageNum . view currentPageNum) cinfo -          arr = view (viewInfo.pageArrangement) cinfo-      geometry <- liftIO $ makeCanvasGeometry pnum arr cvs -      let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord-      let owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.testWidgetPosition) cinfo-          obbox = BBox (x0,y0) (x0+100,y0+100) -          pbbox1 = BBox (x0+10,y0+10) (x0+50,y0+90)-          pbbox2 = BBox (x0+50,y0+10) (x0+90,y0+90)-          pbbox3 = BBox (x0+90,y0) (x0+100,y0+10)-          zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)-      if (isPointInBBox obbox (x,y))  -         then do -           let mmode | isPointInBBox zbbox (x,y) = Just Zooming -                     | isPointInBBox pbbox1 (x,y) = Just (Panning False)-                     | isPointInBBox pbbox2 (x,y) = Just (Panning True)-                     | isPointInBBox pbbox3 (x,y) = Nothing-                     | otherwise = Just Moving -           let hdl = getHoodle xst-           case mmode of -             Nothing -> togglePanZoom-             Just mode -> do -               (sfc,Dim wsfc hsfc) <- case mode of -                                        Moving -> liftIO (canvasImageSurface Nothing geometry hdl)-                                        Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl)-                                        Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) -               sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)-               ctime <- liftIO getCurrentTime -               startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime -               liftIO $ surfaceFinish sfc -               liftIO $ surfaceFinish sfc2-         else act +data PanZoomTouch = TouchMode | PenMode +                  deriving (Show,Eq,Ord) ++checkPointerInPanZoom :: (ViewMode a) => +                         (CanvasId,CanvasInfo a,CanvasGeometry) +                      -> PointerCoord +                      -> Maybe (Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate)))+checkPointerInPanZoom (cid,cinfo,geometry) pcoord +  | b = +    let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord+        owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo+        obbox = BBox (x0,y0) (x0+100,y0+100) +        pbbox1 = BBox (x0+10,y0+10) (x0+50,y0+90)+        pbbox2 = BBox (x0+50,y0+10) (x0+90,y0+90)+        pbbox3 = BBox (x0,y0) (x0+10,y0+10)+        zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)+    in if (isPointInBBox obbox (x,y))  +       then let mmode | isPointInBBox zbbox (x,y) = Just (Zooming,(oxy,owxy))+                   | isPointInBBox pbbox1 (x,y) = Just (Panning False,(oxy,owxy))+                   | isPointInBBox pbbox2 (x,y) = Just (Panning True,(oxy,owxy))+                   | isPointInBBox pbbox3 (x,y) = Nothing+                   | otherwise = Just (Moving,(oxy,owxy))+            in (Just mmode)+       else Nothing   +  | otherwise = Nothing +  where b = view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo+++ -- | +startPanZoomWidget :: (ViewMode a) =>+                   PanZoomTouch +                   -> (CanvasId,CanvasInfo a,CanvasGeometry)+                   -> Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate))+                   -> MainCoroutine ()+startPanZoomWidget tchmode (cid,cinfo,geometry) mmode = do +    xst <- get +    let hdl = getHoodle xst+    case mmode of +      Nothing -> togglePanZoom cid+      Just (mode,(oxy,owxy)) -> do +        (srcsfc,Dim wsfc hsfc) <- case mode of +                                    Moving -> liftIO (canvasImageSurface Nothing geometry hdl)+                                    Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl)+                                    Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) +        -- need to draw other widgets here                             +        let otherwidgets = delete PanZoomWidget allWidgets +        liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) +        -- end : need to draw other widgets here ^^^+        tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)+        ctime <- liftIO getCurrentTime +        manipulatePZW (tchmode,mode) cid geometry (srcsfc,tgtsfc) owxy oxy ctime +        liftIO $ surfaceFinish srcsfc +        liftIO $ surfaceFinish tgtsfc+++++-- |  findZoomXform :: Dimension                 -> ((Double,Double),(Double,Double),(Double,Double))                 -> (Double,(Double,Double))@@ -103,9 +123,11 @@         zy | zty > 2 = 2              | zty < 0.5 = 0.5            | otherwise = zty                                          -        z | zx >= 1 && zy >= 1 = max zx zy+        {- z | zx >= 1 && zy >= 1 = max zx zy           | zx < 1 && zy < 1 = min zx zy -          | otherwise = zx+          | otherwise = zx -}+        -- simplified+        z = zx          xtrans = (1 -z)*xo/z-w         ytrans = (1- z)*yo/z-h      in (z,(xtrans,ytrans))@@ -125,26 +147,37 @@            | otherwise = ty      in ((dx-w),(dy-h)) --- | -startWidgetAction :: PanZoomMode -                     -> CanvasId -                     -> CanvasGeometry -                     -> (Surface,Surface)-                     -> CanvasCoordinate -- ^ original widget position-                     -> CanvasCoordinate -- ^ where pen pressed -                     -> UTCTime-                     -> MainCoroutine ()-startWidgetAction mode cid geometry (sfc,sfc2)-                  owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do+-- | manipulate Pan-Zoom widget until released when grabbing the widget+manipulatePZW :: (PanZoomTouch,PanZoomMode) +              -> CanvasId +              -> CanvasGeometry +              -> (Surface,Surface) -- ^ (Source Surface, Target Surface)+              -> CanvasCoordinate -- ^ original widget position+              -> CanvasCoordinate -- ^ where pen pressed +              -> UTCTime+              -> MainCoroutine ()+manipulatePZW fullmode@(tchmode,mode) cid geometry (srcsfc,tgtsfc)+              owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do   r <- nextevent   case r of -    PenMove _ pcoord -> do +    PenMove _ pcoord   -> if (tchmode /= PenMode) then again otime else moveact pcoord +    TouchMove _ pcoord -> if (tchmode /= TouchMode) then again otime else do +      b <- liftM (view (settings.doesUseTouch)) get+      when b $ moveact pcoord+    PenUp _ pcoord     -> if (tchmode /= PenMode) then again otime else upact pcoord +    TouchUp _ pcoord   -> if (tchmode /= TouchMode) then again otime else do +      b <- liftM (view (settings.doesUseTouch)) get +      when b $ upact pcoord +    _ -> again otime -- manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy otime+  where +    again t = manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy t+    moveact pcoord =        processWithDefTimeInterval-        (startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy) -        (\ctime -> movingRender mode cid geometry (sfc,sfc2) owxy oxy pcoord -                   >> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime)+        again -- (manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy) +        (\ctime -> movingRender mode cid geometry (srcsfc,tgtsfc) owxy oxy pcoord +                   >> manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy ctime)         otime -    PenUp _ pcoord -> do +    upact pcoord = do        case mode of          Zooming -> do            let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord @@ -172,73 +205,141 @@             (\(xorig,yorig)->(xorig-dx_d,yorig-dy_d))                          _ -> return ()       invalidate cid -    _ -> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy otime ++ -- |  movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface)                  -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord                  -> MainCoroutine () -movingRender mode cid geometry (sfc,sfc2) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do -          let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord -          xst <- get -          case mode of-            Moving -> do -              let CanvasDimension (Dim cw ch) = canvasDim geometry -                  cinfobox = getCanvasInfo cid xst -                  nposx | xw+x-x0 < -50 = -50 -                        | xw+x-x0 > cw-50 = cw-50 -                        | otherwise = xw+x-x0-                  nposy | yw+y-y0 < -50 = -50 -                        | yw+y-y0 > ch-50 = ch-50 -                        | otherwise = yw+y-y0                             -                  nwpos = CvsCoord (nposx,nposy) -                  changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a -                  changeact cinfo =  -                    set (canvasWidgets.testWidgetPosition) nwpos $ cinfo-                  ncinfobox = selectBox changeact changeact  cinfobox-              put (setCanvasInfo (cid,ncinfobox) xst)-              virtualDoubleBufferDraw sfc sfc2 (return ()) (renderPanZoomWidget Nothing nwpos)-            Zooming -> do -              let cinfobox = getCanvasInfo cid xst               -              let pos = runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox )-              let (xo,yo) = (xw+50,yw+50)-                  CanvasDimension cdim = canvasDim geometry -                  (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))-              virtualDoubleBufferDraw sfc sfc2 -                (save >> scale z z >> translate xtrans ytrans)-                (restore >> renderPanZoomWidget Nothing pos)-            Panning b -> do -              let cinfobox = getCanvasInfo cid xst               -                  CanvasDimension cdim = canvasDim geometry -                  (xtrans,ytrans) = findPanXform cdim ((x0,y0),(x,y))-              let CanvasDimension (Dim cw ch) = canvasDim geometry -                  nposx | xw+x-x0 < -50 = -50 -                        | xw+x-x0 > cw-50 = cw-50 -                        | otherwise = xw+x-x0-                  nposy | yw+y-y0 < -50 = -50 -                        | yw+y-y0 > ch-50 = ch-50 -                        | otherwise = yw+y-y0                             -                  nwpos = if b -                          then CvsCoord (nposx,nposy) -                          else -                            runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox)-                  -- changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a -                  -- changeact cinfo =  -                  --   set (canvasWidgets.testWidgetPosition) nwpos $ cinfo-                  --             selectBox changeact changeact  cinfobox-                  ncinfobox = set (unboxLens (canvasWidgets.testWidgetPosition)) nwpos cinfobox-              put (setCanvasInfo (cid,ncinfobox) xst)-              virtualDoubleBufferDraw sfc sfc2 -                (save >> translate xtrans ytrans) -                (restore >> renderPanZoomWidget Nothing nwpos)-          --   -          xst2 <- get -          let cinfobox = getCanvasInfo cid xst2 -          liftIO $ boxAction (doubleBufferFlush sfc2) cinfobox+movingRender mode cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do +    let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord +    xst <- get +    case mode of+      Moving -> do +        let CanvasDimension (Dim cw ch) = canvasDim geometry +            cinfobox = getCanvasInfo cid xst +            nposx | xw+x-x0 < -50 = -50 +                  | xw+x-x0 > cw-50 = cw-50 +                  | otherwise = xw+x-x0+            nposy | yw+y-y0 < -50 = -50 +                  | yw+y-y0 > ch-50 = ch-50 +                  | otherwise = yw+y-y0                             +            nwpos = CvsCoord (nposx,nposy) +            changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a +            changeact cinfo =  +              set (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) nwpos $ cinfo+            ncinfobox = selectBox changeact changeact  cinfobox+            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox                         +        put (setCanvasInfo (cid,ncinfobox) xst)+        virtualDoubleBufferDraw srcsfc tgtsfc (return ()) (renderPanZoomWidget isTouchZoom Nothing nwpos)+      Zooming -> do +        let cinfobox = getCanvasInfo cid xst               +        let pos = runIdentity (boxAction (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)+        let (xo,yo) = (xw+50,yw+50)+            CanvasDimension cdim = canvasDim geometry +            (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))+            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox             +        virtualDoubleBufferDraw srcsfc tgtsfc +          (save >> scale z z >> translate xtrans ytrans)+          (restore >> renderPanZoomWidget isTouchZoom Nothing pos)+      Panning b -> do +        let cinfobox = getCanvasInfo cid xst               +            CanvasDimension cdim = canvasDim geometry +            (xtrans,ytrans) = findPanXform cdim ((x0,y0),(x,y))+        let CanvasDimension (Dim cw ch) = canvasDim geometry +            nposx | xw+x-x0 < -50 = -50 +                  | xw+x-x0 > cw-50 = cw-50 +                  | otherwise = xw+x-x0+            nposy | yw+y-y0 < -50 = -50 +                  | yw+y-y0 > ch-50 = ch-50 +                  | otherwise = yw+y-y0                             +            nwpos = if b +                    then CvsCoord (nposx,nposy) +                    else +                      runIdentity (boxAction (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)+            ncinfobox = set (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) nwpos cinfobox+            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox +        put (setCanvasInfo (cid,ncinfobox) xst)+        virtualDoubleBufferDraw srcsfc tgtsfc +          (save >> translate xtrans ytrans) +          (restore >> renderPanZoomWidget isTouchZoom Nothing nwpos)+    --   +    xst2 <- get +    let cinfobox = getCanvasInfo cid xst2 +    liftIO $ boxAction (doubleBufferFlush tgtsfc) cinfobox     -- | -togglePanZoom :: MainCoroutine () -togglePanZoom = do -  modify (over (currentCanvasInfo . unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) not)-  invalidateAll  +togglePanZoom :: CanvasId -> MainCoroutine () +togglePanZoom cid = do +    modify $ \xst -> +      let cinfobox = getCanvasInfo cid xst +          ncinfobox = over (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) not cinfobox+      in setCanvasInfo (cid,ncinfobox) xst +    invalidateInBBox Nothing Efficient cid +++-- | +touchStart :: CanvasId -> PointerCoord -> MainCoroutine () +touchStart cid pcoord = boxAction chk =<< liftM (getCanvasInfo cid) get+  where+    chk :: (ViewMode a) => CanvasInfo a -> MainCoroutine () +    chk cinfo = do +      let cvs = view drawArea cinfo+          pnum = (PageNum . view currentPageNum) cinfo +          arr = view (viewInfo.pageArrangement) cinfo+      geometry <- liftIO $ makeCanvasGeometry pnum arr cvs +      let triplet = (cid,cinfo,geometry)+          oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord+          owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo  +          obbox = BBox (x0,y0) (x0+100,y0+100) +      xst <- get+          +      if (isPointInBBox obbox (x,y))     +        then do +          let changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a +              changeact = over (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) not +              ncinfobox = selectBox changeact changeact . getCanvasInfo cid $ xst+          put (setCanvasInfo (cid,ncinfobox) xst)+          invalidateInBBox Nothing Efficient cid +        else do +          let b = view (settings.doesUseTouch) xst+              isZoomTouch = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo+          if b +            then if isZoomTouch then startPanZoomWidget TouchMode triplet (Just (Zooming,(oxy,oxy)))+                                else startPanZoomWidget TouchMode triplet (Just (Panning False,(oxy,oxy)))+            else do +              let devlst = view deviceList xst +              doIOaction $ \_ -> do+                setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst+                -- ad hoc +                let touchstr = dev_touch_str devlst+                when (touchstr /= "touch") $ do +                  readProcess "xinput" [ "disable", dev_touch_str devlst ] "" +                  return ()+                -- +                return (UsrEv ActionOrdered)+              waitSomeEvent (\e -> case e of TouchUp _ _ -> True ; _ -> False) >> return ()+++toggleTouch :: MainCoroutine () +toggleTouch = do +    updateFlagFromToggleUI "HANDA"  (settings.doesUseTouch)+    xst <- get +    let devlst = view deviceList xst +    let b = view (settings.doesUseTouch) xst+    when b $ do +      -- ad hoc +      let touchstr = dev_touch_str devlst      +      when (touchstr /= "touch") $ do +        liftIO $ readProcess "xinput" [ "enable", dev_touch_str devlst ] ""   +        return ()+      --+      let (cid,cinfobox) = view currentCanvas xst +      put (set (currentCanvasInfo. unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) True xst)+      invalidateInBBox Nothing Efficient cid   +      return ()++    +