diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Main where + +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word32) +import Debug.Trace (trace) +--import Diagrams.Backend.SVG.CmdLine (B, mainWith) +--import Diagrams.Prelude +import GHC.Generics +import Graph.CommonGraph (Channel, CGraph, CGraphL, EdgeType (..), NodeClass (..), EdgeClass (..), UINode) +import Graph.GraphDrawing (fromAdj, layeredGraph) +import qualified Graph.IntMap as Graph +--import Graphics.SVGFonts (textSVG) + +-- several papers use this graph +testGraph :: CGraph UINodeLabel UIEdgeLabel +testGraph = fromAdj (extractNodes gr) gr + where + gr = + [ (0, [4, 5, 6, 20, 29], dEdge), + (17, [3], dEdge), + (5, [2, 3, 4, 10, 14, 26], dEdge), + (3, [4], dEdge), + (26, [18], dEdge), + (14, [10], dEdge), + (2, [8, 23], dEdge), + (18, [13], dEdge), + (10, [27], dEdge), + (2, [8, 23], dEdge), + (23, [24, 9], dEdge), + (24, [12, 15, 28], dEdge), + (1, [12], dEdge), + (12, [6, 9, 19], dEdge), + (6, [9, 13, 21, 25, 29], dEdge), + (29, [25], dEdge), + (21, [22], dEdge), + (25, [11], dEdge), + (22, [8, 9], dEdge), + (15, [27, 16], dEdge), + (8, [16, 20], dEdge), + (11, [16, 9], dEdge), + (16, [27], dEdge), + (27, [13, 19], dEdge), + (13, [20], dEdge), + (19, [9], dEdge), + (20, [4], dEdge), + (9, [4, 28], dEdge), + (28, [7], dEdge) + ] + +testGraph2 :: CGraph UINodeLabel UIEdgeLabel +testGraph2 = fromAdj (extractNodes gr) gr + where + gr = + [ (1, [3, 4, 21, 13], dEdge), + (2, [3, 20], dEdge), + (3, [4, 5, 23], dEdge), + (4, [6], dEdge), + (5, [7], dEdge), + (6, [8, 16, 23], dEdge), + (7, [9], dEdge), + (8, [10, 11], dEdge), + (9, [12], dEdge), + (10, [13, 14, 15], dEdge), + (11, [15, 16], dEdge), + (12, [20], dEdge), + (13, [17], dEdge), + (14, [17, 18], dEdge), + (16, [18, 19, 20], dEdge), + (18, [21], dEdge), + (19, [22], dEdge), + (21, [23], dEdge), + (22, [23], dEdge), + (23, [24], dEdge), + (24, [25], dEdge), + (26, [27], dEdge), + (27, [28], dEdge), + (29, [30], dEdge), + (30, [31], dEdge), + (32, [31], dEdge), + (33, [31], dEdge), + (25, [34], dEdge), + -- (19, [26], dEdge), + (23, [27], vdummyEdge), + (27, [30], vdummyEdge) + ] + +-- A typical graph of three unconnected functions with one input and output. +-- Should be displayed vertical as options +-- Vertical lines between the function nodes give an order. If the graph grows the vertical nodes should +-- still be in one column +optionsGraph :: CGraph UINodeLabel UIEdgeLabel +optionsGraph = fromAdj (extractNodes gr) gr + where + gr = + [ (1, [2], dEdge), + (2, [3], dEdge), + (4, [5], dEdge), + (5, [6], dEdge), + (7, [8], dEdge), + (8, [9], dEdge), + (9, [10], dEdge), + (2, [5], vdummyEdge), + (5, [8], vdummyEdge) + ] + +dEdge :: [UIEdgeLabel] +dEdge = [standard NormalEdge] + +-- [UIEdge 2 1 "" Curly "#ff5863" "" 0 False False] + +vdummyEdge :: [UIEdgeLabel] +vdummyEdge = [standard VirtualHorEdge] + +-- [UIEdge 2 1 "" Curly "#ff5863" "" 0 True False] +extractNodes :: EdgeClass e => [(Word32, [Word32], [e])] -> Map.Map Word32 UINodeLabel +extractNodes adj = Map.fromList (map labelNode nodes) + where + nodes = (map sel1 adj) ++ (concat (map sel2 adj)) + sel1 (x, y, z) = x + sel2 (x, y, z) = y + labelNode n = + ( n, + UINodeLabel + ( FuN + ( FunctionNode + "" + (T.pack (show n)) + "" + ) + ) + ) + +main :: IO () +main = return () -- mainWith (visualGraph (layeredGraph True testGraph) :: Diagram B) + +------------------------------------------------------------------------------------------------ + +data UINodeLabel = UINodeLabel + { + uinode :: SpecialNode [Text] + } + deriving (Show) + +data UIEdgeLabel = UIEdgeLabel + { lineClass :: Text, + strokeWidth :: Maybe Int, + opacity :: Maybe Double, + dashArray :: Maybe Text, + lineColor :: Maybe Text, + lineName :: Text, + lineType :: Maybe LineType, + channelNrIn :: Maybe Channel, -- arg nr x of constructor node + + -- | Me, Colleague-Name to remeber past decisions, but only people you know, + -- or company, group + channelNrOut :: Channel, -- function output is connected with input nr x of type node + edgeType :: EdgeType + } + deriving (Show) + +data LineType + = Slanted Int -- a line consisiting of slanted sublines, + -- (a lot of people did this, but no famous) + | Curly -- contains a several subpaths + deriving (Show, Generic, Eq, Ord) + +data SpecialNode a + = FuN FunctionNode + | SubN [a] + | DN DummyNode + | CN ConnectionNode + | AN ArgNode + deriving (Eq, Ord, Show, Generic) + +data DummyNode = DummyNode {dsize :: Int} deriving (Eq, Ord, Show, Generic) + +data ConnectionNode = ConnectionNode {size :: Int} deriving (Eq, Ord, Show, Generic) + +data FunctionNode = FunctionNode + { functionUnique :: Text, + functionName :: Text, + functionType :: Text -- maybe not displayed + } + deriving (Eq, Ord, Generic, Show) + +data ArgNode = ArgNode + { refFunctionUnique :: Text, + argName :: Text, + argNr :: Int, + isValueArg :: Bool, + isMainFunctionArg :: Bool, + argSelected :: Bool + } + deriving (Eq, Ord, Show, Generic) + +instance NodeClass UINodeLabel where + isDummy gr n = False -- maybe False isDummyLabel (Graph.lookupNode n gr) + isConnNode gr n = maybe False isConnLabel (Graph.lookupNode n gr) + isFunction gr n = maybe False isFuncLabel (Graph.lookupNode n gr) + isMainArg gr n = False -- maybe False isArgLabel (Graph.lookupNode n gr) + isSubLabel (UINodeLabel (SubN _)) = True + isSubLabel _ = False + isArgLabel (UINodeLabel (AN _)) = True + isArgLabel _ = False + subLabels (UINodeLabel (SubN as)) = length as + connectionNode = UINodeLabel (CN (ConnectionNode 1)) + dummyNode x = UINodeLabel (DN (DummyNode x)) + nestingFeatures _ = Nothing + updateLayer _ n = n + verticalNumber _ = Nothing + +instance EdgeClass UIEdgeLabel where + dummyEdge chIn chOut = UIEdgeLabel "" Nothing Nothing Nothing Nothing "" Nothing chIn chOut NormalEdge + standard edgeType = UIEdgeLabel "" Nothing Nothing Nothing Nothing "" Nothing Nothing 0 edgeType + edgeType (UIEdgeLabel _ _ _ _ _ _ _ _ _ e) = e + channelNrIn (UIEdgeLabel _ _ _ _ _ _ _ channelIn channelOut _) = channelIn + channelNrOut (UIEdgeLabel _ _ _ _ _ _ _ channelIn channelOut _) = channelOut + +isDummyLabel :: UINodeLabel -> Bool +isDummyLabel (UINodeLabel (DN _)) = True +isDummyLabel _ = False + +isConnLabel :: UINodeLabel -> Bool +isConnLabel (UINodeLabel (CN _)) = True +isConnLabel _ = False + +isFuncLabel :: UINodeLabel -> Bool +isFuncLabel (UINodeLabel (FuN _)) = True +isFuncLabel _ = False + +isArgLabel :: UINodeLabel -> Bool +isArgLabel (UINodeLabel (AN _)) = True +isArgLabel _ = False + +----------------------------------------------------------------------------------------------- + +-- Using diagrams to visualise the graph (this is commented out, so that you only need the quite big diagrams dependency when using this for debugging) +{- +visualGraph :: (NodeClass n, EdgeClass e) => CGraphL n e -> Diagram B +visualGraph (g, nPositions) = + Debug.Trace.trace (show (length shortEs) ++ " : " ++ show (length longEs) ++ show (Graph.nodes testGraph, Graph.nodes g)) $ + position graphNodes # connections shortEs + # connectionsWithoutArrow longEs + where + graphNodes = catMaybes (map pos (Graph.nodes g)) + pos n = fmap (\(x, y) -> (p2 ((fromIntegral x) * 2, (fromIntegral y)), vNode (fromIntegral n))) lu + where + lu = Map.lookup (fromIntegral n) nPositions + es = Graph.edges g + shortEs = filter (\(src, tgt) -> not (isConnNode g src) && not (isConnNode g tgt)) es + longEs = filter (\(src, tgt) -> (isConnNode g src) || (isConnNode g tgt)) es + vNode :: Int -> Diagram B + vNode n = visualNode (n > 31) (show n) -- (isDummyNode g (fromIntegral n)) (show n) + +connections es + | (length es) < 2 = id + | otherwise = + foldr1 (.) $ + map + ( \(src, tgt) -> + connectOutside' arrowStyle2 (show src) (show tgt) + ) + es + +connectionsWithoutArrow es + | (length es) < 2 = id + | otherwise = + foldr1 (.) $ + map + ( \(src, tgt) -> + connectOutside' arrowStyle3 (show src) (show tgt) + ) + es + +visualNode l str + | l -- (stateLabel str <> + = + dummy # named str + | otherwise = (stateLabel str <> state) # named str + +text' d s = (strokeP $ textSVG s 0.7) # lw none # fc black # center # showOrigin + +stateLabel = text' 0.6 + +arrowLabel txt size = text' size txt + +state = circle 0.4 # fc silver + +dummy = circle 0.05 # fc black -- mempty + +shaft = arc xDir (-1 / 6 @@ turn) + +shaft' = arc xDir (-2.7 / 5 @@ turn) + +line = trailFromOffsets [unitX] + +arrowStyle1 = + ( with & arrowHead .~ spike & headLength .~ small + & arrowShaft .~ shaft + ) + +arrowStyle2 = + ( with & arrowHead .~ spike & headLength .~ small + & arrowShaft .~ line + ) + +arrowStyle3 = (with & arrowHead .~ noHead & arrowShaft .~ line) -- & shaftStyle %~ dashingG [0.1, 0.05] 0) +-} diff --git a/layered-graph-drawing.cabal b/layered-graph-drawing.cabal new file mode 100644 --- /dev/null +++ b/layered-graph-drawing.cabal @@ -0,0 +1,46 @@ +name: layered-graph-drawing +version: 0.1.0.0 +synopsis: Layered Graph Drawing after Sugiyama +description: Calculates the positions of graph nodes in a table with layered graph drawing +homepage: https://github.com/BeFunctional/layered-graph-drawing +license: BSD3 +license-file: LICENSE +author: Tillmann Vogt +maintainer: tillk.vogt@gmail.com +copyright: 2023 Tillmann Vogt +category: graphics, graph +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Graph.CommonGraph + , Graph.GraphDrawing + , Graph.SubGraphWindows + build-depends: aeson + , base >= 4.7 && < 5 + , containers + , data-ordlist + , intmap-graph + , text + , vector + , vector-algorithms + default-language: Haskell2010 + +executable graph-drawing-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , containers + , layered-graph-drawing +-- , diagrams +-- , diagrams-lib +-- , diagrams-svg + , intmap-graph +-- , SVGFonts + , text + + default-language: Haskell2010 + diff --git a/src/Graph/CommonGraph.hs b/src/Graph/CommonGraph.hs new file mode 100644 --- /dev/null +++ b/src/Graph/CommonGraph.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Graph.CommonGraph where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.IntMap as I +import Data.List (group, sort) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust) +import qualified Data.Vector.Unboxed as VU +import Data.Word (Word32, Word8) +import Debug.Trace (trace) +import GHC.Generics (Generic) +import Graph.IntMap + ( Edge8 (..), + EdgeAttribute (..), + ExtractNodeType (..), + Graph (..), + adjacentNodesByAttr, + ) + +type UINode = Word32 + +-- A Graph consists of nodes and edges, graph drawing arranges it from left to right, +-- start to end. +type CGraph n e = Graph n [e] + +type CGraphL n e = (Graph n [e], Map UINode (Int, Int)) + +type Channel = Int -- The nth type of a type node +-- This is path of function and type nodes with spaces that can be filled with options + +data EdgeType + = NormalEdge + | VerticalEdge -- When having options, they appear continuously in one column + -- We mark this in the graph with vertical edges from the first + -- option to the second and so on + | VirtualHorEdge -- virtual edges are not displayed but used for layouting and + -- naviagtion with the keyboard + | SeparatingEdge -- to connect graph components that are separate + deriving (Show, Generic, Eq, Ord) + +type GraphMoveX = Int + +type Column = (GraphMoveX, [UINode]) + +--instance NodeClass n => Eq n where +-- node1 == node2 = uinode node1 == uinode node2 + +class NodeClass n where + isDummy :: EdgeClass e => CGraph n e -> UINode -> Bool + isConnNode :: EdgeClass e => CGraph n e -> UINode -> Bool + isFunction :: EdgeClass e => CGraph n e -> UINode -> Bool + isMainArg :: CGraph n e -> UINode -> Bool + isSubLabel :: n -> Bool + isArgLabel :: n -> Bool + subLabels :: n -> Int + connectionNode :: n + dummyNode :: Int -> n -- Depth -> n + nestingFeatures :: n -> Maybe LayerFeatures + updateLayer :: Maybe LayerFeatures -> n -> n + verticalNumber :: n -> Maybe Word32 -- we want to keep the order of vertically connected Nodes, + +type ChannelNrIn = Maybe Channel + +type ChannelNrOut = Channel + +class EdgeClass e where + dummyEdge :: ChannelNrIn -> ChannelNrOut -> e + standard :: EdgeType -> e + edgeType :: e -> EdgeType + channelNrIn :: e -> ChannelNrIn + channelNrOut :: e -> ChannelNrOut + +------------------------------------------------------------------------------------------------------ + +myFromJust :: Int -> Maybe a -> a +myFromJust i term + | isJust term -- Debug.Trace.trace ("myFromJustTrue "++ show i) + = + fromJust term + | otherwise = + Debug.Trace.trace + ("myFromJust " ++ show i) + fromJust + term + +myhead :: Int -> [a] -> a +myhead i a + | null a = error ("head: empty list " ++ show i) + | otherwise = head a + +vhead :: (VU.Unbox a) => Int -> VU.Vector a -> a +vhead i a + | VU.null a = error ("VU.head: empty list " ++ show i) + | otherwise = VU.head a + +rmdups :: (Ord a) => [a] -> [a] +rmdups = map (myhead 500) . group . sort + +------------------------------------------------------------------------------------------------------ + +vertBit :: Word8 +vertBit = 0x1 + +virtBit :: Word8 +virtBit = 0x2 + +sepBit :: Word8 +sepBit = 0x4 + +instance EdgeClass e => EdgeAttribute [e] where -- Why can two nodes be connected with more than one edge? +-- To connect one function with several input types that are part of one type node + fastEdgeAttr (e : _) = f (edgeType e) + where + f VerticalEdge = vertBit + f VirtualHorEdge = virtBit + f _ = 0 + fastEdgeAttr _ = 0 + edgeFromAttr = + Map.fromList + [ (vertBit, [standard VerticalEdge]), + (virtBit, [standard VirtualHorEdge]), + (0, [standard NormalEdge]) + ] + + -- show_e (Just [UIEdge standard Nothing 0 e]) = show e + -- show_e _ = "no Edge" + bases _ = [Edge8 0, Edge8 vertBit, Edge8 virtBit] + +childrenSeparating :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32 +childrenSeparating gr n = adjacentNodesByAttr gr True n (Edge8 sepBit) + +childrenNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 +childrenNoVertical gr n = + adjacentNodesByAttr gr True n (Edge8 virtBit) + VU.++ adjacentNodesByAttr gr True n (Edge8 0) + +childrenVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 +childrenVertical gr n = adjacentNodesByAttr gr True n (Edge8 vertBit) + +parentsVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 +parentsVertical gr n = adjacentNodesByAttr gr False n (Edge8 vertBit) + +parentsNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 +parentsNoVertical gr n = + adjacentNodesByAttr gr False n (Edge8 virtBit) + VU.++ adjacentNodesByAttr gr False n (Edge8 0) + +verticallyConnectedNodes :: EdgeClass e => CGraph n e -> UINode -> [UINode] +verticallyConnectedNodes g n = + VU.toList $ + goUp (parentsVertical g n) + VU.++ VU.cons n (goDown (childrenVertical g n)) + where + goUp nodes + | VU.null nodes = VU.empty + | otherwise = + nodes + VU.++ VU.concatMap (goUp . parentsVertical g) nodes + goDown nodes + | VU.null nodes = VU.empty + | otherwise = + nodes + VU.++ VU.concatMap (goDown . childrenVertical g) nodes + +------------------------------------------------------------------------------------------------------ + +data LayerFeatures = LayerFeatures + { layer :: Int, -- Expanding a fuction generates a new layer + -- (maybe make every new layer a little bit darker) + border :: Maybe Border -- To set the right css values (border, boxshadow) + } + deriving (Show, Generic) + +instance FromJSON LayerFeatures + +instance ToJSON LayerFeatures + +lb :: Int -> Maybe LayerFeatures +lb n = Just (LayerFeatures n (Just LeftBorder)) + +rb :: Int -> Maybe LayerFeatures +rb n = Just (LayerFeatures n (Just RightBorder)) + +tb :: Int -> Maybe LayerFeatures +tb n = Just (LayerFeatures n (Just TopBorder)) + +bb :: Int -> Maybe LayerFeatures +bb n = Just (LayerFeatures n (Just BottomBorder)) + +ltb :: Int -> Maybe LayerFeatures +ltb n = Just (LayerFeatures n (Just LeftTopBorder)) + +rtb :: Int -> Maybe LayerFeatures +rtb n = Just (LayerFeatures n (Just RightTopBorder)) + +lbb :: Int -> Maybe LayerFeatures +lbb n = Just (LayerFeatures n (Just LeftBottomBorder)) + +rbb :: Int -> Maybe LayerFeatures +rbb n = Just (LayerFeatures n (Just RightBottomBorder)) + +mid :: Int -> Maybe LayerFeatures +mid n = Just (LayerFeatures n Nothing) + +data Border + = LeftBorder + | RightBorder + | TopBorder + | BottomBorder + | LeftTopBorder + | RightTopBorder + | LeftBottomBorder + | RightBottomBorder + deriving (Show, Generic) + +instance FromJSON Border + +instance ToJSON Border diff --git a/src/Graph/GraphDrawing.hs b/src/Graph/GraphDrawing.hs new file mode 100644 --- /dev/null +++ b/src/Graph/GraphDrawing.hs @@ -0,0 +1,1478 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} +{-# HLINT ignore "Use =<<" #-} + +module Graph.GraphDrawing where + +import qualified Data.IntMap as I +import qualified Data.IntMap.Strict as IM +import Data.List (elemIndex, find, group, groupBy, intercalate, sort, sortBy, sortOn, (\\)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Tuple (swap) +import qualified Data.Vector.Algorithms.Intro as I +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as VU +import Data.Word (Word32) +import Debug.Trace (trace) +import Graph.CommonGraph + ( CGraph, + CGraphL, + Channel, + Column, + EdgeClass (channelNrIn, channelNrOut, dummyEdge, standard), + EdgeType (NormalEdge), + GraphMoveX, + LayerFeatures (LayerFeatures), + NodeClass (connectionNode, dummyNode, isConnNode, isDummy, isMainArg, isSubLabel, subLabels), + UINode, + childrenNoVertical, + childrenSeparating, + childrenVertical, + isFunction, + myFromJust, + myhead, + parentsNoVertical, + parentsVertical, + rmdups, + verticallyConnectedNodes, + vhead, + ) +import qualified Graph.CommonGraph as Common +import Graph.IntMap (Graph (..), nodes) +import qualified Graph.IntMap as Graph + +-- Also returns a map with Columns to allow navigation with arrows +layeredGraphAndCols :: + (NodeClass n, Show n, EdgeClass e, Show e) => + Bool -> + CGraph n e -> + (CGraphL n e, (Map.Map GraphMoveX [UINode], Map.Map Int [Column])) +layeredGraphAndCols cross graph = (g, getColumns g) + where + g = layeredGraph cross graph + +-- Debug with https://dreampuf.github.io/GraphvizOnline using neato or fdp engine + +-- ^ Layout a directed acyclic graph in several steps (Sugiyama) +-- 1. Assign the nodes to several layers (longest path) +-- 2. Dummy vertices for lines that are longer than a layer +-- 3. Reduce crossings, place the longest path on top +-- 4. Assign y-coordinates to the nodes so that long lines that pass several layers are +-- as straight as possible + +layeredGraph :: + (VU.Unbox UINode, NodeClass n, Show n, EdgeClass e, Show e) => + Bool -> + CGraph n e -> + CGraphL n e +layeredGraph cross graph = + -- Debug.Trace.trace ("layered "++ show graph ++"\n") -- ++ showEdges graph ++ show (Graph.edgeLabels graph)) $ -- ++"\nnewGraph\n" ++ show newGraph ++"\n") $ + newGraph + where + sortLayers (gr, ls) = (gr, map sort ls) -- makes the dummy vertices appear lower + newGraph = + ( -- subgraphWindows . + yCoordinateAssignement + -- . + -- primitiveYCoordinateAssignement + . crossingReduction 1 cross + . sortLayers + . addConnectionVertices + . longestPathAlgo + . addMissingInputNodes -- does not change the graph, only computes layers + ) + graph + +fr :: (Int, n) -> (UINode, n) +fr (n, nl) = (fromIntegral n, nl) + +graphvizNodes :: (CGraph n e, Map.Map Int [Column]) -> String +graphvizNodes (gr, m) = concatMap ((++ "\n") . sh) (I.toList (Graph.nodeLabels gr)) + where + sh (n, _nl) = show n ++ " [ pos = \"" ++ show (myFromJust 499 $ Map.lookup n m) ++ "!\"]" + +primitiveYCoordinateAssignement :: (CGraph n e, [[UINode]]) -> CGraphL n e +primitiveYCoordinateAssignement (graph, layers) = + -- Debug.Trace.trace ("primitiveY1 "++ show (graph,layers,ns)) $ + (graph, Map.fromList ns) + where + ns :: [(UINode, (Int, Int))] + ns = concat $ zipWith (\layer i -> map (incX i) layer) (map oneLayer layers) ([0 ..] :: [Int]) + oneLayer l = zip (iterate incY (0, 0)) l + incX i ((x, y), n) = (n, (x - i, y)) + incY (x, y) = (x, y + 1) +{- +primitiveYCoordinateAssignement2 :: (CGraph, [[UINode]]) -> CGraph +primitiveYCoordinateAssignement2 (g, (la:layers)) = + Debug.Trace.trace ("primitiveY2 "++ show (g, newGraph, ns, la, layers)) $ +-- ++ show (reverse $ oneLayer newLa layers)) $ + newGraph + where + newGraph = g { nodeLabels = I.fromList $ map fr2 $ map (positionNode g) (concat ns) } + ns = zipWith (\layer i -> map (incX i) layer) (oneLayer newLa layers) ([0..] :: [Int]) + newLa = zip (iterate incY (0,0)) la + oneLayer :: [((Int,Int), UINode)] -> [[UINode]] -> [[((Int,Int), UINode)]] + oneLayer l0 [] = [l0] + oneLayer l0 (l1:rest) = l0 : (oneLayer newL1 rest) + where + newL1 = childYOrInc 0 (-1) l1 + + childYOrInc _ _ [] = [] + childYOrInc y lastY (e:es) + | isJust cy && (fromJust cy) /= lastY = +-- Debug.Trace.trace ("cy " ++ show (fromJust cy) ++" "++ show e ++ " " ++ show lu) $ + ((0,fromJust cy),e) : childYOrInc ((fromJust cy)+1) (fromJust cy) es + | otherwise = +-- Debug.Trace.trace ("other y "++ show y ++" cy "++ show cy ++" "++ show e) $ + ((0,y),e) : childYOrInc (y+1) (fromMaybe y cy) es + where cy | VU.null (child e) = Nothing + | otherwise = fmap snd lu + lu = lookup (vhead 500 (child e)) (map (\(a,b) -> (b,a)) l0) + child el = childrenNoVertical g el + incX i ((x,y),n) = (x-i,y,n) + incY (x,y) = (x,y+1) +-} +{- +positionNode :: CGraph -> (Int, Int, UINode) -> (UINode, UINodeLabel) +positionNode graph (x,y,n) = + (n, UINodeLabel { option = maybe NoOption option lu, + formerNonOption = maybe False formerNonOption lu, + uinode = maybe (DN (DummyNode 1)) uinode lu, + nestingFeatures = maybe Nothing nestingFeatures lu, + verticalNumber = maybe Nothing verticalNumber lu + }) + where lu = Graph.lookupNode n graph +-} + +-- ^ See "Fast and Simple Horizontal Coordinate Assignment" (Brandes, Köpf) + +yCoordinateAssignement :: (NodeClass n, EdgeClass e) => (CGraph n e, [[UINode]]) -> CGraphL n e +yCoordinateAssignement (graph, layers) = + -- Debug.Trace.trace ("\nyCoordAssign "++ show (layers,graph,pos)) $ + (graph, pos) + where + -- newGraph = graph { nodeLabels = I.fromList placedNodes } -- for debugging (Map.fromList edgesToKeep) + pos :: Map UINode (Int, Int) + pos = horizontalBalancing lu ld ru rd + lu = biasedAlignment graph yPos medians (reverse nLayers) (True, True) + ld = biasedAlignment graph yPos medians (reverse nLayers) (True, False) + ru = biasedAlignment graph yPos medians (reverse nLayers) (False, True) + rd = biasedAlignment graph yPos medians (reverse nLayers) (False, False) + + -- for debugging + -- edgesToKeep :: [(Graph.DirEdge UINode, [UIEdge])] + -- edgesToKeep = map (\(x,y) -> (Graph.DirEdge x y, fromJust (Graph.lookupEdge (Graph.DirEdge x y) graph))) $ + -- concat $ map (sweep medians Map.empty 0 (True,True)) (tuples (reverse nLayers)) + + yPos = Map.fromList (concat enumLayers) + enumLayers = map (\l -> zip l [0 ..]) layers + nLayers = map (map connProp) layers + connProp n = (n, isConnNode graph n) + + medians = (Map.fromList lowerMedians, Map.fromList upperMedians) + upperMedians = + -- Debug.Trace.trace ("upper"++ show (map upper ns, map (getMedian . upper) ns)) $ + mapMaybe (getMedian . upper) ns + lowerMedians = + -- Debug.Trace.trace ("lower"++ show (map lower ns)) $ + mapMaybe (getMedian . lower) ns + ns = map fr $ I.toList (Graph.nodeLabels graph) + upper (n, _) = (n, VU.toList (childrenNoVertical graph n)) + lower (n, _) = (n, VU.toList (parentsNoVertical graph n)) + + getMedian (n, ns1) + | l == 0 -- Debug.Trace.trace "get l0" $ + = + Nothing + | l == 1 = Just (n, Single rightMedian) + | even l -- Debug.Trace.trace ("get lmod2"++ show (nodeLbls,ns1,(n, (leftMedian, rightMedian)))) $ + = + Just (n, UpLowMedian leftMedian rightMedian) -- an even list has two medians + | otherwise -- Debug.Trace.trace ("get other"++ show (nodeLbls,ns1,(n, (rightMedian, rightMedian)))) $ + = + Just (n, Middle rightMedian) -- an odd list has only one median + where + leftMedian = + -- Debug.Trace.trace ("median "++ show (n,ns1,nodeLbls,sorted,l)) $ + addConnProp (sorted !! ((l `div` 2) - 1)) + rightMedian = addConnProp (sorted !! (l `div` 2)) + l = length ns1 + sorted = sortBy py nodeLbls + py (y0, _) (y1, _) = compare y0 y1 + nodeLbls = map (\node -> (fromMaybe 0 (Map.lookup node yPos), node)) ns1 + addConnProp (y, node) = (y, (node, isConnNode graph node)) + +-- the paper suggest to use an average of four alignments (TODO) +horizontalBalancing :: Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y) +horizontalBalancing lu _ld _ru _rd = + -- Debug.Trace.trace ("horizontalBalancing "++ show (lu,ru)) -- ++"\n"++ show ld ++"\n"++ show average) + -- lu -- ld ru rd + lu + +-- average = zipWith f lu ru +-- f :: (UINode,(X,Y)) -> (UINode,(X,Y)) -> (UINode,(X,Y)) +-- f (n0,(x0,y0)) (n1,(x1,y1)) | n0 /= n1 = error "horizontalBalancing n0 /= n1 " +-- | otherwise = (n0, (x0, (y0+y1) `div` 2 )) + +type X = Int + +type Y = Int + +type YN = (Y, (UINode, Bool)) + +data MYN + = Single (Y, (UINode, Bool)) -- no medians because there is only one connection + | Middle (Y, (UINode, Bool)) -- an odd number of connections has only one median + | UpLowMedian (Y, (UINode, Bool)) (Y, (UINode, Bool)) + deriving (Eq, Ord, Show) -- an even number of connections has two medians + +type Median = Map UINode MYN + +biasedAlignment :: + (NodeClass n, EdgeClass e) => + CGraph n e -> + Map UINode Y -> + (Median, Median) -> + [[(UINode, Bool)]] -> + (Bool, Bool) -> + Map UINode (X, Y) +biasedAlignment graph _ medians layers dir = + -- Debug.Trace.trace ("\nbalign"++ show (layers, balign)) $ --edgesToKeep, map sweep2 (tuples layers)) ++ + -- "\nunpositioned " ++ show (map removePositioned (map (map fst) layers))) $ + balign + where + (left, _up) = dir + positioned = Map.keys balign + _removePositioned ns = ns \\ positioned + -- see with https://dreampuf.github.io/GraphvizOnline/ + balign = + -- Debug.Trace.trace ("\n\nedgesToKeep "++ show dir ++ "\ndigraph G {" ++ + -- (concat $ map line edgesToKeep) ++"\n"++ placeNodes ++ "\n}") -- \n\nmedians "++ show medians) $ + align graph (map (map fst) layers) edgesToKeep dir + edgesToKeep = rmdups $ concatMap (concatMap resolve . sweep2) (tuples layers) + _line (from, to) = "\n" ++ show from ++ " -> " ++ show to + _placeNodes = concat $ concatMap (map placeNode) (zipWith (zip . repeat) [1 ..] (map (zip [1 ..]) layers)) + where + placeNode :: (X, (Y, (UINode, Bool))) -> String + placeNode (x, (y, (n, _b))) = show n ++ " [pos=\"" ++ show x ++ "," ++ show (-y) ++ "!\"];\n" + resolve :: [(MYN, MYN)] -> [(UINode, UINode)] + resolve ts = + -- Debug.Trace.trace ("\nresolve "++ show (ts, res)) + res + where + res = rmdups $ map toNode (resolveConflicts dir ts) + + _sweep :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]] + _sweep (layer0, layer1) = + -- Debug.Trace.trace ("\nsweep "++ show (dir, layer0, layer1) ++"\n"++ show sfiel) + -- Debug.Trace.trace ("(l0,l1)\n"++ show (layer0, layer1) ++"\n\n"++ show medians ++"\n\n"++ show sfiel) $ + sfiel + where + sfiel = sweepForIndependentEdgeLists graph medians allowedEdges dir (Map.empty, Map.empty) (0, 0) (layer0, layer1) Set.empty + allowedEdges :: Set.Set (UINode, UINode) + allowedEdges = Set.fromList (mapMaybe f layer0) + -- f :: UINode -> (UINode, UINode) + f (n, _b) + | isJust lu = Just (n, dest) + | otherwise = Nothing + where + dest = fst $ snd $ getYN (fst dir) (myFromJust 500 lu) + lu = Map.lookup n (snd medians) + + -- sweeping through a layer to find all edges without separating them into independent lists + -- maybe slower in some cases, faster in others + sweep2 :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]] + sweep2 (layer0, _layer1) = + -- Debug.Trace.trace ("sweep2 "++ show (layer0, layer1,es)) + es + where + es = [catMaybes (zipWith f [0 ..] layer0)] + f y (n, b) + | isJust lu && isValidEdge -- Debug.Trace.trace ("sweep2lu0 "++ show lu) $ + = + Just (Single (y, (n, b)), myFromJust 501 lu) + | otherwise -- Debug.Trace.trace ("sweep2lu1 "++ show (n,lu)) + = + Nothing + where + lu = Map.lookup n (snd medians) + luBack = Map.lookup (fst $ snd $ getYN left $ myFromJust 502 lu) (fst medians) + isValidEdge = + -- Debug.Trace.trace ("n,lu,luBack "++ show (n,lu,luBack)) $ + isJust luBack && n == fst (snd $ getYN left $ myFromJust 503 luBack) + +toNode :: ((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2) +toNode ((_, (n0, _)), (_, (n1, _))) = (n0, n1) + +tuples :: [a] -> [(a, a)] +tuples (x : y : xs) = (x, y) : tuples (y : xs) +tuples _ = [] + +type Insp = (Map Int (MYN, MYN), Map Int (MYN, MYN)) + +-- | Takes two layers and returns a list of lists of independent edges. +-- A list A of edges is independent of a list B of edges if every edge of A does not intersect or connect any edge of B. +-- This sweeping should save some time because graphs often have edges crossing near to each other. +-- The number of intersections has been reduced in crossingreduction. +-- Because of this we can assume that most edges are quite short and rectangular to layer0 and layer1. +-- A sweep in the parallel direction of the two layers should reduce the number of edges that have to be examined. +-- The overall algorithm (sweep + resolve) should have a runtime more like n*log(n) instead of n², +-- because we only have to search for conflicts inside of these independent lists. +-- The Brandes-Köpf paper is not explaining very well how they find intersections between two layers. +-- I doubt that the whole algorithm is O(n). It seems more like a quadratic runtime in the worst case. +-- Even finding the number of intersections (without giving back the exact edges that intersect) is O(n log n), +-- See: Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger +-- or chapter 33 of Cormen: Introduction to algorithms +-- If several edges emanate from a node the algorithm takes (one of the) the median. (e.g. three edges have one median, 4 edges have two) +-- The sweep works by looking at the next node in the two layers, and comparing which node deletes more edges and +-- introduces less new edges from the set of edges to look at. Every edge has a start node (first appearing at its +-- y-position) and an end node. A start node means adding an edge when its source or target node appears in one of +-- the two layers, and the edge disappears when both its nodes have been swept over. +sweepForIndependentEdgeLists :: + (NodeClass n, EdgeClass e) => + CGraph n e -> + (Median, Median) -> + Set (UINode, UINode) -> + (Bool, Bool) -> + Insp -> + (Y, Y) -> + ([(UINode, Bool)], [(UINode, Bool)]) -> + Set (MYN, MYN) -> + [[(MYN, MYN)]] +sweepForIndependentEdgeLists graph medians allowedEdges dir inspectionEdges (y0, y1) (layer0, layer1) missingEdges + | null layer0 && null layer1 = Debug.Trace.trace ("nullnull " ++ show (layer0, layer1)) [] + | y0 >= 10 || y1 >= 10 = Debug.Trace.trace ("1010 " ++ show (y0, y1, layer0, layer1)) [] + | -- node at postion y1 is connected vertically with node at position y1+1 + (length layer1 >= 2) && verticalNode && isFunction graph hl1 = + -- Debug.Trace.trace "sweep vert node" $ + sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0, y1 + 1) (layer0, tl1) Set.empty + | Map.null sweepedOverFrom && Map.null sweepedOverTo = + -- Debug.Trace.trace ("res"++ show (y0,y1) ++"\nlayer0 "++ show layer0 ++"\nlayer1 "++ show layer1 + -- ++"\nresEdges "++ show resEdges ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo " + -- ++ show newInsTo ++"\nsweepedOver "++ show sweepedOver ++"\n") $ + resEdges : (sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0 + 1, y1 + 1) (tl0, tl1) Set.empty) + | Map.size sweepedOverFrom < Map.size sweepedOverTo = + -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ "<"++ show (Map.size sweepedOverTo) ++"\n"++ + -- show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo + -- ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $ + sweepForIndependentEdgeLists + graph + medians + allowedEdges + dir + sweepedOver + (y0 + 1, y1) + (tl0, layer1) + (Set.union missingEdges newMissingEdges) + | otherwise -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ ">="++ show (Map.size sweepedOverTo) ++"\n"++ + -- show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo + -- ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $ + = + sweepForIndependentEdgeLists + graph + medians + allowedEdges + dir + sweepedOver + (y0, y1 + 1) + (layer0, tl1) + (Set.union missingEdges newMissingEdges) + where + (inspectEdgesFrom, inspectEdgesTo) = inspectionEdges + (lowerMedians, upperMedians) = medians + (left, _up) = dir + (n0, b0) = myhead 60 layer0 + (n1, b1) = myhead 61 layer1 + tl0 + | null layer0 = [] + | otherwise = tail layer0 + tl1 + | null layer1 = [] + | otherwise = tail layer1 + hl1 = fst (myhead 62 layer1) + verticalNode = VU.elem (fst (myhead 63 tl1)) (Graph.adjacentNodesByAttr graph True hl1 (Graph.Edge8 Common.vertBit)) + resEdges = myNub (Map.elems newInsFrom ++ Map.elems newInsTo ++ Set.toList missingEdges) + + edgeFrom :: Maybe MYN + edgeFrom + | null layer0 = Nothing + | otherwise -- Debug.Trace.trace ("up2 "++ show (n0, Map.lookup n0 upperMedians)) $ + = + Map.lookup n0 upperMedians + edgeTo :: Maybe MYN + edgeTo + | null layer1 -- || (not (Set.member (n0,n1) allowedEdges)) + = + Nothing + | otherwise -- Debug.Trace.trace ("up4 "++ show (n1, Map.lookup n1 lowerMedians)) $ + = + Map.lookup n1 lowerMedians + + newInsFrom :: Map Int (MYN, MYN) + newInsFrom + | isJust edgeFrom && yy1 >= y1 = Map.insert yy1 (Single (y0, (n0, b0)), myFromJust 504 edgeFrom) inspectEdgesFrom + | otherwise = inspectEdgesFrom + where + yy1 = getY left (myFromJust 505 edgeFrom) + + newInsTo :: Map Int (MYN, MYN) + newInsTo + | isJust edgeTo && yy0 >= y0 = Map.insert yy0 (myFromJust 506 edgeTo, Single (y1, (n1, b1))) inspectEdgesTo + | otherwise = inspectEdgesTo + where + yy0 = getY left (myFromJust 506 edgeTo) + + newMissingEdges :: Set.Set (MYN, MYN) + newMissingEdges + | isJust edgeFrom && isJust edgeTo = + Set.fromList + [ (Single (y0, (n0, b0)), myFromJust 507 edgeFrom), + (myFromJust 508 edgeTo, Single (y1, (n1, b1))) + ] + | isJust edgeFrom = Set.singleton (Single (y0, (n0, b0)), myFromJust 509 edgeFrom) + | isJust edgeTo = Set.singleton (myFromJust 510 edgeTo, Single (y1, (n1, b1))) + | otherwise = Set.empty + + sweepedOverFrom = Map.delete y1 newInsFrom + sweepedOverTo = Map.delete y0 newInsTo + sweepedOver = (sweepedOverFrom, sweepedOverTo) :: Insp + +-- | Either e0 prevails against all e1s or all e1s prevail against e0 +data EdgeTy a = E0Prevails a | E1Prevails a | NoIntersect (a, a) deriving (Eq, Show) + +resolveConflicts :: (Bool, Bool) -> [(MYN, MYN)] -> [(YN, YN)] +resolveConflicts (_, _) [] = [] +resolveConflicts (left, _) [e] = [toYN left e] +resolveConflicts (left, up) es = + -- Debug.Trace.trace ("resolveConflicts"++ show (es, resolveConfs (left,up) es 0)) $ + map (toYN left) (resolveConfs (left, up) es 0) + +toYN :: Bool -> (MYN, MYN) -> ((Y, (UINode, Bool)), (Y, (UINode, Bool))) +toYN left (n0, n1) = (getYN left n0, getYN left n1) + +-- | Compare all edges of a layer with each other. Worst case: O(n²). +-- But n can shrink fast in every round and n is small, because of sweepForIndependentEdgeLists +resolveConfs :: (Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)] +resolveConfs (_, _) [] _ = + -- Debug.Trace.trace "ch0 " + [] +resolveConfs (left, up) (e0 : edges) i + | i > 20 -- Debug.Trace.trace ("ch1 "++ show (e0:edges)) + = + e0 : edges -- avoid endless loop + | checkE0 consistent -- Debug.Trace.trace ("checkE0 "++ show (map te (e0:edges)) ++"\n"++ show (map _toEdges2 conflictList) ++"\n") $ + = + e0 : (resolveConfs (left, up) removeInferiorToE0 (i + 1)) + | checkNoIntersect consistent -- Debug.Trace.trace ("check noIntersect "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i) ++ "\n") $ + = + if null conflictList + then e0 : edges + else e0 : (resolveConfs (left, up) edges (i + 1)) -- concat (map toEdges conflictList) + | otherwise -- Debug.Trace.trace ("checkE1 "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i, firstE1, edgesE1First) ++ "\n") $ + = + resolveConfs (left, up) edgesE1First (i + 1) + where + conflictList = map (conflict left e0) edges + + edgesE1First = e1 : (filter (\e -> e /= e0 && e /= e1) (concatMap toEdges conflictList)) + e1 = head (toEdges firstE1) + firstE1 = myFromJust 511 (find e1Prevails conflictList) + + consistent = isConsistent conflictList + checkE0 (E0Prevails True) = True + checkE0 _ = False + _checkE1 (E1Prevails True) = True + _checkE1 _ = False + checkNoIntersect (NoIntersect _) = True + checkNoIntersect _ = False + removeInferiorToE0 = rmdups $ concatMap toEdges (filter isNoIntersect conflictList) + isNoIntersect (NoIntersect _) = True + isNoIntersect _ = False + e1Prevails (E1Prevails _) = True + e1Prevails _ = False + toEdges (E0Prevails e) = [e] + toEdges (E1Prevails e) = [e] + toEdges (NoIntersect (edge0, edge1)) = [edge0, edge1] + + _toEdges2 (E0Prevails (n0, n1)) = [te1 (n0, n1)] + _toEdges2 (E1Prevails (n0, n1)) = [te1 (n0, n1)] + _toEdges2 (NoIntersect ((n0, n1), (n2, n3))) = [te1 (n0, n1), te1 (n2, n3)] + te1 (n0, n1) = (getN n0, getN n1) + +-- resolveConfs _ _ _ = Debug.Trace.trace "error resolveConfs " [] + +-- | The resolveConflicts-algorithm has to be constructed in a consistent way +-- It should be impossible that edge e has priority to edge x (keeping e), +-- and another edge y has priority to edge e (deleting e). It would not be clear if e has to be deleted or not +isConsistent :: [EdgeTy (MYN, MYN)] -> EdgeTy Bool +isConsistent (NoIntersect _ : es) = isConsistent es +isConsistent [] = NoIntersect (True, True) -- will only be called if there is no E0Prevails or E1Prevails +isConsistent ((E0Prevails _) : es) = isAllE0OrNoIntersect es + where + isAllE0OrNoIntersect [] = E0Prevails True + isAllE0OrNoIntersect ((E0Prevails _) : edges) = isAllE0OrNoIntersect edges + isAllE0OrNoIntersect ((NoIntersect _) : edges) = isAllE0OrNoIntersect edges + isAllE0OrNoIntersect (_ : _) = E0Prevails False -- not consistent +isConsistent ((E1Prevails _) : es) = isAllE1OrNoIntersect es + where + isAllE1OrNoIntersect [] = E1Prevails True + isAllE1OrNoIntersect ((E1Prevails _) : edges) = isAllE1OrNoIntersect edges + isAllE1OrNoIntersect ((NoIntersect _) : edges) = isAllE1OrNoIntersect edges + isAllE1OrNoIntersect (_ : _) = E1Prevails False + +conflict :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN) +conflict left (n0, n1) (n2, n3) + | isIntersecting -- Debug.Trace.trace ("intersecting "++ show (n0,n1,n2,n3)) $ + = + cases left (n0, n1) (n2, n3) + | otherwise = NoIntersect ((n0, n1), (n2, n3)) + where + isIntersecting -- two segments intersect + = + (getY left n0 <= getY left n2 && getY left n1 >= getY left n3) + || (getY left n0 >= getY left n2 && getY left n1 <= getY left n3) + +-- | Given two edges that intersect or connect, which one will prevail? +cases :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN) +cases left (n0, n1) (n2, n3) + -- type 2 (one segment consists of two connection nodes and is preferred then) + | connNode n0 && connNode n1 -- Debug.Trace.trace ("type2 0 "++ show (n0,n1,n2,n3)) $ + = + E0Prevails (n0, n1) + | connNode n2 && connNode n3 -- Debug.Trace.trace ("type2 1 "++ show (n0,n1,n2,n3)) $ + = + E1Prevails (n2, n3) + | (connNode n0 || connNode n1) + && (connNode n2 || connNode n3) -- one connection node (type 2) + = + if (isMedian n0 || isMedian n1) && isSingle n2 && isSingle n3 + then -- Debug.Trace.trace ("type2 2 "++ show (n0,n1,n2,n3)) $ + E0Prevails (n0, n1) + else E0Prevails (n2, n3) + -- type 1 (non-inner segment crosses an inner segment) + | (connNode n0 || connNode n1) + && not (connNode n2) + && not (connNode n3) -- Debug.Trace.trace ("type1 0"++ show (n0,n1,n2,n3)) $ + = + E0Prevails (n0, n1) + | (connNode n2 || connNode n3) + && not (connNode n0) + && not (connNode n1) -- Debug.Trace.trace ("type1 1"++ show (n0,n1,n2,n3)) $ + = + E1Prevails (n2, n3) + -- type 0 (a pair of non-inner segments) + | not (connNode n0) && not (connNode n1) + && not (connNode n2) + && not (connNode n3) -- Debug.Trace.trace ("type0 "++ show (preferE0,n0,n1,n2,n3)) $ + = + if preferE0 + then E0Prevails (n0, n1) + else E1Prevails (n2, n3) + | otherwise = Debug.Trace.trace "cases err" $ E0Prevails (n0, n1) -- correct? just to fix a warning + where + connNode (Single (_, (_, b))) = b + connNode (Middle (_, (_, b))) = b + connNode (UpLowMedian (_, (_, b0)) (_, (_, b1))) + | left = b0 + | otherwise = b1 + isMedian (Single _) = False + isMedian (Middle _) = True + isMedian (UpLowMedian _n0 _n1) = True + isSingle (Single _) = True + isSingle _ = False + preferE0 + | (isMedian n0 || isMedian n1) && not (isMedian n2) && not (isMedian n3) -- Debug.Trace.trace "p0" + = + True + | (isMedian n2 || isMedian n3) && not (isMedian n0) && not (isMedian n1) -- Debug.Trace.trace "p1" + = + False + | abs (getY left n0 - getY left n1) < abs (getY left n2 - getY left n3) -- Debug.Trace.trace "p2" + = + True + | otherwise -- Debug.Trace.trace "p3" + = + False + +getYN :: Bool -> MYN -> (Y, (UINode, Bool)) +getYN _ (Single (y, (n, b))) = (y, (n, b)) +getYN _ (Middle (y, (n, b))) = (y, (n, b)) +getYN left (UpLowMedian (y0, (n0, b0)) (y1, (n1, b1))) + | left = (y0, (n0, b0)) + | otherwise = (y1, (n1, b1)) + +getY :: Bool -> MYN -> Y +getY _ (Single (y, _)) = y +getY _ (Middle (y, _)) = y +getY left (UpLowMedian (y0, (_n0, _b0)) (y1, (_n1, _b1))) + | left = y0 + | otherwise = y1 + +getN :: MYN -> [UINode] +getN (Single (_y, (n, _b))) = [n] +getN (Middle (_y, (n, _b))) = [n] +getN (UpLowMedian (_y0, (n0, _b0)) (_y1, (n1, _b1))) = [n0, n1] + +ranksame :: [[UINode]] -> String +ranksame ls = "{ rank=same; " ++ intercalate "," (map show ls) ++ " }\n" + +col :: Int -> UINode -> String +col i n = show n ++ " " ++ c (i `mod` 5) ++ "\n" + where + c m + | m == 0 = "[color = red" ++ width + | m == 1 = "[color = green" ++ width + | m == 2 = "[color = blue" ++ width + | m == 3 = "[color = yellow" ++ width + | m == 4 = "[color = turquoise" ++ width + c _ = "[color = black" ++ width + width = ",penwidth=" ++ show (1 + (i `div` 2)) ++ "]" + +-------------------------------------------------------------------------------------------------------------------- + +-- Similar to Brandes-Köpf but without arrays and no placement of blocks +-- The basic algorithm is longest path. +-- debugging can be done with graphviz, also uncomment line 533 in longestPath | otherwise +align :: EdgeClass e => CGraph n e -> [[UINode]] -> [(UINode, UINode)] -> (Bool, Bool) -> Map UINode (Int, Int) +align graph layers edges (_alignLeft, _up) = + {-Debug.Trace.trace ("\nalign\ndigraph{\n"++ (concat $ map ranksame layers) + ++ (concat (map ((++ "\n") . (intercalate " -> ") . (map show)) layers)) + ++ (graphviz "[color=red,penwidth=2];" edges) + ++ (graphviz "" es) ++ "}\n" + ++ show (startNs, map last (zipWith f [0..] layers)) + ++"\nblocks\n"++ show blocks ++ "\nnextInLayerMap" ++ show nextInLayerMap + )-} + mb2 + where + -- | up = lp + -- | otherwise = lpBackwards + -- mb = Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp))) $ + -- moveBlocks (Map.fromList lp) + mb2 = + -- Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp), moveBlocksAgain (Map.fromList lp)) ++ "\n") $ + moveBlocksAgain (Map.fromList lp) + lp = longestPath (map blockChildren startNs) [] 0 + -- globalYMin = minimum (map (snd . snd) lp) + -- lpBackwards = longestPath (map blockChildren startNsBackwards) [] 0 + layerConnections = Map.fromList $ concatMap tuples layers + reverseLayerConnections = Map.fromList $ concatMap (tuples . reverse) layers + edgeMap = Map.fromList edges + reverseBlocks = Map.fromList (map swap edges) + _es = Map.keys (Graph.edgeLabels graph) \\ edges + + startNs = mapMaybe (nodeWithoutParent . last) (zipWith f [0 ..] layers) + -- startNsBackwards = catMaybes $ map (nodeWithoutParent . head) (zipWith f [0..] layers) + f i ns = map (i,) ns + + nodeWithoutParent (x, n) + | isNothing (Map.lookup n reverseBlocks) + && noParentInLayer (x, n) -- no parent in block + = + -- Debug.Trace.trace ("nodeWoPar0 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $ + Just (x, n) + | otherwise = + -- Debug.Trace.trace ("nodeWoPar1 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $ + Nothing + where + noParentInLayer root = + -- Debug.Trace.trace ("noParInLayer "++ show (root, blockChildren root, + -- map hasNoLayerParent (blockChildren root))) $ + all hasNoLayerParent (blockChildren root) + + hasNoLayerParent (_, _n) = isNothing (Map.lookup n layerConnections) + + blockChildren :: (X, UINode) -> [(X, UINode)] + blockChildren (x, n) + | isJust lu = (x, n) : blockChildren (x + 1, myFromJust 513 lu) + | otherwise = [(x, n)] + where + lu = Map.lookup n edgeMap + + longestPath :: [[(X, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))] + longestPath [] _ _ = + -- Debug.Trace.trace "finish" + [] + longestPath blockNodes used i + | i > 100 -- Debug.Trace.trace ("reverseBlocks " ++ show (edges, reverseBlocks)) $ + = + [] + | otherwise -- Debug.Trace.trace ((concat $ map (col i) blns) ++ "\n") $ + -- ++ "map layerChild " ++ show (map layerChild (concat blockNodes)) ++ "\n" + -- ++ "nextLayerRoots " ++ show nextLayerRoots ++ "\n" + -- ++ "map blockChildren nextLayerRoots " ++ show (map blockChildren nextLayerRoots) ++ "\n" + -- ++ "blocksWithOnlyUsedParents " ++ show blocksWithOnlyUsedParents ++ "\n" + -- ++ "newUsed " ++ show newUsed + -- ) $ + = + newLayer ++ longestPath blocksWithOnlyUsedParents newUsed (i + 1) + where + newLayer = concatMap (oneLayer i) blockNodes + blocksWithOnlyUsedParents = rmdups $ filter noParentOrUsed (map blockChildren nextLayerRoots) + -- | otherwise = rmdups $ filter noParentOrUsed (map blockChildren nextLayerRootsBackwards) + nextLayerRoots = myNub2 (map findRoot nextPossibleLayerNodes) + -- nextLayerRootsBackwards = myNub2 (map findRoot nextPossibleLayerNodesBackwards) + nextPossibleLayerNodes = mapMaybe layerChild (concat blockNodes) + -- nextPossibleLayerNodesBackwards = catMaybes (map layerParent (concat blockNodes)) + layerChild (x, n) = maybe Nothing (\node -> Just (x, node)) (Map.lookup n reverseLayerConnections) + -- layerParent (x,n) = maybe Nothing (\node -> Just (x,node)) (Map.lookup n layerConnections) + newUsed = used ++ blns + blns = map snd (concat blockNodes) + noParentOrUsed block = + -- Debug.Trace.trace ("noParentOrUsed "++ show (block, map noParOrUsed block, newUsed)) $ + all noParOrUsed block + noParOrUsed (_, n) = + -- Debug.Trace.trace ("noParOrUsed "++ show (n,lu)) $ + isNothing lu || (isJust lu && elem (myFromJust 514 lu) newUsed) + where + lu = Map.lookup n layerConnections + + oneLayer :: Y -> [(X, UINode)] -> [(UINode, (Int, Int))] + oneLayer y ns = map (\(x, n) -> (n, (x, -y))) ns + + findRoot :: (X, UINode) -> (X, UINode) + findRoot (x, n) + | isJust lu && x >= 0 -- Debug.Trace.trace ("findRoot " ++ show (x,n)) $ + = + findRoot (x - 1, myFromJust 515 lu) + | otherwise = (x, n) + where + lu = Map.lookup n reverseBlocks + + blocks = extr ++ (map (\x -> [x]) rest) + where + extr = extractBlocks edgeMap + rest = (concat layers \\ allNodes) \\ concat extr + allNodes = Map.keys edgeMap ++ Map.elems edgeMap + + extractBlocks :: Map UINode UINode -> [[UINode]] + extractBlocks m + | Map.null m = [] + | otherwise = oneBlock ++ extractBlocks newEdgeMap -- extract one block and remove keys from the edge map + where + newEdgeMap = + -- Debug.Trace.trace ("oneBlock " ++ show oneBlock) $ + foldr Map.delete m (concat oneBlock) + oneBlock = + filter + (not . null) + ( merge1 (map (fst . snd) oneBlockWithVerts) + ++ [map fst oneBlockWithVerts] + ++ merge1 (map (snd . snd) oneBlockWithVerts) + ) + merge1 [] = [] + merge1 xs = (map head fil) : (merge1 (map tail fil)) + where + fil = filter (not . null) xs + oneBlockWithVerts = + -- Debug.Trace.trace ("oneBlock " ++ show (reverse (blockNodesDown (head ks)), tail (blockNodesUp (head ks)))) $ + reverse (blockNodesDown (head ks)) + ++ tail (blockNodesUp (head ks)) + + ks = Map.keys m ++ Map.elems m + + blockNodesDown :: UINode -> [(UINode, ([UINode], [UINode]))] + blockNodesDown n + | isJust lu = (n, (vertup, vertdown)) : (blockNodesDown (myFromJust 513 lu)) + | otherwise = [(n, (vertup, vertdown))] + where + lu = Map.lookup n edgeMap + vertup = VU.toList (parentsVertical graph n) + vertdown = VU.toList (childrenVertical graph n) + + blockNodesUp :: UINode -> [(UINode, ([UINode], [UINode]))] + blockNodesUp n + | isJust lu = (n, (vertup, vertdown)) : (blockNodesUp (myFromJust 513 lu)) + | otherwise = [(n, (vertup, vertdown))] + where + lu = Map.lookup n reverseBlocks + vertup = VU.toList (parentsVertical graph n) + vertdown = VU.toList (childrenVertical graph n) + + moveBlocks m = + -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks))) + foldr moveToShortestConnection m (reverse blocks) + moveBlocksAgain m = + -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks))) + foldr moveToShortestConnection (moveBlocks m) (reverse blocks) + + moveToShortestConnection block m + | null bs = m + | otherwise = -- Debug.Trace.trace ("\nblock " ++ show block ++ + -- "\nbounds " ++ show bounds ++ + -- "\nnewY " ++ show newY ++ + -- "\nadjustY block newY m\n" ++ show (adjustY block newY m)) + adjustY block newY m + where + -- newY = ( (fromJust (fst (head bounds))) + (fromJust (snd (head bounds))) ) `div` 2 + bs = mapMaybe fst bounds + newY = maximum bs + 1 -- TODO look at block connections + bounds = map blockBound block + blockBound b = + -- Debug.Trace.trace ("blockBound " ++ show (b,n,(yTop,yBottom),m)) + (yTop, yBottom) + where + -- yTop = fmap snd (maybe (Just (0,globalYMin)) (\node -> Map.lookup node m) n) + yTop = fmap snd (maybe Nothing (`Map.lookup` m) n) + yBottom = fmap snd (Map.lookup b m) + n = Map.lookup b nextInLayerMap + + nextInLayerMap = foldr addLayerEdges Map.empty layers + where + addLayerEdges layer m = foldr addEdge m (tuples layer) + addEdge (from, to) m = Map.insert to from m + + adjustY block newY m = foldr adj m block + where + adj b mp = Map.adjust (\(x, _y) -> (x, newY)) b mp + +--------------------------------------------------------------------------------------------------------- + +-- The idea behind the following heuristic: +-- Very frequent chaining of functions are obvious and need no attention, e.g. Data.Text.pack str +-- unusual chainings need the highest attention +-- a long path means it is the main path of activity, like a table of contents in a book that +-- is a guide where to go. This long path should be a straight line at the top of the page. + +-- Sort nodes in the layers by: +-- Finding the longest path with the most infrequent connections, make these nodes appear +-- first (y=0) use dfs to find the second longest/infrequent path +-- longestinfrequentPaths :: CGraph -> [[Node]] -> [Node] + +type YNode = (YPos, Channel, UINode, IsDummy) + +type YPos = Word32 + +type IsDummy = Bool + +data Dir = LeftToRight | RightToLeft deriving (Show) + +leftToRight :: Dir -> Bool +leftToRight LeftToRight = True +leftToRight RightToLeft = False + +longestinfrequentPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> Vector Int +longestinfrequentPaths _ [] = VU.empty +longestinfrequentPaths _ [_] = VU.empty +longestinfrequentPaths g (l0 : l1 : layers) + | null r = VU.empty + | otherwise = VU.take (length layers + 2) $ myhead 64 r + where + r = map (liPaths g (l1 : layers) []) (startNodes g l0 l1) + +startNodes :: EdgeClass e => CGraph n e -> [Word32] -> [Word32] -> [Word32] +startNodes g l0 l1 = mapMaybe (nodeWithChildInLayer l1) l0 + where + nodeWithChildInLayer layer1 node + | VU.null $ + VU.filter + (`elem` layer1) + (childrenNoVertical g node) = + Nothing + | otherwise = Just node + +liPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int +liPaths _ [] ns node = VU.fromList (map fromIntegral (node : ns)) +liPaths g (l0 : layers) ns node = VU.concatMap (liPaths g layers (node : ns)) cs + where + cs = + VU.filter + -- (\x -> (maybe False (not . isDummyLabel) (Graph.lookupNode x g)) && elem x l0) + (\x -> not (isDummy g x) && elem x l0) + (childrenNoVertical g node) + +myNub :: Ord a => [a] -> [a] +myNub = map (myhead 65) . group . sort + +myNub2 :: [(Int, UINode)] -> [(Int, UINode)] +myNub2 = map (myhead 66) . groupBy nnn . sortBy nn + where + nn (_, n0) (_, n1) = compare n0 n1 + nnn (_, n0) (_, n1) = n0 == n1 + +type UnconnectedChildren = [UINode] + +-- | Every graph has a longest path, which is the center of attention for us +-- Return layers of node ids +-- This algorithm is a little bit more complicated because we can connect nodes "vertically", +-- so that they are guaranteed to be all in one vertical layer +-- All nodes before this vertical layer have to be placed in layers before we can proceed +longestPathAlgo :: (NodeClass n, EdgeClass e) => CGraph n e -> (CGraph n e, [[UINode]]) +longestPathAlgo g = + -- Debug.Trace.trace ("\nlongestPathAlgo\n" ++ show (g, newLayers, moveFinalNodesLeftToVert newLayers)) $ + -- Debug.Trace.trace ("\nlongestPathAlgo " ++ show g ++ + -- "\nnewLayers" ++ show newLayers ++ + -- "\nnodesWithoutChildren" ++ show nodesWithoutChildren ++ + -- "\nverticalLayers" ++ show verticalLayers ++ + -- "\noptionNodes" ++ show optionNodes ++ + -- "\nnodesWithoutChildrenVertLayer" ++ show nodesWithoutChildrenVertLayer ++ + -- "\n"++ showEdges g) + (g, moveFinalNodesLeftToVert (map rmdups newLayers)) + where + moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]] + moveFinalNodesLeftToVert ls = + -- Debug.Trace.trace ("nodesToMove "++ show (nodesToMove, nodesAndPrevious)) $ + (myhead 67 ls \\ nodesToMove) : (foldr insert (tail ls) nodesAndPrevious) + where + nodesToMove + | length ls < 2 = [] + | otherwise = filter (notEl . VU.toList . parentsNoVertical g) (myhead 68 ls) + notEl [n] = n `notElem` myhead 69 (tail ls) + notEl _ = False + insert (n, p) lays + | null fpl = lays -- Debug.Trace.trace ("insert "++ show lays ++"\n\n"++ show (add lays (find p lays) n)) $ + | otherwise = add lays (head fpl) n + where + fpl = findn p lays + nodesAndPrevious = zip nodesToMove (map (VU.head . parentsNoVertical g) nodesToMove) + add list pos n = take (pos - 1) list ++ ((list !! (pos - 1)) ++ [n]) : (drop pos list) + findn p l = [fst il | il <- zip [0 ..] l, p `elem` snd il] + + newLayers = layersrec (rmdups $ VU.toList nodesWithoutChildrenVertLayer) fil [] + fil = filter (not . null . sel2) verticalLayers + sel1 (x, _, _) = x + sel2 (_, y, _) = y + ns = VU.map fromIntegral (VU.fromList (nodes g)) + nodesWithoutChildren = VU.filter (VU.null . cs) ns + nodesWithoutChildrenVertLayer :: VU.Vector UINode + nodesWithoutChildrenVertLayer = + -- Debug.Trace.trace ("nwcvl "++ show (nodesWithoutChildren, nwcvl)) + nwcvl + where + nwcvl = VU.concatMap (findLayers (map sel1 verticalLayers)) nodesWithoutChildren + findLayers :: [[UINode]] -> UINode -> VU.Vector UINode + findLayers ls n + | null ls = VU.singleton n + | otherwise = VU.fromList (concat (map findL ls)) + where + findL l + | elem n l = l + | otherwise = [n] + cs node = Graph.children g node [dummyEdge Nothing 0] + (_, optionNodes) = partitionNodes g ns -- nonOptionNodes + verticalLayers = + -- Debug.Trace.trace (show ("verticalLayers", VU.toList optionNodes, vLayers (VU.toList optionNodes))) $ + vLayers (VU.toList optionNodes) + + vLayers [] = [] + vLayers (n : ns1) = + -- Debug.Trace.trace (show ("vLayers", n, newLayer, addUnconnectedChildren newLayer)) $ + (addUnconnectedChildren newLayer) : (vLayers (ns1 \\ newLayer)) + where + newLayer = sort $ verticallyConnectedNodes g n + addUnconnectedChildren :: [UINode] -> ([UINode], UnconnectedChildren, Bool) + addUnconnectedChildren layer1 = (layer1, myNub $ VU.toList (VU.concat (map nonVertChildren layer1)), False) + nonVertChildren node = childrenNoVertical g node + + -- the idea of this recursion is to go backwards from the final node and add non-vertical nodes that are fully connected at the input + -- if there is only a vertical layer possible, add it + layersrec :: [UINode] -> [([UINode], UnconnectedChildren, Bool)] -> [UINode] -> [[UINode]] + layersrec curLayer vertLayers usedNodes + | null curLayer -- Debug.Trace.trace "\n§§1 " + = + [] + | length usedNodes + length curLayer > length (nodes g) = + Debug.Trace.trace + ("\n§§2 " ++ show (curLayer, length usedNodes, usedNodes, length curLayer, length (nodes g))) + [curLayer] -- should not happen + | otherwise {-Debug.Trace.trace ("\n§§3 curLayer "++ show curLayer ++ + "\nfullyConnectedVertNodes2 " ++ show fullyConnectedVertNodes2 ++ + "\nnewCurLayerOrVert " ++ show newCurLayerOrVert ++ + "\nusedNodes " ++ show usedNodes ++ + "\nlayerParents curLayer " ++ show (layerParents curLayer) ++ + "\nvertLayers " ++ show vertLayers ++ + "\nnewVertLayers " ++ show newVertLayers ++ + "\nfil" ++ show fil)-} = + curLayer : (layersrec newCurLayerOrVert filtered (usedNodes ++ curLayer)) + where + newVertLayers = map adjustConnected vertLayers + adjustConnected (someLayer, unconnectedChildren, _) = + -- Debug.Trace.trace ("adjustConnected " ++ show (someLayer, unconnectedChildren, newun, map (isNotMainFunctionArg g) someLayer)) $ + (someLayer, newun, null newun && all (isNotMainFunctionArg g) someLayer) + where + newun = unconnectedChildren \\ curLayer + + filtered + | not (null newCurLayer) -- Debug.Trace.trace ("fil0 "++ show (newVertLayers)) $ + = + filter (not . changed) newVertLayers + | not (null fullyConnectedVertNodes2) -- Debug.Trace.trace ("fil1 "++ show (filter (not . isFullyConnected) newVertLayers)) $ + = + filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers + | otherwise -- Debug.Trace.trace ("fil2 "++ show (filter (not . isFullyConnected) newVertLayers)) $ + = + filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers + -- fullyConnectedVertNodes = concat (map fst (filter isFullyConnectedAndNotArg newVertLayers)) + fullyConnectedVertNodes2 = concatMap sel1 (filter isFullyConnected newVertLayers) + -- isFullyConnectedAndNotArg (someLayer,unconnectedChildren) = Debug.Trace.trace ("isfully "++ show (null unconnectedChildren, map (isMainFunctionArg g) someLayer)) $ + -- null unconnectedChildren && + -- not (or (map (isMainFunctionArg g) someLayer)) + + isFullyConnected (_someLayer, unconnectedChildren, _) = null unconnectedChildren + + newCurLayer = + -- Debug.Trace.trace ("curParents"++ show (layerParents curLayer, filter shouldNodeBeAdded (layerParents curLayer))) $ + myNub (filter shouldNodeBeAdded (layerParents curLayer)) ++ concatMap sel1 (filter changed newVertLayers) + changed (_, _, b) = b + layerParents l = VU.toList (VU.concatMap (parentsNoVertical g) (VU.fromList l)) + newCurLayerOrVert + | not (null newCurLayer) -- Debug.Trace.trace "not (null newCurLayer)" $ --prefer normal nodes to vertical nodes + = + myNub newCurLayer + | not (null fullyConnectedVertNodes2) -- Debug.Trace.trace "not (null fullyConnectedVertNodes2)" $ --if no normal nodes are left + = + myNub fullyConnectedVertNodes2 + | otherwise = [] + shouldNodeBeAdded :: UINode -> Bool -- have all children been added, then node should be added + shouldNodeBeAdded node + | VU.null chs -- Debug.Trace.trace ("should0 "++ show (node, chs, VU.map isChildUsed chs)) $ + = + False + | otherwise -- Debug.Trace.trace ("should1 "++ show (node, chs, VU.map isChildUsed chs)) $ + = + VU.and (VU.map isChildUsed chs) + && not (isInVertLayer node) + where + chs = childrenNoVertical g node + isChildUsed :: UINode -> Bool + isChildUsed child = child `elem` (usedNodes ++ curLayer) + isInVertLayer :: UINode -> Bool + isInVertLayer n = any (elem n . sel1) vertLayers + +-- Some functions don't have an input (e.g. True). +-- But a function without input can only appear directly after a case node +-- That's why we insert a connection node between this case node and the function node +addMissingInputNodes :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> CGraph n e +addMissingInputNodes graph = + -- Debug.Trace.trace ("\naddConnectionNodes"++ show (foldl addConnNode graph (map fromIntegral (nodes graph)))) $ + foldl addConnNode graph (map fromIntegral (nodes graph)) + where + addConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> CGraph n e + addConnNode g n + | VU.null ps = g + | isFunction graph n = + -- && isCase graph (vhead 501 ps) -- Debug.Trace.trace ("caseconn"++ show (n, VU.head ps)) $ + + insertConnNode g n (vhead 502 ps) Nothing 0 + | otherwise = g + where + ps = parentsNoVertical graph n + +-- | partition nodes into non-vertically connected nodes and vertically connected nodes +partitionNodes :: EdgeClass e => CGraph n e -> VU.Vector UINode -> (VU.Vector UINode, VU.Vector UINode) +partitionNodes g = + VU.partition + ( \n -> + VU.null (parentsVertical g n) + && VU.null (childrenVertical g n) + ) + +-- coffmanGrahamAlgo :: Graph -> [[Int]] +-- coffmanGrahamAlgo g = + +addConnectionVertices :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]) +addConnectionVertices (g, ls) = + -- Debug.Trace.trace ("acv"++ show (ls, addConnectionVs (g,ls))) $ + addConnectionVs (g, ls) + +addConnectionVs :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]) +addConnectionVs (graph, []) = (graph, []) +addConnectionVs (graph, [l0]) = (graph, [l0]) +addConnectionVs (graph, l0 : l1 : layers) = (fst adv, l0 : (snd adv)) + where + adv = addConnectionVs (newGraph, (newLayer : layers)) + + (newGraph, newLayer) = foldl dummyNodeEdge (graph, l1) (zip [(fromIntegral (m + 1)) ..] innerSs) + m = maximum (nodes graph) + + innerSs = concatMap innerSegments l0 + innerSegments n = + -- Debug.Trace.trace ("ps"++ show ps) $ + zip3 (repeat n) notInLayerL1Parents chans + where + notInLayerL1Parents = VU.toList (VU.filter isNotInLayerL1 ps) + ps = parentsNoVertical graph n + isNotInLayerL1 = not . (`elem` l1) + chans = map (\e -> maybe (Nothing, 0) f e) edges + f x = (channelNrIn (myhead 71 x), channelNrOut (myhead 72 x)) + edges = map (`lue` n) notInLayerL1Parents + lue x y = Graph.lookupEdge (x, y) graph + + dummyNodeEdge :: (NodeClass n, Show n, EdgeClass e) => (CGraph n e, [UINode]) -> (UINode, (UINode, UINode, (Maybe Int, Int))) -> (CGraph n e, [UINode]) + dummyNodeEdge (g, l) (v, (from, to, (chanIn, chanOut))) = + -- Debug.Trace.trace ("dummyNodeEdge"++ show (v,(from,to,chan))) + (insertConnNode g from to chanIn chanOut, v : l) + +insertConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> UINode -> Maybe Channel -> Channel -> CGraph n e +insertConnNode graph from to chanIn chanOut = + -- Debug.Trace.trace ("dummyNodeEdge"++ show (to, fromIntegral (m+1), chanIn, 0, chanOut, fromIntegral (m+1), from)) + Graph.deleteEdge (Just True) (to, from) $ + Graph.insertEdge (Just True) (to, fromIntegral (m + 1)) [dummyEdge chanIn 0] $ + Graph.insertEdge + (Just True) + (fromIntegral (m + 1), from) + [dummyEdge Nothing chanOut] + (Graph.insertNode (fromIntegral (m + 1)) connectionNode graph) + where + m = maximum (nodes graph) + nest + | isJust lu = Common.nestingFeatures (myFromJust 516 lu) + | otherwise = Nothing + lu = Graph.lookupNode from graph + depth = maybe 1 Common.layer nest + +-- UIEdge 2 1 "" Curly "#ff5863" "" i False False] + +crossingReduction :: (NodeClass n, Show n, EdgeClass e, Show e) => Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]) +crossingReduction i longestP (graph, layers) + | i > 0 -- Debug.Trace.trace ("crossingReduction\nlayers " ++ show layers ++ + -- "\nc "++ show c ++ + -- "\nnewlayers "++ show newLayers) $ + = + crossingReduction (i - 1) longestP (graph, newLayers) + | otherwise = (graph, layers) + where + -- nodes that are at the center of attention + priorityNodes = VU.toList $ longestinfrequentPaths graph revLayers + revLayers = reverse (map (map fromIntegral) layers) + + -- c = -- Debug.Trace.trace ("|r ") $ -- ++ show (layers, priorityNodes)) + -- (crossR graph LeftToRight (map (map fromIntegral) layers) priorityNodes longestP) + -- newLayers = -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes)) + -- map (map fromIntegral) + -- (reverse (crossR graph RightToLeft (reverse c) (reverse priorityNodes) longestP)) + + c = + -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes)) + reverse (crossR graph RightToLeft (reverse (map (map fromIntegral) layers)) (reverse priorityNodes) longestP) + + newLayers = + -- Debug.Trace.trace ("|r ") $ -- ++ show (layers, priorityNodes)) + map + (map fromIntegral) + (crossR graph LeftToRight c priorityNodes longestP) + +crossR :: (NodeClass n, Show n, EdgeClass e, Show e) => CGraph n e -> Dir -> [[Int]] -> [Int] -> Bool -> [[Int]] +crossR _ _ [] _ _ = [] +crossR g dir (l0 : l1 : layers) (n0 : n1 : ns) longestP + | crossings l0Enum bEnum <= crossings l0Enum l1Enum = + -- Debug.Trace.trace ("a0 " ++ show (dir,l0p, b, l1p, (n0:n1:ns), crossings l0Enum bEnum, crossings l0Enum l1Enum,l0,l1) + -- ++ "\n " ++ show (nl0,nl1)) $ + l0p : (crossR g dir (bv : layers) (n1 : ns) longestP) + | otherwise -- map (lv g) $ + -- Debug.Trace.trace ("a1 " ++ show (dir,l0p, b, l1p,l0Enum,l1Enum,bEnum,crossings l0Enum bEnum,crossings l0Enum l1Enum) + -- ++ "\n " ++ show (nl0,nl1)) $ + = + l0p : (crossR g dir (l1p : layers) (n1 : ns) longestP) + where + nl0 = map fst (lv g l0) + nl1 = map fst (lv g l1) + -- isNoVert0 = not (or (map snd (lv g l0))) + -- isNoVert1 = not (or (map snd (lv g l1))) + b = barycenter g dir l0 l1 n1 + bv = map fst (lv g b) + -- m = median g nl0 nl1 + l0p + | isJust (vertNum n0) || longestP = nl0 + | otherwise = nl0 -- n0 : (delete n0 nl0) + l1p + | isJust (vertNum n1) || longestP = nl1 + | otherwise = nl1 -- n1 : (delete n1 nl1) + getY1 ((_, _, _, _), (y1, chan, _, _)) = (fromIntegral y1) * 10 + chan + crossings en0 en1 = + -- Debug.Trace.trace (if nl0 == [9] then "ee " ++ show (lexicographicSort ee) ++ + -- show (VU.map getY1 $ lexicographicSort ee) ++ + -- show (primitiveInversionCount (VU.map getY1 $ lexifromJustcographicSort ee)) else "") $ + primitiveInversionCount (VU.map getY1 $ lexicographicSort ee) + where + ee = VU.fromList (edgesEnum en0 en1 g dir (map fromIntegral nl0)) + l0Enum = IM.fromList (zip nl0 [0 ..]) + l1Enum = IM.fromList (zip nl1 [0 ..]) + bEnum = IM.fromList (zip b [0 ..]) + -- mEnum = IM.fromList (zip m [0..]) + + lu n = Graph.lookupNode (fromIntegral n) g + vertNum n = maybe Nothing Common.verticalNumber (lu n) +crossR _ _ ls ns _ = ls + +-- arrange vertical nodes directly below each other, +-- returns Nothing if there are no vertical nodes in this layer +lv :: EdgeClass e => CGraph n e -> [Int] -> [(Int, Bool)] +lv _ [] = [] +lv g (l : ls) = + -- Debug.Trace.trace ("vertConnected "++ show ((l,ls,ls \\ vertConnected),(goUp ps),l,(goDown cs))) $ + vertConnected ++ (lv g (ls \\ (map fst vertConnected))) + where + vertConnected :: [(Int, Bool)] + vertConnected + | null up && null down = [(l, False)] + | otherwise = map tr (up ++ [l] ++ down) + tr ll = (ll, True) + up = goUp ps + down = goDown cs + ps = map fromIntegral $ VU.toList $ parentsVertical g (fromIntegral l) + goUp :: [Int] -> [Int] + goUp n + | null n = [] + | otherwise = goUp (map fromIntegral $ VU.toList $ parentsVertical g (fromIntegral (head n))) ++ [fromIntegral (head n)] + + cs = map fromIntegral $ VU.toList $ childrenVertical g (fromIntegral l) + goDown :: [Int] -> [Int] + goDown n + | null n = [] + | otherwise = (fromIntegral (head n)) : (goDown (map fromIntegral $ VU.toList $ childrenVertical g (fromIntegral (head n)))) + +-- type YNode = (YPos,Channel,UINode,IsDummy) +edgesEnum :: (NodeClass n, EdgeClass e, Show e) => IM.IntMap UINode -> IM.IntMap UINode -> CGraph n e -> Dir -> [UINode] -> [(YNode, YNode)] +edgesEnum en0 en1 gr dir l0 = catMaybes edges + where + edges :: [Maybe (YNode, YNode)] + edges = map (edge en0 en1) (edgesOfLayer gr l0) + edge :: IM.IntMap UINode -> IM.IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode) + edge e0 e1 (src, tgt) + | isNothing s || isNothing t = Nothing + | otherwise = + Just + ( (myFromJust 517 s, chanNr, src, isDummy gr src), + (myFromJust 518 t, 0, tgt, isDummy gr tgt) + ) + where + s = IM.lookup (fromIntegral src) e0 + t = IM.lookup (fromIntegral tgt) e1 + chanNr + | isJust lu && null (myFromJust 519 lu) = 0 + | isJust lu = channelNrOut (myhead 73 (myFromJust 520 lu)) + | otherwise = 0 + lu = Graph.lookupEdge (tgt, src) gr + + edgesOfLayer :: EdgeClass e => CGraph n e -> [UINode] -> [(UINode, UINode)] + edgesOfLayer g l = concatMap (adjEdges g) l + adjEdges :: EdgeClass e => CGraph n e -> Word32 -> [(UINode, UINode)] + adjEdges g n + | leftToRight dir = map (n,) (VU.toList (parentsNoVertical g n)) + | otherwise = map (n,) (VU.toList (childrenNoVertical g n)) + +-- type YPos = Int +-- type YNode = (YPos,Channel,UINode,IsDummy) + +isNotMainFunctionArg :: NodeClass n => CGraph n e -> UINode -> Bool +isNotMainFunctionArg g node = + -- not (maybe False isMainArg (Graph.lookupNode node g)) + not (isMainArg g node) + +-- Assign every node in l1 a number thats the barycenter of its neighbours in l0, then sort. +-- If the node is marked as a vertical node with a number, this number has precedence in sorting +barycenter :: (NodeClass n, Show n, EdgeClass e, Show e) => CGraph n e -> Dir -> [Int] -> [Int] -> Int -> [Int] +barycenter g dir l0 l1 _ = + -- Debug.Trace.trace ("bary " ++ show (map bc l1, sortOn snd (map bc l1))) $ + map fst (sortOn snd (map bc l1)) + where + bc :: Int -> (Int, Double) + bc node = + -- Debug.Trace.trace ("bc" ++ show (dir, node, ps, cs, l0, l1, nodeWeight dir)) + (node, nodeWeight dir) + where + lenCs = VU.length cs + lenPs = VU.length ps + cs = VU.map fromIntegral (childrenNoVertical g (fromIntegral node)) + ps = VU.map fromIntegral (parentsNoVertical g (fromIntegral node)) + nodeWeight :: Dir -> Double + nodeWeight LeftToRight + | isJust vertNum -- Debug.Trace.trace ("bvert lr "++ show vertNum) + = + (fromIntegral (myFromJust 521 vertNum)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000) + | lenCs == 0 = + -- Debug.Trace.trace "bry -1" + (-1) + -- | node == prioNode = -2 + | otherwise = + -- Debug.Trace.trace ("bsum lr "++ show (VU.map xpos cs)) $ + ((VU.sum (VU.map xpos cs)) / (fromIntegral lenCs)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000) + nodeWeight RightToLeft + | isJust vertNum = + -- Debug.Trace.trace ("bvert rl "++ show vertNum) + (fromIntegral (myFromJust 522 vertNum)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000) + | lenPs == 0 -- Debug.Trace.trace "bry -1" + = + (-1) + -- | node == prioNode = -2 + | otherwise -- Debug.Trace.trace ("bsum rl "++ show (VU.map xpos ps)) $ + = + ((VU.sum (VU.map xpos ps)) / (fromIntegral lenPs)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000) + + lu = Graph.lookupNode (fromIntegral node) g + vertNum = maybe Nothing Common.verticalNumber lu + xpos :: Int -> Double + xpos c = + -- Debug.Trace.trace (show (c, l0,maybe 0 fromIntegral (elemIndex c l0), subPos c)) $ + (maybe 0 fromIntegral (elemIndex c l0)) + + subPos :: Int -> Double + subPos c = + -- Debug.Trace.trace (show channel ++ " : " ++ show channels) $ + (fromIntegral channel) / (fromIntegral channels) + where + channel = maybe 0 channelNrOut edgeLabel + channels = maybe 1 nrTypes (Graph.lookupNode (fromIntegral c) g) + nrTypes x + | isSubLabel x = subLabels x + | otherwise = 1 + edgeLabel + | isNothing (Graph.lookupEdge dEdge g) = Nothing + | null (myFromJust 523 (Graph.lookupEdge dEdge g)) = Nothing + | otherwise = fmap (myhead 74) (Graph.lookupEdge dEdge g) + dEdge = (fromIntegral node, fromIntegral c) + +-- Assign every node in l0 a number thats the median of its neighbours in l1, then sort +median :: EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int] +median g l0 l1 = map fst $ sortOn snd $ map bc l0 + where + bc :: Int -> (Int, Int) + bc node = (node, if len == 0 then 0 else m VU.! (len `div` 2)) + where + len = VU.length cs + cs :: Vector Int + cs = + VU.map + (\x -> fromMaybe 0 (elemIndex (fromIntegral x) l1)) + (childrenNoVertical g (fromIntegral node)) + m = VU.modify I.sort cs + +--TODO: radix sort +--https://hackage.haskell.org/package/uvector-algorithms-0.2/docs/Data-Array-Vector-Algorithms-Radix.html + +-- Sort two edges lexicographically after their y-position in the layer +-- An edge has two points, each point has a y-position (e.g. e0y0) +-- and a node number (e.g. e0n0) +lexicographicSort :: Vector (YNode, YNode) -> VU.Vector (YNode, YNode) +lexicographicSort es = VU.modify (I.sortBy lexicographicOrdering) es + where + lexicographicOrdering + ((e0y0, e0n0, _, _), (e0y1, e0n1, _, _)) + ((e1y0, e1n0, _, _), (e1y1, e1n1, _, _)) + | (e0y0 > e1y0) + || (e0y0 == e1y0 && e0n0 > e1n0) + || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 > e1y1) + || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 > e1n1) = + GT + | e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 == e1n1 = EQ + | otherwise = LT + +-- | See: Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger +primitiveInversionCount :: VU.Vector Int -> Int +primitiveInversionCount xs = + sum + [ if (xs VU.! i) > (xs VU.! j) then 1 else 0 | i <- [0 .. ((VU.length xs) - 1)], j <- [i .. ((VU.length xs) - 1)] + ] + +-- where l = VU.length xs + +-- Modified merge sort for counting of edge crossings +-- which is the same as counting inversions (see) +-- http://www.geeksforgeeks.org/counting-inversions/ + +merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int) +merge ([], _) (ys, inv) = (ys, inv) +merge (xs, inv) ([], _) = (xs, inv) +merge (xs@(x : xt), inv0) (ys@(y : yt), inv1) + | x <= y = (x : (fst (merge (xt, inv0) (ys, inv1))), inv0 + inv1) + | otherwise = (y : (fst (merge (xs, inv0) (yt, inv1))), inv0 + inv1 + length xs) + +split :: [a] -> ([a], [a]) +split (x : y : zs) = let (xs, ys) = split zs in (x : xs, y : ys) +split [x] = ([x], []) +split [] = ([], []) + +mergeSort :: ([Int], Int) -> ([Int], Int) +mergeSort ([], _) = ([], 0) +mergeSort ([x], _) = ([x], 0) +mergeSort (xs, _) = + let (as, bs) = split xs -- num_inv + in merge (mergeSort (as, 0)) (mergeSort (bs, 0)) + +-- https://hackage.haskell.org/package/splaytree +-- https://hackage.haskell.org/package/TreeStructures-0.0.1/docs/Data-Tree-Splay.html + +fromAdj :: EdgeClass e => Map Word32 nl -> [(Word32, [Word32], [e])] -> Graph nl [e] +fromAdj nodesMap adj = foldl (newNodes nodesMap) Graph.empty adj + where + newNodes :: -- (Ord n, VU.Unbox n) => + EdgeClass e => + Map Word32 nl -> + Graph nl [e] -> + (Word32, [Word32], [e]) -> + Graph nl [e] + newNodes nm g (n, ns, eLabel) = + Graph.insertEdges (Just True) edges $ + maybe id (Graph.insertNode (fromIntegral n)) (Map.lookup n nm) $ + Graph.insertNodes lookedUpNodes g + where + lookedUpNodes = mapMaybe addLabel ns + addLabel n1 = fmap (n1,) (Map.lookup n nm) + edges = zip es edgeLbls + es = map (n,) ns + edgeLbls = repeat eLabel + +------------------------------------------------------------------------------------------------------------------------------ + +-- | To be able to jump vertically between nodes in an interactive ui +getColumns :: EdgeClass e => CGraphL n e -> (Map X [UINode], Map.Map Int [Column]) +getColumns (gr, m) = (Map.fromList cols, Map.fromList (zip [0 ..] (divideTables cols))) + where + cols = + map + tupleWithX + ( ( (map (sortBy sorty)) + . (groupBy groupx) + . (sortBy sortx) + ) + (map fromIntegral (Graph.nodes gr)) + ) + tupleWithX :: [UINode] -> (X, [UINode]) + tupleWithX ls = (maybe 0 fst (Map.lookup (myhead 504 ls) m), ls) + groupx n0 n1 = maybe 0 fst (Map.lookup n0 m) == maybe 0 fst (Map.lookup n1 m) + sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m)) + sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m)) + + -- There can be several graphs on the screen that are connected with separating edges + divideTables :: [Column] -> [[Column]] + divideTables [] = [] + divideTables layers = layersWithoutSep : divideTables rest + where + (layersWithoutSep, rest) = sumLayers ([], layers) + sumLayers :: ([Column], [Column]) -> ([Column], [Column]) + sumLayers (s, []) = (s, []) + sumLayers (s, l : ls) + | containsSeparatingEdge (snd l) = (s ++ [l], ls) + | otherwise = sumLayers (s ++ [l], ls) + containsSeparatingEdge ns = any cs ns + cs n = VU.length (childrenSeparating gr n) > 0 + +-- | To be able to jump horizontally between nodes in an interactive ui +getRows :: CGraphL n e -> Map Y [UINode] +getRows (gr, m) = + Map.fromList $ + map + tupleWithY + ( ( (map (sortBy sortx)) + . (groupBy groupy) + . (sortBy sorty) + ) + (map fromIntegral (Graph.nodes gr)) + ) + where + tupleWithY :: [UINode] -> (Y, [UINode]) + tupleWithY ls = (maybe 0 snd (Map.lookup (myhead 504 ls) m), ls) + groupy n0 n1 = maybe 0 snd (Map.lookup n0 m) == maybe 0 snd (Map.lookup n1 m) + sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m)) + sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m)) diff --git a/src/Graph/SubGraphWindows.hs b/src/Graph/SubGraphWindows.hs new file mode 100644 --- /dev/null +++ b/src/Graph/SubGraphWindows.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Graph.SubGraphWindows (subgraphWindows, getColumns, getRows) where + +import qualified Data.IntMap as I +import Data.List (groupBy, sortBy, (\\)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe, isJust) +import qualified Data.Vector.Unboxed as VU +import Debug.Trace ( trace ) +import Graph.CommonGraph + ( CGraph, + CGraphL, + Column, + LayerFeatures (..), + NodeClass (dummyNode, isArgLabel, updateLayer), + EdgeClass, + UINode, + bb, + childrenSeparating, + layer, + lb, + lbb, + ltb, + mid, + myhead, + nestingFeatures, + parentsVertical, + rb, + rbb, + rtb, + tb, + ) +import Graph.GraphDrawing (getColumns, getRows) +import Graph.IntMap (nodes) +import qualified Graph.IntMap as Graph + +data Span = SpanLeftBorder | SpanMiddle | SpanRightBorder | SpanOutside deriving (Show) + +data SpanInOut = Outside | Inside + +type Layer = Int -- the nesting of the window: +-- 0 -> dummy node +-- 1 -> not part of a window +-- 2 -> first window layer + +type X = Int + +type Y = Int + +type Min = Int + +type Max = Int + +subgraphWindows :: (EdgeClass e, NodeClass n, Show n, VU.Unbox UINode) => CGraphL n e -> CGraphL n e +subgraphWindows (graph, pos) + | null ns = (graph, pos) + | otherwise -- Debug.Trace.trace ("subgraphWindows "++ show (graph,pos,newGraph,normalisedPos) ++"\n") -- ++ -- show newGraph ++"\n"++ + -- show pos ++"\n"++ show (rows,zRows,spans zRows) ++"\n"++ show (fst columns,zColumns, spans zColumns)) $ + = + (newGraph, normalisedPos) + where + newGraph = + Graph.mapNodeWithKey + changeNode + filledGraph + + changeNode :: NodeClass n => I.Key -> n -> n + changeNode n node = changeLayer nf n node + where nf = nestingFeatures node + + changeLayer :: NodeClass n => Maybe LayerFeatures -> I.Key -> n -> n + changeLayer Nothing n node + | isArgLabel node = updateLayer (changeStyle l defaultFeatures) node + | otherwise = updateLayer (changeStyle l defaultFeatures) node + where + l = highestLayer xy (spans zRows) (spans zColumns) + xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos) + _xy2 = fromMaybe (0, 0) (Map.lookup (fromIntegral root) normalisedPos) + root = rootOf graph (fromIntegral n) + + changeLayer nestingFeats n node + | isArgLabel node = updateLayer (changeStyle l (Just ((fromJust nestingFeats) {layer = fst l}))) node + | otherwise = updateLayer (changeStyle l nestingFeats) node + where + l = highestLayer xy (spans zRows) (spans zColumns) + xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos) + + rootOf :: EdgeClass e => CGraph n e -> UINode -> UINode + rootOf gr node + | VU.null psVert = node + | otherwise = rootOf gr (VU.head psVert) + where + psVert = parentsVertical gr node + + defaultFeatures = Just (LayerFeatures 0 Nothing) + + changeStyle :: (Int, (Span, Span)) -> Maybe LayerFeatures -> Maybe LayerFeatures + changeStyle (n, (SpanLeftBorder, SpanLeftBorder)) style = maybeReplace style n lbb -- LeftBottomBorder + changeStyle (n, (SpanLeftBorder, SpanMiddle)) style -- n >= 2 = maybeReplace style n mid + = + maybeReplace style n bb -- BottomBorder + changeStyle (n, (SpanLeftBorder, SpanRightBorder)) style -- n >= 2 = maybeReplace style n mid + = + maybeReplace style n rbb -- RightBottomBorder + changeStyle (n, (SpanMiddle, SpanLeftBorder)) style = maybeReplace style n lb -- LeftBorder + changeStyle (n, (SpanMiddle, SpanMiddle)) style = maybeReplace style n mid + changeStyle (n, (SpanMiddle, SpanRightBorder)) style -- n >= 2 = maybeReplace style n mid + = + maybeReplace style n rb -- RightBorder + changeStyle (n, (SpanRightBorder, SpanLeftBorder)) style -- n >= 4 = maybeReplace style n mid + = + maybeReplace style n ltb -- LeftTopBorder + changeStyle (n, (SpanRightBorder, SpanMiddle)) style -- n >= 4 = maybeReplace style n mid + = + maybeReplace style n tb -- TopBorder + changeStyle (n, (SpanRightBorder, SpanRightBorder)) style -- n >= 4 = maybeReplace style n mid + = + maybeReplace style n rtb -- RightTopBorder + changeStyle (_, _) style = style + + maybeReplace :: Maybe LayerFeatures -> Int -> (Int -> Maybe LayerFeatures) -> Maybe LayerFeatures + maybeReplace (Just (LayerFeatures 0 _)) n lf = lf n + maybeReplace (Just (LayerFeatures x _)) _ lf = lf x + maybeReplace _ n lf = Debug.Trace.trace "_" lf n + + filledGraph = Graph.insertNodes (map fr newNodes) graph + fr (n, nl) = (fromIntegral n, nl) + normalisedPos = Map.map (\(x, y) -> (x - minX, y - minY)) (Map.union pos newPos) + + newNodes = zipWith dNode [(m + 1) ..] holes + newPos = Map.fromList (zip (map fromIntegral [(m + 1) ..]) holes) + dNode n _ = (n, dummyNode 1) + m = maximum (nodes graph) + + holes :: [(Int, Int)] + holes = [(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions + + nodePositions = Map.elems pos + + ns = I.toList (Graph.nodeLabels graph) + + minX = minimum (map fst nodePositions) + minY = minimum (map snd nodePositions) + maxX = maximum (map fst nodePositions) + maxY = maximum (map snd nodePositions) + + rows :: Map Y [UINode] + rows = getRows (filledGraph, normalisedPos) + columns = getColumns (filledGraph, normalisedPos) + + maxZCoord = maximum $ map (\(_, nl) -> zOfNode nl) ns + zOfNode nl = maybe 0 layer (nestingFeatures nl) + + zLayers :: [(X, [UINode])] -> [(Layer, [(X, [Layer])])] + zLayers xs = map getLayer (reverse [1 .. maxZCoord]) + where + getLayer l = (l, map zOfNodes xs) + where + zOfNodes (x, ns1) = (x, map zLayer ns1) + zLayer n + | isJust lu && zOfNode (fromJust lu) >= l = l + | otherwise = 0 + where + lu = Graph.lookupNode n graph + + zRows :: [(Layer, [(X, [Layer])])] + zRows = zLayers (Map.toList rows) + zColumns = zLayers (Map.toList (fst columns)) + + spans :: [(Layer, [(X, [Layer])])] -> Map Layer (Map X [(Min, Max)]) + spans ls = Map.fromList (map zSpans ls) + where + zSpans (z, rs) = (z, Map.fromList (map rowsColums rs)) + where + rowsColums (x, layers) = (x, minMax layers 0 0 Outside) + + minMax :: [Layer] -> Int -> Int -> SpanInOut -> [(Min, Max)] + minMax [] start i Inside = [(start, i - 1)] + minMax [] _ _ _ = [] + minMax (l : layers) start i Outside + | l == z = minMax layers i (i + 1) Inside + | otherwise = minMax layers start (i + 1) Outside + minMax (l : layers) start i Inside + | l == z = minMax layers start (i + 1) Inside + | otherwise = (start, i - 1) : minMax layers start (i + 1) Outside + + highestLayer :: + (X, Y) -> + Map Layer (Map X [(Min, Max)]) -> + Map Layer (Map X [(Min, Max)]) -> + (Layer, (Span, Span)) + highestLayer (x, y) hrows cols = findFirstWindow maxZCoord + where + findFirstWindow 0 = (0, (SpanOutside, SpanOutside)) + findFirstWindow z + | found c r = (z, (c, r)) + | otherwise = findFirstWindow (z - 1) + where + c = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) True) (Map.lookup z cols) + r = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) False) (Map.lookup z hrows) + found SpanOutside _ = False + found _ SpanOutside = False + found _ _ = True + + -- Is there at least one neighboring row/column that includes the X/Y coordinate in its span + overlappedByNeighbouringSpans :: (X, Y) -> Bool -> Map X [(Min, Max)] -> Span + overlappedByNeighbouringSpans (x, y) isColumn nspans + | isColumn = maybe SpanOutside spanPositionColumn (minmax (goLeft x ++ goRight (x + 1))) + | otherwise = maybe SpanOutside spanPositionRow (minmax (goLeft y ++ goRight (y + 1))) + where + spanPositionColumn (smin, smax) + | y == smin = SpanRightBorder + | y == smax = SpanLeftBorder + | y > smin && y < smax = SpanMiddle + | otherwise = SpanOutside + spanPositionRow (smin, smax) + | x == smin = SpanLeftBorder + | x == smax = SpanRightBorder + | x > smin && x < smax = SpanMiddle + | otherwise = SpanOutside + minmax xs + | null xs = Nothing + | otherwise = Just (minimum (map fst xs), maximum (map snd xs)) + + goLeft p + | null mm = mm + | otherwise = mm ++ goLeft (p - 1) + where + mm = fromMaybe [] (Map.lookup p nspans) + + goRight p + | null mm = mm + | otherwise = mm ++ goRight (p + 1) + where + mm = fromMaybe [] (Map.lookup p nspans)