diff --git a/Blobs.cabal b/Blobs.cabal new file mode 100644 --- /dev/null +++ b/Blobs.cabal @@ -0,0 +1,42 @@ +Name: Blobs +Version: 0.1 +License: LGPL +License-file: LICENCE-LGPL +Author: Arjan van IJzendoorn, Martijn Schrage, Malcolm Wallace +maintainer: Alan Zimmerman +Synopsis: Diagram editor +Description: + Blobs is a diagram editor for directed graphs. It is written in + Haskell, using the platform-independent GUI toolkit wxHaskell. It + is a community project at a fairly early stage of development - you + are encouraged to get involved and improve it! + . + Blobs is a front-end for drawing and editing graph diagrams. You + must add your own back-end engine if you want it to do some + analysis or processing of the graph. +Category: Graphics +Stability: unstable +cabal-version: >= 1.9.2 +build-type: Simple +Homepage: http://www.cs.york.ac.uk/fp/darcs/Blobs/ +bug-reports: http://github.com/alanz/Blobs/issues + +Extra-source-files: + Blobs.icns, blobs.png, dazzle.jpg, index.html, patch.icons, + README.md, simple.blobpalette, wiring.blobs, + ./src/*.hs + ./lib/DData/*.hs + +data-files: + Blobs.icns, blobs.png, dazzle.jpg, index.html, patch.icons, + simple.blobpalette, wiring.blobs + +executable blobs + main-is: Main.hs + Build-Depends: base >= 4 && < 5, haskell98, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14 + , polyparse, directory, pretty, containers + Hs-Source-Dirs: src lib/DData + +source-repository head + type: git + location: git://github.com/alanz/Blobs.git diff --git a/Blobs.icns b/Blobs.icns new file mode 100644 Binary files /dev/null and b/Blobs.icns differ diff --git a/LICENCE-LGPL b/LICENCE-LGPL new file mode 100644 --- /dev/null +++ b/LICENCE-LGPL @@ -0,0 +1,507 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +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 this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +Blobs +===== + +Blobs from http://www.cs.york.ac.uk/fp/darcs/Blobs/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/blobs.png b/blobs.png new file mode 100644 Binary files /dev/null and b/blobs.png differ diff --git a/dazzle.jpg b/dazzle.jpg new file mode 100644 Binary files /dev/null and b/dazzle.jpg differ diff --git a/index.html b/index.html new file mode 100644 --- /dev/null +++ b/index.html @@ -0,0 +1,234 @@ + + + + + Blobs diagram editor + + + + + +
+

Blobs

+

a diagram editor in Haskell

+
+
+ Blobs editor with FPTC + + Dazzle +
+
+
+ +
+What is Blobs?
+How do I use it?
+		 +Downloads
+How can I contribute?
+
+
+
+ + +

What is Blobs?

+

+Blobs is a diagram editor for directed graphs. It is written in +Haskell, using the platform-independent GUI toolkit wxHaskell. It is a +community project at a fairly early stage of development - you are +encouraged to get involved and improve it! + +

+Blobs is a front-end for drawing and editing graph diagrams. +You must add your own back-end engine if you want it to +do some analysis or processing of the graph. There are +various analysis engines that use Blobs as a front-end, e.g. +

    +
  • Dazzle for bayesian analysis + of networks; +
  • FPTC for safety analysis of systems designs; +
  • INBlobs for + editing and interpreting Interaction Nets; +
+but these are not currently available as open source. We do supply a +couple of very simple engines, just to demonstrate how to connect the +engine up to Blobs. + +

+What can Blobs do? +

    +
  • Draw nodes with textual labels, and optional extra (polymorphic) + information labels. +
  • Connect nodes together with edges. An edge has optional extra + information labels. +
  • You can create palettes of different node shapes, and load a + palette into the editor. (Currently, palette creation is by + hand, not graphical.) +
  • Graphs are stored in an XML file format. +
  • If you have a backend engine, you can send the graph to it for + analysis, receiving a graph back for viewing as a result. +
+ + +
+

Downloads

+ +

+Because Blobs does not do anything much useful on its own, there is no +released version of Blobs. Individual projects which share Blobs as a +component have their own separate releases. + +

+To use Blobs in your own project, you must collect a copy of the +darcs repository. +

+    darcs get http://www.cs.york.ac.uk/fp/darcs/Blobs
+
+The source tree and version history can be browsed on-line through +darcsweb. + +

Copyright: © 2005 the authors and contributors. + +

+Blobs was originally written by Arjan van IJzendoorn and Martijn +Schrage of the Universiteit Utrecht. Other contributors include +Malcolm Wallace. Full details are in the COPYRIGHT file. + +

License: This software is distributed under +the terms of the LGPL (see file LICENCE-LGPL +for more details), but there is a special exception clause detailed in +file COPYRIGHT. + +

+This software comes with no warranty. Use at your own risk. + +

+

How do I use it?

+

+ +

+Building instructions +

+To build Blobs, you need: +

    +
  • ghc-6.2.2 + (Note 6.4 may work, untested) +
  • wxWidgets +
  • wxHaskell-0.9.0 + (or later?) +
  • HaXml-1.15 + (Note, this unstable version or later is required.) +
+ +

+On Windows you may also need to install +mingw in order to have the GNU make +utility etc. + +

+In the toplevel Blobs directory, there is a Makefile. You may need to +edit it slightly, e.g. for a different version of ghc, or to +enable/disable building a MacOS application bundle (symbol MAC=yes). + +

+Just type 'make' and Blobs should build. If you change or add any +imports in the code itself, you may need to 'make depend' to update the +Makefile. + +

+Usage instructions +

+

    +
  • Right click on the canvas, nodes, and edges for context menus. +
  • To create a node, shift click on some blank canvas. +
  • To create an edge, select (click) the source node then shift-click + the target node. +
  • To delete a node or edge, select it and press backspace. +
  • To rearrange the diagram, click and drag nodes to where you want them. +
  • To make an edge look tidier, add a control-point from its context menu, + and drag the point to where you want it. +
  • You can add multiple items into the current selection by meta-clicking + the extra nodes and control points. (Meta = Apple key, or Alt key.) + A multiple selection can be dragged just like a single selection. +
+ + +
+

How can I contribute to Blobs?

+

+ +

+Step one: join the +Blobs mailing list. + +

+Step two: darcs send your patches to the list. + +

+Discussion about features is encouraged before you implement them. +Patches to create or improve documentation (including this webpage) are +just as welcome as actual code. + +

+To Do list +

+

    +
  • More than one analysis method. Currently, there is a class + Analysis with the methods analysis and + revert. But this means there can only ever be one + implementation of analysis for a given graph type. The class + should be replaced with a concrete datatype containing a lookup + table of analysis methods. Then the Edit menu can show as many or + as few analyses as are available. +
    Done, MW, 2005-11-16. The GraphOps datatype + (in module Operations) replaces the Analysis class. There is a new + "Operations" menu. +
  • Multiple selection. The ability to group multiple nodes + together, by selecting a rectangular area of the diagram. They can + then be dragged or deleted together. (Should also select any edge + control-points within the area.) +
    Partially done, MW, 2005-11-16. Implemented + multiple selection with meta-click. But dragging a rectangular + area (to select everything within it) remains to be done. +
    Nearly complete, MW, 2005-11-17. + Dragging a rectangular area now selects everything within it. + The rectangular area itself is not yet highlighted, just the + contained items. +
    Complete, MW, 2005-11-18. + Multiple selection by dragging out a rectangle now displays the + rectangle as well as the selected items. +
  • Positioning guides. Apple Keynote has the best diagram + layout editor I have ever come across. When one object lines up + horizontally or vertically with any other object on the diagram a + yellow line appears connecting up their centres. (It disappears + again once you drop the object). This simple idea makes it + incredibly easy to get things looking just right, without any need + for absolute coords or grids etc. I think the objects also "snap" + to the line when the mouse is within one or two pixels of the + alignment. +
  • Visible palette. At the moment, if you load a palette from file, + you get the palette on the right-click context menu of nodes. But this + is a bit nasty, because (a) you have to create the node first, then + change its shape; (b) you can't see pictures of the palette. So + there should be a separate window with a table of all the node + shapes in the palette. Selecting a shape from the palette will make + that the default shape for all subsequent node-creation until another + shape is selected from the palette. +
  • Palette editor. How do you create a palette? At the moment, + by hand in a text editor. Much better to have a graphical way of + creating shapes, cutting-n-pasting shapes into palette sets, etc. +
  • Edge palette. Do we need a palette of different edge shapes + as well as node shapes? +
  • Ports. A node may need some specific connection ports, where + edges may attach to. For instance, this might be because the + information stored at a node is an expression to be applied to + inputs from edges, generating output on other edges. The expression + would need to distinguish different input sources and output channels. + +
+ +
+ + + diff --git a/lib/DData/IntBag.hs b/lib/DData/IntBag.hs new file mode 100644 --- /dev/null +++ b/lib/DData/IntBag.hs @@ -0,0 +1,368 @@ +-------------------------------------------------------------------------------- +{-| Module : IntBag + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of bags of integers on top of the "IntMap" module. + + Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements with a maximum of /W/ + -- the number of bits in an 'Int' (32 or 64). For more information, see + the references in the "IntMap" module. +-} +---------------------------------------------------------------------------------} +module IntBag ( + -- * Bag type + IntBag -- instance Eq,Show + + -- * Operators + , (\\) + + -- *Query + , isEmpty + , size + , distinctSize + , member + , occur + + , subset + , properSubset + + -- * Construction + , empty + , single + , insert + , insertMany + , delete + , deleteAll + + -- * Combine + , union + , difference + , intersection + , unions + + -- * Filter + , filter + , partition + + -- * Fold + , fold + , foldOccur + + -- * Conversion + , elems + + -- ** List + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- ** Occurrence lists + , toOccurList + , toAscOccurList + , fromOccurList + , fromAscOccurList + + -- ** IntMap + , toMap + , fromMap + , fromOccurMap + + -- * Debugging + , showTree + , showTreeWith + ) where + +import Prelude hiding (map,filter) +import qualified Prelude (map,filter) + +import qualified IntMap as M + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ + +-- | /O(n+m)/. See 'difference'. +(\\) :: IntBag -> IntBag -> IntBag +b1 \\ b2 = difference b1 b2 + +{-------------------------------------------------------------------- + IntBags are a simple wrapper around Maps, 'Map.Map' +--------------------------------------------------------------------} +-- | A bag of integers. +newtype IntBag = IntBag (M.IntMap Int) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the bag empty? +isEmpty :: IntBag -> Bool +isEmpty (IntBag m) + = M.isEmpty m + +-- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@). +distinctSize :: IntBag -> Int +distinctSize (IntBag m) + = M.size m + +-- | /O(n)/. The number of elements in the bag. +size :: IntBag -> Int +size b + = foldOccur (\x n m -> n+m) 0 b + +-- | /O(min(n,W))/. Is the element in the bag? +member :: Int -> IntBag -> Bool +member x m + = (occur x m > 0) + +-- | /O(min(n,W))/. The number of occurrences of an element in the bag. +occur :: Int -> IntBag -> Int +occur x (IntBag m) + = case M.lookup x m of + Nothing -> 0 + Just n -> n + +-- | /O(n+m)/. Is this a subset of the bag? +subset :: IntBag -> IntBag -> Bool +subset (IntBag m1) (IntBag m2) + = M.subsetBy (<=) m1 m2 + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) +properSubset :: IntBag -> IntBag -> Bool +properSubset b1 b2 + = subset b1 b2 && (b1 /= b2) + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty bag. +empty :: IntBag +empty + = IntBag (M.empty) + +-- | /O(1)/. Create a singleton bag. +single :: Int -> IntBag +single x + = IntBag (M.single x 0) + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Insert an element in the bag. +insert :: Int -> IntBag -> IntBag +insert x (IntBag m) + = IntBag (M.insertWith (+) x 1 m) + +-- | /O(min(n,W))/. The expression (@insertMany x count bag@) +-- inserts @count@ instances of @x@ in the bag @bag@. +insertMany :: Int -> Int -> IntBag -> IntBag +insertMany x count (IntBag m) + = IntBag (M.insertWith (+) x count m) + +-- | /O(min(n,W))/. Delete a single element. +delete :: Int -> IntBag -> IntBag +delete x (IntBag m) + = IntBag (M.updateWithKey f x m) + where + f x n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(min(n,W))/. Delete all occurrences of an element. +deleteAll :: Int -> IntBag -> IntBag +deleteAll x (IntBag m) + = IntBag (M.delete x m) + +{-------------------------------------------------------------------- + Combine +--------------------------------------------------------------------} +-- | /O(n+m)/. Union of two bags. The union adds the elements together. +-- +-- > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,1,1,2,2,2,3} +union :: IntBag -> IntBag -> IntBag +union (IntBag t1) (IntBag t2) + = IntBag (M.unionWith (+) t1 t2) + +-- | /O(n+m)/. Intersection of two bags. +-- +-- > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,2} +intersection :: IntBag -> IntBag -> IntBag +intersection (IntBag t1) (IntBag t2) + = IntBag (M.intersectionWith min t1 t2) + +-- | /O(n+m)/. Difference between two bags. +-- +-- > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1} +difference :: IntBag -> IntBag -> IntBag +difference (IntBag t1) (IntBag t2) + = IntBag (M.differenceWithKey f t1 t2) + where + f x n m | n-m > 0 = Just (n-m) + | otherwise = Nothing + +-- | The union of a list of bags. +unions :: [IntBag] -> IntBag +unions bags + = IntBag (M.unions [m | IntBag m <- bags]) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: (Int -> Bool) -> IntBag -> IntBag +filter p (IntBag m) + = IntBag (M.filterWithKey (\x n -> p x) m) + +-- | /O(n)/. Partition the bag according to some predicate. +partition :: (Int -> Bool) -> IntBag -> (IntBag,IntBag) +partition p (IntBag m) + = (IntBag l,IntBag r) + where + (l,r) = M.partitionWithKey (\x n -> p x) m + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over each element in the bag. +fold :: (Int -> b -> b) -> b -> IntBag -> b +fold f z (IntBag m) + = M.foldWithKey apply z m + where + apply x n z | n > 0 = apply x (n-1) (f x z) + | otherwise = z + +-- | /O(n)/. Fold over all occurrences of an element at once. +-- In a call (@foldOccur f z bag@), the function @f@ takes +-- the element first and than the occur count. +foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b +foldOccur f z (IntBag m) + = M.foldWithKey f z m + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The list of elements. +elems :: IntBag -> [Int] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Create a list with all elements. +toList :: IntBag -> [Int] +toList s + = toAscList s + +-- | /O(n)/. Create an ascending list of all elements. +toAscList :: IntBag -> [Int] +toAscList (IntBag m) + = [y | (x,n) <- M.toAscList m, y <- replicate n x] + + +-- | /O(n*min(n,W))/. Create a bag from a list of elements. +fromList :: [Int] -> IntBag +fromList xs + = IntBag (M.fromListWith (+) [(x,1) | x <- xs]) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list. +fromAscList :: [Int] -> IntBag +fromAscList xs + = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs]) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements. +fromDistinctAscList :: [Int] -> IntBag +fromDistinctAscList xs + = IntBag (M.fromDistinctAscList [(x,1) | x <- xs]) + +-- | /O(n)/. Create a list of element\/occurrence pairs. +toOccurList :: IntBag -> [(Int,Int)] +toOccurList b + = toAscOccurList b + +-- | /O(n)/. Create an ascending list of element\/occurrence pairs. +toAscOccurList :: IntBag -> [(Int,Int)] +toAscOccurList (IntBag m) + = M.toAscList m + +-- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs. +fromOccurList :: [(Int,Int)] -> IntBag +fromOccurList xs + = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs. +fromAscOccurList :: [(Int,Int)] -> IntBag +fromAscOccurList xs + = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +{-------------------------------------------------------------------- + Maps +--------------------------------------------------------------------} +-- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences. +toMap :: IntBag -> M.IntMap Int +toMap (IntBag m) + = m + +-- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. +fromMap :: M.IntMap Int -> IntBag +fromMap m + = IntBag (M.filter (>0) m) + +-- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. +-- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once. +fromOccurMap :: M.IntMap Int -> IntBag +fromOccurMap m + = IntBag m + +{-------------------------------------------------------------------- + Eq, Ord +--------------------------------------------------------------------} +instance Eq (IntBag) where + (IntBag m1) == (IntBag m2) = (m1==m2) + (IntBag m1) /= (IntBag m2) = (m1/=m2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show (IntBag) where + showsPrec d b = showSet (toAscList b) + +showSet :: Show a => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree +-- is shown as a compressed and /hanging/. +showTree :: IntBag -> String +showTree bag + = showTreeWith True False bag + +-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows +-- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version +-- is shown. +showTreeWith :: Bool -> Bool -> IntBag -> String +showTreeWith hang wide (IntBag m) + = M.showTreeWith hang wide m + diff --git a/lib/DData/IntMap.hs b/lib/DData/IntMap.hs new file mode 100644 --- /dev/null +++ b/lib/DData/IntMap.hs @@ -0,0 +1,1243 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : IntMap + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of maps from integer keys to values. + + 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. + If you want to use "IntMap" unqualified, these functions should be hidden. + + > import Prelude hiding (map,lookup,filter) + > import IntMap + + Another solution is to use qualified names. + + > import qualified IntMap + > + > ... IntMap.single "Paris" "France" + + Or, if you prefer a terse coding style: + + > import qualified IntMap as M + > + > ... M.single "Paris" "France" + + 2) The implementation is based on /big-endian patricia trees/. This data structure + performs especially well on binary operations like 'union' and 'intersection'. However, + my benchmarks show that it is also (much) faster on insertions and deletions when + compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap"). + + * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", + Workshop on ML, September 1998, pages 77--86, + + * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information + Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534. + + 3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements + with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-} +--------------------------------------------------------------------------------- +module IntMap ( + -- * Map type + IntMap, Key -- instance Eq,Show + + -- * Operators + , (!), (\\) + + -- * Query + , isEmpty + , size + , member + , lookup + , find + , findWithDefault + + -- * Construction + , empty + , single + + -- ** Insertion + , insert + , insertWith, insertWithKey, insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + + -- ** Fold + , fold + , foldWithKey + + -- * Conversion + , elems + , keys + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , split + , splitLookup + + -- * Subset + , subset, subsetBy + , properSubset, properSubsetBy + + -- * Debugging + , showTree + , showTreeWith + ) where + + +import Prelude hiding (lookup,map,filter) +import Bits +import Int + +{- +-- just for testing +import qualified Prelude +import Debug.QuickCheck +import List (nub,sort) +import qualified List +-} + +#ifdef __GLASGOW_HASKELL__ +{-------------------------------------------------------------------- + GHC: use unboxing to get @shiftRL@ inlined. +--------------------------------------------------------------------} +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Word +import GHC.Exts ( Word(..), Int(..), shiftRL# ) +#else +import Word +import GlaExts ( Word(..), Int(..), shiftRL# ) +#endif + +infixl 9 \\ -- cpp nonsense + +type Nat = Word + +natFromInt :: Key -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Key +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Key -> Nat +shiftRL (W# x) (I# i) + = W# (shiftRL# x i) + +#elif __HUGS__ +{-------------------------------------------------------------------- + Hugs: + * raises errors on boundary values when using 'fromIntegral' + but not with the deprecated 'fromInt/toInt'. + * Older Hugs doesn't define 'Word'. + * Newer Hugs defines 'Word' in the Prelude but no operations. +--------------------------------------------------------------------} +import Word +infixl 9 \\ + +type Nat = Word32 -- illegal on 64-bit platforms! + +natFromInt :: Key -> Nat +natFromInt i = fromInt i + +intFromNat :: Nat -> Key +intFromNat w = toInt w + +shiftRL :: Nat -> Key -> Nat +shiftRL x i = shiftR x i + +#else +{-------------------------------------------------------------------- + 'Standard' Haskell + * A "Nat" is a natural machine word (an unsigned Int) +--------------------------------------------------------------------} +import Word +infixl 9 \\ + +type Nat = Word + +natFromInt :: Key -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Key +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Key -> Nat +shiftRL w i = shiftR w i + +#endif + + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} + +-- | /O(min(n,W))/. See 'find'. +(!) :: IntMap a -> Key -> a +m ! k = find k m + +-- | /O(n+m)/. See 'difference'. +(\\) :: IntMap a -> IntMap a -> IntMap a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} +-- | A map of integers to values @a@. +data IntMap a = Nil + | Tip !Key a + | Bin !Prefix !Mask !(IntMap a) !(IntMap a) + +type Prefix = Int +type Mask = Int +type Key = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the map empty? +isEmpty :: IntMap a -> Bool +isEmpty Nil = True +isEmpty other = False + +-- | /O(n)/. Number of elements in the map. +size :: IntMap a -> Int +size t + = case t of + Bin p m l r -> size l + size r + Tip k x -> 1 + Nil -> 0 + +-- | /O(min(n,W))/. Is the key a member of the map? +member :: Key -> IntMap a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just x -> True + +-- | /O(min(n,W))/. Lookup the value of a key in the map. +lookup :: Key -> IntMap a -> Maybe a +lookup k t + = case t of + Bin p m l r + | nomatch k p m -> Nothing + | zero k m -> lookup k l + | otherwise -> lookup k r + Tip kx x + | (k==kx) -> Just x + | otherwise -> Nothing + Nil -> Nothing + +-- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found. +find :: Key -> IntMap a -> a +find k m + = case lookup k m of + Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map") + Just x -> x + +-- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when +-- the key is not an element of the map. +findWithDefault :: a -> Key -> IntMap a -> a +findWithDefault def k m + = case lookup k m of + Nothing -> def + Just x -> x + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty map. +empty :: IntMap a +empty + = Nil + +-- | /O(1)/. A map of one element. +single :: Key -> a -> IntMap a +single k x + = Tip k x + +{-------------------------------------------------------------------- + Insert + 'insert' is the inlined version of 'insertWith (\k x y -> x)' +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key +-- is already an element of the set, it's value is replaced by the new value, +-- ie. 'insert' is left-biased. +insert :: Key -> a -> IntMap a -> IntMap a +insert k x t + = case t of + Bin p m l r + | nomatch k p m -> join k (Tip k x) p t + | zero k m -> Bin p m (insert k x l) r + | otherwise -> Bin p m l (insert k x r) + Tip ky y + | k==ky -> Tip k x + | otherwise -> join k (Tip k x) ky t + Nil -> Tip k x + +-- right-biased insertion, used by 'union' +-- | /O(min(n,W))/. Insert with a combining function. +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith f k x t + = insertWithKey (\k x y -> f x y) k x t + +-- | /O(min(n,W))/. Insert with a combining function. +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey f k x t + = case t of + Bin p m l r + | nomatch k p m -> join k (Tip k x) p t + | zero k m -> Bin p m (insertWithKey f k x l) r + | otherwise -> Bin p m l (insertWithKey f k x r) + Tip ky y + | k==ky -> Tip k (f k x y) + | otherwise -> join k (Tip k x) ky t + Nil -> Tip k x + + +-- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where +-- the first element is equal to (@lookup k map@) and the second element +-- equal to (@insertWithKey f k x map@). +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertLookupWithKey f k x t + = case t of + Bin p m l r + | nomatch k p m -> (Nothing,join k (Tip k x) p t) + | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r) + | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r') + Tip ky y + | k==ky -> (Just y,Tip k (f k x y)) + | otherwise -> (Nothing,join k (Tip k x) ky t) + Nil -> (Nothing,Tip k x) + + +{-------------------------------------------------------------------- + Deletion + [delete] is the inlined version of [deleteWith (\k x -> Nothing)] +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: Key -> IntMap a -> IntMap a +delete k t + = case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> bin p m (delete k l) r + | otherwise -> bin p m l (delete k r) + Tip ky y + | k==ky -> Nil + | otherwise -> t + Nil -> Nil + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjust :: (a -> a) -> Key -> IntMap a -> IntMap a +adjust f k m + = adjustWithKey (\k x -> f x) k m + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a +adjustWithKey f k m + = updateWithKey (\k x -> Just (f k x)) k m + +-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k m + = updateWithKey (\k x -> f x) k m + +-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a +updateWithKey f k t + = case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> bin p m (updateWithKey f k l) r + | otherwise -> bin p m l (updateWithKey f k r) + Tip ky y + | k==ky -> case (f k y) of + Just y' -> Tip ky y' + Nothing -> Nil + | otherwise -> t + Nil -> Nil + +-- | /O(min(n,W))/. Lookup and update. +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) +updateLookupWithKey f k t + = case t of + Bin p m l r + | nomatch k p m -> (Nothing,t) + | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r) + | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r') + Tip ky y + | k==ky -> case (f k y) of + Just y' -> (Just y,Tip ky y') + Nothing -> (Just y,Nil) + | otherwise -> (Nothing,t) + Nil -> (Nothing,Nil) + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of maps. +unions :: [IntMap a] -> IntMap a +unions xs + = foldlStrict union empty xs + + +-- | /O(n+m)/. The (left-biased) union of two sets. +union :: IntMap a -> IntMap a -> IntMap a +union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 + | otherwise = Bin p1 m1 l1 (union r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 + | otherwise = Bin p2 m2 l2 (union t1 r2) + +union (Tip k x) t = insert k x t +union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias +union Nil t = t +union t Nil = t + +-- | /O(n+m)/. The union with a combining function. +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWith f m1 m2 + = unionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. The union with a combining function. +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1 + | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2 + | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2) + +unionWithKey f (Tip k x) t = insertWithKey f k x t +unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias +unionWithKey f Nil t = t +unionWithKey f t Nil = t + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference between two maps (based on keys). +difference :: IntMap a -> IntMap a -> IntMap a +difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (difference l1 t2) r1 + | otherwise = bin p1 m1 l1 (difference r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = difference t1 l2 + | otherwise = difference t1 r2 + +difference t1@(Tip k x) t2 + | member k t2 = Nil + | otherwise = t1 + +difference Nil t = Nil +difference t (Tip k x) = delete k t +difference t Nil = t + +-- | /O(n+m)/. Difference with a combining function. +differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a +differenceWith f m1 m2 + = differenceWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns @Nothing@, the element is discarded (proper set difference). If +-- it returns (@Just y@), the element is updated with a new value @y@. +differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a +differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1 + | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = differenceWithKey f t1 l2 + | otherwise = differenceWithKey f t1 r2 + +differenceWithKey f t1@(Tip k x) t2 + = case lookup k t2 of + Just y -> case f k x y of + Just y' -> Tip k y' + Nothing -> Nil + Nothing -> t1 + +differenceWithKey f Nil t = Nil +differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t +differenceWithKey f t Nil = t + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). +intersection :: IntMap a -> IntMap a -> IntMap a +intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersection l1 t2 + | otherwise = intersection r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersection t1 l2 + | otherwise = intersection t1 r2 + +intersection t1@(Tip k x) t2 + | member k t2 = t1 + | otherwise = Nil +intersection t (Tip k x) + = case lookup k t of + Just y -> Tip k y + Nothing -> Nil +intersection Nil t = Nil +intersection t Nil = Nil + +-- | /O(n+m)/. The intersection with a combining function. +intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +intersectionWith f m1 m2 + = intersectionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. The intersection with a combining function. +intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersectionWithKey f l1 t2 + | otherwise = intersectionWithKey f r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersectionWithKey f t1 l2 + | otherwise = intersectionWithKey f t1 r2 + +intersectionWithKey f t1@(Tip k x) t2 + = case lookup k t2 of + Just y -> Tip k (f k x y) + Nothing -> Nil +intersectionWithKey f t1 (Tip k y) + = case lookup k t1 of + Just x -> Tip k (f k x y) + Nothing -> Nil +intersectionWithKey f Nil t = Nil +intersectionWithKey f t Nil = Nil + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@). +properSubset :: Eq a => IntMap a -> IntMap a -> Bool +properSubset m1 m2 + = properSubsetBy (==) m1 m2 + +{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). + The expression (@properSubsetBy f m1 m2@) returns @True@ when + @m1@ and @m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) + > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool +properSubsetBy pred t1 t2 + = case subsetCmp pred t1 t2 of + LT -> True + ge -> False + +subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = subsetCmpLt + | p1 == p2 = subsetCmpEq + | otherwise = GT -- disjoint + where + subsetCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = subsetCmp pred t1 l2 + | otherwise = subsetCmp pred t1 r2 + subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + other -> LT + +subsetCmp pred (Bin p m l r) t = GT +subsetCmp pred (Tip kx x) (Tip ky y) + | (kx == ky) && pred x y = EQ + | otherwise = GT -- disjoint +subsetCmp pred (Tip k x) t + = case lookup k t of + Just y | pred x y -> LT + other -> GT -- disjoint +subsetCmp pred Nil Nil = EQ +subsetCmp pred Nil t = LT + +-- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@). +subset :: Eq a => IntMap a -> IntMap a -> Bool +subset m1 m2 + = subsetBy (==) m1 m2 + +{- | /O(n+m)/. + The expression (@subsetBy f m1 m2@) returns @True@ if + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) + > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) +-} + +subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool +subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2 + else subsetBy pred t1 r2) + | otherwise = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2 +subsetBy pred (Bin p m l r) t = False +subsetBy pred (Tip k x) t = case lookup k t of + Just y -> pred x y + Nothing -> False +subsetBy pred Nil t = True + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> IntMap a -> IntMap b +map f m + = mapWithKey (\k x -> f x) m + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey f t + = case t of + Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) + Tip k x -> Tip k (f k x) + Nil -> Nil + +-- | /O(n)/. The function @mapAccum@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccum f a m + = mapAccumWithKey (\a k x -> f a x) a m + +-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | /O(n)/. The function @mapAccumL@ threads an accumulating +-- argument through the map in pre-order. +mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumL f a t + = case t of + Bin p m l r -> let (a1,l') = mapAccumL f a l + (a2,r') = mapAccumL f a1 r + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + + +-- | /O(n)/. The function @mapAccumR@ threads an accumulating +-- argument throught the map in post-order. +mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumR f a t + = case t of + Bin p m l r -> let (a1,r') = mapAccumR f a r + (a2,l') = mapAccumR f a1 l + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter all values that satisfy some predicate. +filter :: (a -> Bool) -> IntMap a -> IntMap a +filter p m + = filterWithKey (\k x -> p x) m + +-- | /O(n)/. Filter all keys\/values that satisfy some predicate. +filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a +filterWithKey pred t + = case t of + Bin p m l r + -> bin p m (filterWithKey pred l) (filterWithKey pred r) + Tip k x + | pred k x -> t + | otherwise -> Nil + Nil -> Nil + +-- | /O(n)/. partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a) +partition p m + = partitionWithKey (\k x -> p x) m + +-- | /O(n)/. partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a) +partitionWithKey pred t + = case t of + Bin p m l r + -> let (l1,l2) = partitionWithKey pred l + (r1,r2) = partitionWithKey pred r + in (bin p m l1 r1, bin p m l2 r2) + Tip k x + | pred k x -> (t,Nil) + | otherwise -> (Nil,t) + Nil -> (Nil,Nil) + + +-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ +-- where all keys in @map1@ are lower than @k@ and all keys in +-- @map2@ larger than @k@. +split :: Key -> IntMap a -> (IntMap a,IntMap a) +split k t + = case t of + Bin p m l r + | zero k m -> let (lt,gt) = split k l in (lt,union gt r) + | otherwise -> let (lt,gt) = split k r in (union l lt,gt) + Tip ky y + | k>ky -> (t,Nil) + | k (Nil,t) + | otherwise -> (Nil,Nil) + Nil -> (Nil,Nil) + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- key was found in the original map. +splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a) +splitLookup k t + = case t of + Bin p m l r + | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r) + | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt) + Tip ky y + | k>ky -> (Nothing,t,Nil) + | k (Nothing,Nil,t) + | otherwise -> (Just y,Nil,Nil) + Nil -> (Nothing,Nil,Nil) + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements of a map in an unspecified order. +-- +-- > sum map = fold (+) 0 map +-- > elems map = fold (:) [] map +fold :: (a -> b -> b) -> b -> IntMap a -> b +fold f z t + = foldWithKey (\k x y -> f x y) z t + +-- | /O(n)/. Fold over the elements of a map in an unspecified order. +-- +-- > keys map = foldWithKey (\k x ks -> k:ks) [] map +foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey f z t + = foldR f z t + +foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldR f z t + = case t of + Bin p m l r -> foldR f (foldR f z r) l + Tip k x -> f k x z + Nil -> z + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. Return all elements of the map. +elems :: IntMap a -> [a] +elems m + = foldWithKey (\k x xs -> x:xs) [] m + +-- | /O(n)/. Return all keys of the map. +keys :: IntMap a -> [Key] +keys m + = foldWithKey (\k x ks -> k:ks) [] m + +-- | /O(n)/. Return all key\/value pairs in the map. +assocs :: IntMap a -> [(Key,a)] +assocs m + = toList m + + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the map to a list of key\/value pairs. +toList :: IntMap a -> [(Key,a)] +toList t + = foldWithKey (\k x xs -> (k,x):xs) [] t + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the +-- keys are in ascending order. +toAscList :: IntMap a -> [(Key,a)] +toAscList t + = -- NOTE: the following algorithm only works for big-endian trees + let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +fromList :: [(Key,a)] -> IntMap a +fromList xs + = foldlStrict ins empty xs + where + ins t (k,x) = insert k x t + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWith f xs + = fromListWithKey (\k x y -> f x y) xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWithKey f xs + = foldlStrict ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +fromAscList :: [(Key,a)] -> IntMap a +fromAscList xs + = fromList xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromAscListWith f xs + = fromListWith f xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromAscListWithKey f xs + = fromListWithKey f xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +fromDistinctAscList :: [(Key,a)] -> IntMap a +fromDistinctAscList xs + = fromList xs + + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq a => Eq (IntMap a) where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Eq a => IntMap a -> IntMap a -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y) + = (kx == ky) && (x==y) +equal Nil Nil = True +equal t1 t2 = False + +nequal :: Eq a => IntMap a -> IntMap a -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y) + = (kx /= ky) || (x/=y) +nequal Nil Nil = False +nequal t1 t2 = True + +instance Show a => Show (IntMap a) where + showsPrec d t = showMap (toList t) + + +showMap :: (Show a) => [(Key,a)] -> ShowS +showMap [] + = showString "{}" +showMap (x:xs) + = showChar '{' . showElem x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . showElem x . showTail xs + + showElem (k,x) = shows k . showString ":=" . shows x + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the map. The tree is shown +-- in a compressed, hanging format. +showTree :: Show a => IntMap a -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the map. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. +-} +showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS +showsTree wide lbars rbars t + = case t of + Bin p m l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip k x + -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS +showsTreeHang wide bars t + = case t of + Bin p m l r + -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip k x + -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin p m + = "*" -- ++ show (p,m) + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a +bin p m l Nil = l +bin p m Nil r = r +bin p m l r = Bin p m l r + + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} +zero :: Key -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch,match :: Key -> Prefix -> Mask -> Bool +nomatch i p m + = (mask i m) /= p + +match i p m + = (mask i m) == p + +mask :: Key -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) + + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. (complement (m-1) `xor` m)) + +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{---------------------------------------------------------------------- + Finding the highest bit (mask) in a word [x] can be done efficiently in + three ways: + * convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + * use processor specific assembler instruction (asm). + + The most portable way would be [bit], but is it efficient enough? + I have measured the cycle counts of the different methods on an AMD + Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + + highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + + highestBit: method cycles + -------------- + frexp 195 + float 33 + bit 11 + asm 11 + + Wow, the bit twiddling is on today's RISC like machines even faster + than a single CISC instruction (BSR)! +----------------------------------------------------------------------} + +{---------------------------------------------------------------------- + [highestBitMask] returns a word where only the highest bit is set. + It is found by first setting all bits in lower positions than the + highest bit and than taking an exclusive or with the original value. + Allthough the function may look expensive, GHC compiles this into + excellent C code that subsequently compiled into highly efficient + machine code. The algorithm is derived from Jorg Arndt's FXT library. +----------------------------------------------------------------------} +highestBitMask :: Nat -> Nat +highestBitMask x + = case (x .|. shiftRL x 1) of + x -> case (x .|. shiftRL x 2) of + x -> case (x .|. shiftRL x 4) of + x -> case (x .|. shiftRL x 8) of + x -> case (x .|. shiftRL x 16) of + x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms + x -> (x `xor` (shiftRL x 1)) + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> IntMap Int +testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs] +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (IntMap a) where + arbitrary = do{ ks <- arbitrary + ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks + ; return (fromList xs) + } + + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Key -> Int -> Bool +prop_Single k x + = (insert k x empty == single k x) + +prop_InsertDelete :: Key -> Int -> IntMap Int -> Property +prop_InsertDelete k x t + = not (member k t) ==> delete k (insert k x t) == t + +prop_UpdateDelete :: Key -> IntMap Int -> Bool +prop_UpdateDelete k t + = update (const Nothing) k t == delete k t + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool +prop_UnionInsert k x t + = union (single k x) t == insert k x t + +prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: IntMap Int -> IntMap Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == unionWith (\x y -> y) t2 t1) + + +prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool +prop_Diff xs ys + = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) + +prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool +prop_Int xs ys + = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [(x,()) | x <- [0..n::Int]] + in fromAscList xs == fromList xs + +prop_List :: [Key] -> Bool +prop_List xs + = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])]) +-} diff --git a/lib/DData/IntSet.hs b/lib/DData/IntSet.hs new file mode 100644 --- /dev/null +++ b/lib/DData/IntSet.hs @@ -0,0 +1,852 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : IntSet + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of integer sets. + + 1) The 'filter' function clashes with the "Prelude". + If you want to use "IntSet" unqualified, this function should be hidden. + + > import Prelude hiding (filter) + > import IntSet + + Another solution is to use qualified names. + + > import qualified IntSet + > + > ... IntSet.fromList [1..5] + + Or, if you prefer a terse coding style: + + > import qualified IntSet as S + > + > ... S.fromList [1..5] + + 2) The implementation is based on /big-endian patricia trees/. This data structure + performs especially well on binary operations like 'union' and 'intersection'. However, + my benchmarks show that it is also (much) faster on insertions and deletions when + compared to a generic size-balanced set implementation (see "Set"). + + * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", + Workshop on ML, September 1998, pages 77--86, + + * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information + Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534. + + 3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements + with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-} +---------------------------------------------------------------------------------} +module IntSet ( + -- * Set type + IntSet -- instance Eq,Show + + -- * Operators + , (\\) + + -- * Query + , isEmpty + , size + , member + , subset + , properSubset + + -- * Construction + , empty + , single + , insert + , delete + + -- * Combine + , union, unions + , difference + , intersection + + -- * Filter + , filter + , partition + , split + , splitMember + + -- * Fold + , fold + + -- * Conversion + -- ** List + , elems + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- * Debugging + , showTree + , showTreeWith + ) where + + +import Prelude hiding (lookup,filter) +import Bits +import Int + +{- +-- just for testing +import QuickCheck +import List (nub,sort) +import qualified List +-} + + +#ifdef __GLASGOW_HASKELL__ +{-------------------------------------------------------------------- + GHC: use unboxing to get @shiftRL@ inlined. +--------------------------------------------------------------------} +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Word +import GHC.Exts ( Word(..), Int(..), shiftRL# ) +#else +import Word +import GlaExts ( Word(..), Int(..), shiftRL# ) +#endif + +infixl 9 \\ -- cpp nonsense + +type Nat = Word + +natFromInt :: Int -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Int +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Int -> Nat +shiftRL (W# x) (I# i) + = W# (shiftRL# x i) + +#elif __HUGS__ +{-------------------------------------------------------------------- + Hugs: + * raises errors on boundary values when using 'fromIntegral' + but not with the deprecated 'fromInt/toInt'. + * Older Hugs doesn't define 'Word'. + * Newer Hugs defines 'Word' in the Prelude but no operations. +--------------------------------------------------------------------} +import Word +infixl 9 \\ + +type Nat = Word32 -- illegal on 64-bit platforms! + +natFromInt :: Int -> Nat +natFromInt i = fromInt i + +intFromNat :: Nat -> Int +intFromNat w = toInt w + +shiftRL :: Nat -> Int -> Nat +shiftRL x i = shiftR x i + +#else +{-------------------------------------------------------------------- + 'Standard' Haskell + * A "Nat" is a natural machine word (an unsigned Int) +--------------------------------------------------------------------} +import Word +infixl 9 \\ + +type Nat = Word + +natFromInt :: Int -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Int +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Int -> Nat +shiftRL w i = shiftR w i + +#endif + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +-- | /O(n+m)/. See 'difference'. +(\\) :: IntSet -> IntSet -> IntSet +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} +-- | A set of integers. +data IntSet = Nil + | Tip !Int + | Bin !Prefix !Mask !IntSet !IntSet + +type Prefix = Int +type Mask = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the set empty? +isEmpty :: IntSet -> Bool +isEmpty Nil = True +isEmpty other = False + +-- | /O(n)/. Cardinality of the set. +size :: IntSet -> Int +size t + = case t of + Bin p m l r -> size l + size r + Tip y -> 1 + Nil -> 0 + +-- | /O(min(n,W))/. Is the value a member of the set? +member :: Int -> IntSet -> Bool +member x t + = case t of + Bin p m l r + | nomatch x p m -> False + | zero x m -> member x l + | otherwise -> member x r + Tip y -> (x==y) + Nil -> False + +-- 'lookup' is used by 'intersection' for left-biasing +lookup :: Int -> IntSet -> Maybe Int +lookup x t + = case t of + Bin p m l r + | nomatch x p m -> Nothing + | zero x m -> lookup x l + | otherwise -> lookup x r + Tip y + | (x==y) -> Just y + | otherwise -> Nothing + Nil -> Nothing + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: IntSet +empty + = Nil + +-- | /O(1)/. A set of one element. +single :: Int -> IntSet +single x + = Tip x + +{-------------------------------------------------------------------- + Insert +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Add a value to the set. When the value is already +-- an element of the set, it is replaced by the new one, ie. 'insert' +-- is left-biased. +insert :: Int -> IntSet -> IntSet +insert x t + = case t of + Bin p m l r + | nomatch x p m -> join x (Tip x) p t + | zero x m -> Bin p m (insert x l) r + | otherwise -> Bin p m l (insert x r) + Tip y + | x==y -> Tip x + | otherwise -> join x (Tip x) y t + Nil -> Tip x + +-- right-biased insertion, used by 'union' +insertR :: Int -> IntSet -> IntSet +insertR x t + = case t of + Bin p m l r + | nomatch x p m -> join x (Tip x) p t + | zero x m -> Bin p m (insert x l) r + | otherwise -> Bin p m l (insert x r) + Tip y + | x==y -> t + | otherwise -> join x (Tip x) y t + Nil -> Tip x + +-- | /O(min(n,W))/. Delete a value in the set. Returns the +-- original set when the value was not present. +delete :: Int -> IntSet -> IntSet +delete x t + = case t of + Bin p m l r + | nomatch x p m -> t + | zero x m -> bin p m (delete x l) r + | otherwise -> bin p m l (delete x r) + Tip y + | x==y -> Nil + | otherwise -> t + Nil -> Nil + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of sets. +unions :: [IntSet] -> IntSet +unions xs + = foldlStrict union empty xs + + +-- | /O(n+m)/. The union of two sets. +union :: IntSet -> IntSet -> IntSet +union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 + | otherwise = Bin p1 m1 l1 (union r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 + | otherwise = Bin p2 m2 l2 (union t1 r2) + +union (Tip x) t = insert x t +union t (Tip x) = insertR x t -- right bias +union Nil t = t +union t Nil = t + + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference between two sets. +difference :: IntSet -> IntSet -> IntSet +difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (difference l1 t2) r1 + | otherwise = bin p1 m1 l1 (difference r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = difference t1 l2 + | otherwise = difference t1 r2 + +difference t1@(Tip x) t2 + | member x t2 = Nil + | otherwise = t1 + +difference Nil t = Nil +difference t (Tip x) = delete x t +difference t Nil = t + + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. The intersection of two sets. +intersection :: IntSet -> IntSet -> IntSet +intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersection l1 t2 + | otherwise = intersection r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersection t1 l2 + | otherwise = intersection t1 r2 + +intersection t1@(Tip x) t2 + | member x t2 = t1 + | otherwise = Nil +intersection t (Tip x) + = case lookup x t of + Just y -> Tip y + Nothing -> Nil +intersection Nil t = Nil +intersection t Nil = Nil + + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +properSubset :: IntSet -> IntSet -> Bool +properSubset t1 t2 + = case subsetCmp t1 t2 of + LT -> True + ge -> False + +subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = subsetCmpLt + | p1 == p2 = subsetCmpEq + | otherwise = GT -- disjoint + where + subsetCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = subsetCmp t1 l2 + | otherwise = subsetCmp t1 r2 + subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + other -> LT + +subsetCmp (Bin p m l r) t = GT +subsetCmp (Tip x) (Tip y) + | x==y = EQ + | otherwise = GT -- disjoint +subsetCmp (Tip x) t + | member x t = LT + | otherwise = GT -- disjoint +subsetCmp Nil Nil = EQ +subsetCmp Nil t = LT + +-- | /O(n+m)/. Is this a subset? +subset :: IntSet -> IntSet -> Bool +subset t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subset t1 l2 + else subset t1 r2) + | otherwise = (p1==p2) && subset l1 l2 && subset r1 r2 +subset (Bin p m l r) t = False +subset (Tip x) t = member x t +subset Nil t = True + + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: (Int -> Bool) -> IntSet -> IntSet +filter pred t + = case t of + Bin p m l r + -> bin p m (filter pred l) (filter pred r) + Tip x + | pred x -> t + | otherwise -> Nil + Nil -> Nil + +-- | /O(n)/. partition the set according to some predicate. +partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet) +partition pred t + = case t of + Bin p m l r + -> let (l1,l2) = partition pred l + (r1,r2) = partition pred r + in (bin p m l1 r1, bin p m l2 r2) + Tip x + | pred x -> (t,Nil) + | otherwise -> (Nil,t) + Nil -> (Nil,Nil) + + +-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@ +-- where all elements in @set1@ are lower than @x@ and all elements in +-- @set2@ larger than @x@. +split :: Int -> IntSet -> (IntSet,IntSet) +split x t + = case t of + Bin p m l r + | zero x m -> let (lt,gt) = split x l in (lt,union gt r) + | otherwise -> let (lt,gt) = split x r in (union l lt,gt) + Tip y + | x>y -> (t,Nil) + | x (Nil,t) + | otherwise -> (Nil,Nil) + Nil -> (Nil,Nil) + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet) +splitMember x t + = case t of + Bin p m l r + | zero x m -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r) + | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt) + Tip y + | x>y -> (False,t,Nil) + | x (False,Nil,t) + | otherwise -> (True,Nil,Nil) + Nil -> (False,Nil,Nil) + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements of a set in an unspecified order. +-- +-- > sum set = fold (+) 0 set +-- > elems set = fold (:) [] set +fold :: (Int -> b -> b) -> b -> IntSet -> b +fold f z t + = foldR f z t + +foldR :: (Int -> b -> b) -> b -> IntSet -> b +foldR f z t + = case t of + Bin p m l r -> foldR f (foldR f z r) l + Tip x -> f x z + Nil -> z + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a set. +elems :: IntSet -> [Int] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the set to a list of elements. +toList :: IntSet -> [Int] +toList t + = fold (:) [] t + +-- | /O(n)/. Convert the set to an ascending list of elements. +toAscList :: IntSet -> [Int] +toAscList t + = -- NOTE: the following algorithm only works for big-endian trees + let (pos,neg) = span (>=0) (foldR (:) [] t) in neg ++ pos + +-- | /O(n*min(n,W))/. Create a set from a list of integers. +fromList :: [Int] -> IntSet +fromList xs + = foldlStrict ins empty xs + where + ins t x = insert x t + +-- | /O(n*min(n,W))/. Build a set from an ascending list of elements. +fromAscList :: [Int] -> IntSet +fromAscList xs + = fromList xs + +-- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements. +fromDistinctAscList :: [Int] -> IntSet +fromDistinctAscList xs + = fromList xs + + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq IntSet where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: IntSet -> IntSet -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip x) (Tip y) + = (x==y) +equal Nil Nil = True +equal t1 t2 = False + +nequal :: IntSet -> IntSet -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip x) (Tip y) + = (x/=y) +nequal Nil Nil = False +nequal t1 t2 = True + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show IntSet where + showsPrec d s = showSet (toList s) + +showSet :: [Int] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the set. The tree is shown +-- in a compressed, hanging format. +showTree :: IntSet -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the set. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. +-} +showTreeWith :: Bool -> Bool -> IntSet -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS +showsTree wide lbars rbars t + = case t of + Bin p m l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip x + -> showsBars lbars . showString " " . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Bool -> [String] -> IntSet -> ShowS +showsTreeHang wide bars t + = case t of + Bin p m l r + -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip x + -> showsBars bars . showString " " . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin p m + = "*" -- ++ show (p,m) + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet +bin p m l Nil = l +bin p m Nil r = r +bin p m l r = Bin p m l r + + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} +zero :: Int -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch,match :: Int -> Prefix -> Mask -> Bool +nomatch i p m + = (mask i m) /= p + +match i p m + = (mask i m) == p + +mask :: Int -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) + + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. (complement (m-1) `xor` m)) + +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{---------------------------------------------------------------------- + Finding the highest bit (mask) in a word [x] can be done efficiently in + three ways: + * convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + * use processor specific assembler instruction (asm). + + The most portable way would be [bit], but is it efficient enough? + I have measured the cycle counts of the different methods on an AMD + Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + + highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + + highestBit: method cycles + -------------- + frexp 195 + float 33 + bit 11 + asm 11 + + Wow, the bit twiddling is on today's RISC like machines even faster + than a single CISC instruction (BSR)! +----------------------------------------------------------------------} + +{---------------------------------------------------------------------- + [highestBitMask] returns a word where only the highest bit is set. + It is found by first setting all bits in lower positions than the + highest bit and than taking an exclusive or with the original value. + Allthough the function may look expensive, GHC compiles this into + excellent C code that subsequently compiled into highly efficient + machine code. The algorithm is derived from Jorg Arndt's FXT library. +----------------------------------------------------------------------} +highestBitMask :: Nat -> Nat +highestBitMask x + = case (x .|. shiftRL x 1) of + x -> case (x .|. shiftRL x 2) of + x -> case (x .|. shiftRL x 4) of + x -> case (x .|. shiftRL x 8) of + x -> case (x .|. shiftRL x 16) of + x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms + x -> (x `xor` (shiftRL x 1)) + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> IntSet +testTree xs = fromList xs +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance Arbitrary IntSet where + arbitrary = do{ xs <- arbitrary + ; return (fromList xs) + } + + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Bool +prop_Single x + = (insert x empty == single x) + +prop_InsertDelete :: Int -> IntSet -> Property +prop_InsertDelete k t + = not (member k t) ==> delete k (insert k t) == t + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionInsert :: Int -> IntSet -> Bool +prop_UnionInsert x t + = union t (single x) == insert x t + +prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: IntSet -> IntSet -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == union t2 t1) + +prop_Diff :: [Int] -> [Int] -> Bool +prop_Diff xs ys + = toAscList (difference (fromList xs) (fromList ys)) + == List.sort ((List.\\) (nub xs) (nub ys)) + +prop_Int :: [Int] -> [Int] -> Bool +prop_Int xs ys + = toAscList (intersection (fromList xs) (fromList ys)) + == List.sort (nub ((List.intersect) (xs) (ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [0..n::Int] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == toAscList (fromList xs)) +-} diff --git a/lib/DData/Map.hs b/lib/DData/Map.hs new file mode 100644 --- /dev/null +++ b/lib/DData/Map.hs @@ -0,0 +1,1544 @@ +-------------------------------------------------------------------------------- +{-| Module : Map + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of maps from keys to values (dictionaries). + + 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. + If you want to use "Map" unqualified, these functions should be hidden. + + > import Prelude hiding (lookup,map,filter) + > import Map + + Another solution is to use qualified names. This is also the only way how + a "Map", "Set", and "MultiSet" can be used within one module. + + > import qualified Map + > + > ... Map.single "Paris" "France" + + Or, if you prefer a terse coding style: + + > import qualified Map as M + > + > ... M.single "Berlin" "Germany" + + 2) The implementation of "Map" is based on /size balanced/ binary trees (or + trees of /bounded balance/) as described by: + + * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional + Programming 3(4):553-562, October 1993, . + + * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\", + SIAM journal of computing 2(1), March 1973. + + 3) Another implementation of finite maps based on size balanced trees + exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library + is that it is highly tuned and thorougly tested. However, it is also fairly old, + uses @#ifdef@'s all over the place and only supports the basic finite map operations. + The "Map" module overcomes some of these issues: + + * It tries to export a more complete and consistent set of operations, like + 'partition', 'adjust', 'mapAccum', 'elemAt' etc. + + * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' + (a /hedge/ algorithm is not applicable to 'intersection'). + + * It converts ordered lists in linear time ('fromAscList'). + + * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'. + + * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic. +-} +---------------------------------------------------------------------------------- +module Map ( + -- * Map type + Map -- instance Eq,Show + + -- * Operators + , (!), (\\) + + -- * Query + , isEmpty + , size + , member + , lookup + , find + , findWithDefault + + -- * Construction + , empty + , single + + -- ** Insertion + , insert + , insertWith, insertWithKey, insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + + -- ** Fold + , fold + , foldWithKey + + -- * Conversion + , elems + , keys + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , split + , splitLookup + + -- * Subset + , subset, subsetBy + , properSubset, properSubsetBy + + -- * Indexed + , lookupIndex + , findIndex + , elemAt + , updateAt + , deleteAt + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + + -- * Debugging + , showTree + , showTreeWith + , valid + ) where + +import Prelude hiding (lookup,map,filter) + + +{- +-- for quick check +import qualified Prelude +import qualified List +import Debug.QuickCheck +import List(nub,sort) +-} + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 !,\\ + +-- | /O(log n)/. See 'find'. +(!) :: Ord k => Map k a -> k -> a +m ! k = find k m + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord k => Map k a -> Map k a -> Map k a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Size balanced trees. +--------------------------------------------------------------------} +-- | A Map from keys @k@ and values @a@. +data Map k a = Tip + | Bin !Size !k a !(Map k a) !(Map k a) + +type Size = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the map empty? +isEmpty :: Map k a -> Bool +isEmpty t + = case t of + Tip -> True + Bin sz k x l r -> False + +-- | /O(1)/. The number of elements in the map. +size :: Map k a -> Int +size t + = case t of + Tip -> 0 + Bin sz k x l r -> sz + + +-- | /O(log n)/. Lookup the value of key in the map. +lookup :: Ord k => k -> Map k a -> Maybe a +lookup k t + = case t of + Tip -> Nothing + Bin sz kx x l r + -> case compare k kx of + LT -> lookup k l + GT -> lookup k r + EQ -> Just x + +-- | /O(log n)/. Is the key a member of the map? +member :: Ord k => k -> Map k a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just x -> True + +-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found. +find :: Ord k => k -> Map k a -> a +find k m + = case lookup k m of + Nothing -> error "Map.find: element not in the map" + Just x -> x + +-- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when +-- the key is not in the map. +findWithDefault :: Ord k => a -> k -> Map k a -> a +findWithDefault def k m + = case lookup k m of + Nothing -> def + Just x -> x + + + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty map. +empty :: Map k a +empty + = Tip + +-- | /O(1)/. Create a map with a single element. +single :: k -> a -> Map k a +single k x + = Bin 1 k x Tip Tip + +{-------------------------------------------------------------------- + Insertion + [insert] is the inlined version of [insertWith (\k x y -> x)] +--------------------------------------------------------------------} +-- | /O(log n)/. Insert a new key and value in the map. +insert :: Ord k => k -> a -> Map k a -> Map k a +insert kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> case compare kx ky of + LT -> balance ky y (insert kx x l) r + GT -> balance ky y l (insert kx x r) + EQ -> Bin sz kx x l r + +-- | /O(log n)/. Insert with a combining function. +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith f k x m + = insertWithKey (\k x y -> f x y) k x m + +-- | /O(log n)/. Insert with a combining function. +insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWithKey f kx x t + = case t of + Tip -> single kx x + Bin sy ky y l r + -> case compare kx ky of + LT -> balance ky y (insertWithKey f kx x l) r + GT -> balance ky y l (insertWithKey f kx x r) + EQ -> Bin sy ky (f ky x y) l r + +-- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where +-- the first element is equal to (@lookup k map@) and the second element +-- equal to (@insertWithKey f k x map@). +insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a) +insertLookupWithKey f kx x t + = case t of + Tip -> (Nothing, single kx x) + Bin sy ky y l r + -> case compare kx ky of + LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r) + GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r') + EQ -> (Just y, Bin sy ky (f ky x y) l r) + +{-------------------------------------------------------------------- + Deletion + [delete] is the inlined version of [deleteWith (\k x -> Nothing)] +--------------------------------------------------------------------} +-- | /O(log n)/. Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: Ord k => k -> Map k a -> Map k a +delete k t + = case t of + Tip -> Tip + Bin sx kx x l r + -> case compare k kx of + LT -> balance kx x (delete k l) r + GT -> balance kx x l (delete k r) + EQ -> glue l r + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a +adjust f k m + = adjustWithKey (\k x -> f x) k m + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a +adjustWithKey f k m + = updateWithKey (\k x -> Just (f k x)) k m + +-- | /O(log n)/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a +update f k m + = updateWithKey (\k x -> f x) k m + +-- | /O(log n)/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a +updateWithKey f k t + = case t of + Tip -> Tip + Bin sx kx x l r + -> case compare k kx of + LT -> balance kx x (updateWithKey f k l) r + GT -> balance kx x l (updateWithKey f k r) + EQ -> case f kx x of + Just x' -> Bin sx kx x' l r + Nothing -> glue l r + +-- | /O(log n)/. Lookup and update. +updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) +updateLookupWithKey f k t + = case t of + Tip -> (Nothing,Tip) + Bin sx kx x l r + -> case compare k kx of + LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r) + GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') + EQ -> case f kx x of + Just x' -> (Just x',Bin sx kx x' l r) + Nothing -> (Just x,glue l r) + +{-------------------------------------------------------------------- + Indexing +--------------------------------------------------------------------} +-- | /O(log n)/. Return the /index/ of a key. The index is a number from +-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when +-- the key is not a 'member' of the map. +findIndex :: Ord k => k -> Map k a -> Int +findIndex k t + = case lookupIndex k t of + Nothing -> error "Map.findIndex: element is not in the map" + Just idx -> idx + +-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from +-- /0/ up to, but not including, the 'size' of the map. +lookupIndex :: Ord k => k -> Map k a -> Maybe Int +lookupIndex k t + = lookup 0 t + where + lookup idx Tip = Nothing + lookup idx (Bin _ kx x l r) + = case compare k kx of + LT -> lookup idx l + GT -> lookup (idx + size l + 1) r + EQ -> Just (idx + size l) + +-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an +-- invalid index is used. +elemAt :: Int -> Map k a -> (k,a) +elemAt i Tip = error "Map.elemAt: index out of range" +elemAt i (Bin _ kx x l r) + = case compare i sizeL of + LT -> elemAt i l + GT -> elemAt (i-sizeL-1) r + EQ -> (kx,x) + where + sizeL = size l + +-- | /O(log n)/. Update the element at /index/. Calls 'error' when an +-- invalid index is used. +updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a +updateAt f i Tip = error "Map.updateAt: index out of range" +updateAt f i (Bin sx kx x l r) + = case compare i sizeL of + LT -> updateAt f i l + GT -> updateAt f (i-sizeL-1) r + EQ -> case f kx x of + Just x' -> Bin sx kx x' l r + Nothing -> glue l r + where + sizeL = size l + +-- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@). +deleteAt :: Int -> Map k a -> Map k a +deleteAt i map + = updateAt (\k x -> Nothing) i map + + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal key of the map. +findMin :: Map k a -> (k,a) +findMin (Bin _ kx x Tip r) = (kx,x) +findMin (Bin _ kx x l r) = findMin l +findMin Tip = error "Map.findMin: empty tree has no minimal element" + +-- | /O(log n)/. The maximal key of the map. +findMax :: Map k a -> (k,a) +findMax (Bin _ kx x l Tip) = (kx,x) +findMax (Bin _ kx x l r) = findMax r +findMax Tip = error "Map.findMax: empty tree has no maximal element" + +-- | /O(log n)/. Delete the minimal key +deleteMin :: Map k a -> Map k a +deleteMin (Bin _ kx x Tip r) = r +deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r +deleteMin Tip = Tip + +-- | /O(log n)/. Delete the maximal key +deleteMax :: Map k a -> Map k a +deleteMax (Bin _ kx x l Tip) = l +deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r) +deleteMax Tip = Tip + +-- | /O(log n)/. Update the minimal key +updateMin :: (a -> Maybe a) -> Map k a -> Map k a +updateMin f m + = updateMinWithKey (\k x -> f x) m + +-- | /O(log n)/. Update the maximal key +updateMax :: (a -> Maybe a) -> Map k a -> Map k a +updateMax f m + = updateMaxWithKey (\k x -> f x) m + + +-- | /O(log n)/. Update the minimal key +updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a +updateMinWithKey f t + = case t of + Bin sx kx x Tip r -> case f kx x of + Nothing -> r + Just x' -> Bin sx kx x' Tip r + Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r + Tip -> Tip + +-- | /O(log n)/. Update the maximal key +updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a +updateMaxWithKey f t + = case t of + Bin sx kx x l Tip -> case f kx x of + Nothing -> l + Just x' -> Bin sx kx x' l Tip + Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r) + Tip -> Tip + + +{-------------------------------------------------------------------- + Union. +--------------------------------------------------------------------} +-- | The union of a list of maps: (@unions == foldl union empty@). +unions :: Ord k => [Map k a] -> Map k a +unions ts + = foldlStrict union empty ts + +-- | /O(n+m)/. +-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@). +-- The implementation uses the efficient /hedge-union/ algorithm. +union :: Ord k => Map k a -> Map k a -> Map k a +union Tip t2 = t2 +union t1 Tip = t1 +union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) + | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2 + | otherwise = hedgeUnionR (const LT) (const GT) t2 t1 + +-- left-biased hedge union +hedgeUnionL cmplo cmphi t1 Tip + = t1 +hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2 + = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) + (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2)) + where + cmpkx k = compare kx k + +-- right-biased hedge union +hedgeUnionR cmplo cmphi t1 Tip + = t1 +hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2 + = join kx newx (hedgeUnionR cmplo cmpkx l lt) + (hedgeUnionR cmpkx cmphi r gt) + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t2 + (found,gt) = trimLookupLo kx cmphi t2 + newx = case found of + Nothing -> x + Just y -> y + +{-------------------------------------------------------------------- + Union with a combining function +--------------------------------------------------------------------} +-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. +unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWith f m1 m2 + = unionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. +-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. +unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWithKey f Tip t2 = t2 +unionWithKey f t1 Tip = t1 +unionWithKey f t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) + | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2 + | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1 + where + flipf k x y = f k y x + +hedgeUnionWithKey f cmplo cmphi t1 Tip + = t1 +hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2 + = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) + (hedgeUnionWithKey f cmpkx cmphi r gt) + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t2 + (found,gt) = trimLookupLo kx cmphi t2 + newx = case found of + Nothing -> x + Just y -> f kx x y + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference of two maps. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +difference :: Ord k => Map k a -> Map k a -> Map k a +difference Tip t2 = Tip +difference t1 Tip = t1 +difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2 + +hedgeDiff cmplo cmphi Tip t + = Tip +hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeDiff cmplo cmphi t (Bin _ kx x l r) + = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) + (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r) + where + cmpkx k = compare kx k + +-- | /O(n+m)/. Difference with a combining function. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +differenceWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a +differenceWith f m1 m2 + = differenceWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns @Nothing@, the element is discarded (proper set difference). If +-- it returns (@Just y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +differenceWithKey :: Ord k => (k -> a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a +differenceWithKey f Tip t2 = Tip +differenceWithKey f t1 Tip = t1 +differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2 + +hedgeDiffWithKey f cmplo cmphi Tip t + = Tip +hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) + = case found of + Nothing -> merge tl tr + Just y -> case f kx y x of + Nothing -> merge tl tr + Just z -> join kx z tl tr + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t + (found,gt) = trimLookupLo kx cmphi t + tl = hedgeDiffWithKey f cmplo cmpkx lt l + tr = hedgeDiffWithKey f cmpkx cmphi gt r + + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. Intersection of two maps. The values in the first +-- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@). +intersection :: Ord k => Map k a -> Map k a -> Map k a +intersection m1 m2 + = intersectionWithKey (\k x y -> x) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +intersectionWith f m1 m2 + = intersectionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a +intersectionWithKey f Tip t = Tip +intersectionWithKey f t Tip = Tip +intersectionWithKey f t1 t2 -- intersection is more efficient on (bigset `intersection` smallset) + | size t1 >= size t2 = intersectWithKey f t1 t2 + | otherwise = intersectWithKey flipf t2 t1 + where + flipf k x y = f k y x + +intersectWithKey f Tip t = Tip +intersectWithKey f t Tip = Tip +intersectWithKey f t (Bin _ kx x l r) + = case found of + Nothing -> merge tl tr + Just y -> join kx (f kx y x) tl tr + where + (found,lt,gt) = splitLookup kx t + tl = intersectWithKey f lt l + tr = intersectWithKey f gt r + + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. +-- This function is defined as (@subset = subsetBy (==)@). +subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool +subset m1 m2 + = subsetBy (==) m1 m2 + +{- | /O(n+m)/. + The expression (@subsetBy f t1 t2@) returns @True@ if + all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) + + But the following are all @False@: + + > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) + > subsetBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) +-} +subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool +subsetBy f t1 t2 + = (size t1 <= size t2) && (subset' f t1 t2) + +subset' f Tip t = True +subset' f t Tip = False +subset' f (Bin _ kx x l r) t + = case found of + Nothing -> False + Just y -> f x y && subset' f l lt && subset' f r gt + where + (found,lt,gt) = splitLookup kx t + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@). +properSubset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool +properSubset m1 m2 + = properSubsetBy (==) m1 m2 + +{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). + The expression (@properSubsetBy f m1 m2@) returns @True@ when + @m1@ and @m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) + > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +properSubsetBy :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool +properSubsetBy f t1 t2 + = (size t1 < size t2) && (subset' f t1 t2) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> Map k a -> Map k a +filter p m + = filterWithKey (\k x -> p x) m + +-- | /O(n)/. Filter all keys\values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a +filterWithKey p Tip = Tip +filterWithKey p (Bin _ kx x l r) + | p kx x = join kx x (filterWithKey p l) (filterWithKey p r) + | otherwise = merge (filterWithKey p l) (filterWithKey p r) + + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a) +partition p m + = partitionWithKey (\k x -> p x) m + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a) +partitionWithKey p Tip = (Tip,Tip) +partitionWithKey p (Bin _ kx x l r) + | p kx x = (join kx x l1 r1,merge l2 r2) + | otherwise = (merge l1 r1,join kx x l2 r2) + where + (l1,l2) = partitionWithKey p l + (r1,r2) = partitionWithKey p r + + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> Map k a -> Map k b +map f m + = mapWithKey (\k x -> f x) m + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey f Tip = Tip +mapWithKey f (Bin sx kx x l r) + = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) + +-- | /O(n)/. The function @mapAccum@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccum f a m + = mapAccumWithKey (\a k x -> f a x) a m + +-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating +-- argument through the map in unspecified order. (= ascending pre-order) +mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | /O(n)/. The function @mapAccumL@ threads an accumulating +-- argument throught the map in (ascending) pre-order. +mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumL f a t + = case t of + Tip -> (a,Tip) + Bin sx kx x l r + -> let (a1,l') = mapAccumL f a l + (a2,x') = f a1 kx x + (a3,r') = mapAccumL f a2 r + in (a3,Bin sx kx x' l' r') + +-- | /O(n)/. The function @mapAccumR@ threads an accumulating +-- argument throught the map in (descending) post-order. +mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumR f a t + = case t of + Tip -> (a,Tip) + Bin sx kx x l r + -> let (a1,r') = mapAccumR f a r + (a2,x') = f a1 kx x + (a3,l') = mapAccumR f a2 l + in (a3,Bin sx kx x' l' r') + +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} +-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order). +fold :: (a -> b -> b) -> b -> Map k a -> b +fold f z m + = foldWithKey (\k x z -> f x z) z m + +-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order). +foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b +foldWithKey f z t + = foldR f z t + +-- | /O(n)/. In-order fold. +foldI :: (k -> a -> b -> b -> b) -> b -> Map k a -> b +foldI f z Tip = z +foldI f z (Bin _ kx x l r) = f kx x (foldI f z l) (foldI f z r) + +-- | /O(n)/. Post-order fold. +foldR :: (k -> a -> b -> b) -> b -> Map k a -> b +foldR f z Tip = z +foldR f z (Bin _ kx x l r) = foldR f (f kx x (foldR f z r)) l + +-- | /O(n)/. Pre-order fold. +foldL :: (b -> k -> a -> b) -> b -> Map k a -> b +foldL f z Tip = z +foldL f z (Bin _ kx x l r) = foldL f (f (foldL f z l) kx x) r + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. Return all elements of the map. +elems :: Map k a -> [a] +elems m + = [x | (k,x) <- assocs m] + +-- | /O(n)/. Return all keys of the map. +keys :: Map k a -> [k] +keys m + = [k | (k,x) <- assocs m] + +-- | /O(n)/. Return all key\/value pairs in the map. +assocs :: Map k a -> [(k,a)] +assocs m + = toList m + +{-------------------------------------------------------------------- + Lists + use [foldlStrict] to reduce demand on the control-stack +--------------------------------------------------------------------} +-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +fromList :: Ord k => [(k,a)] -> Map k a +fromList xs + = foldlStrict ins empty xs + where + ins t (k,x) = insert k x t + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith f xs + = fromListWithKey (\k x y -> f x y) xs + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. +fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromListWithKey f xs + = foldlStrict ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n)/. Convert to a list of key\/value pairs. +toList :: Map k a -> [(k,a)] +toList t = toAscList t + +-- | /O(n)/. Convert to an ascending list. +toAscList :: Map k a -> [(k,a)] +toAscList t = foldR (\k x xs -> (k,x):xs) [] t + +-- | /O(n)/. +toDescList :: Map k a -> [(k,a)] +toDescList t = foldL (\xs k x -> (k,x):xs) [] t + + +{-------------------------------------------------------------------- + Building trees from ascending/descending lists can be done in linear time. + + Note that if [xs] is ascending that: + fromAscList xs == fromList xs + fromAscListWith f xs == fromListWith f xs +--------------------------------------------------------------------} +-- | /O(n)/. Build a map from an ascending list in linear time. +fromAscList :: Eq k => [(k,a)] -> Map k a +fromAscList xs + = fromAscListWithKey (\k x y -> x) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWith f xs + = fromAscListWithKey (\k x y -> f x y) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys +fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWithKey f xs + = fromDistinctAscList (combineEq f xs) + where + -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] + combineEq f xs + = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> combineEq' x xx + + combineEq' z [] = [z] + combineEq' z@(kz,zz) (x@(kx,xx):xs) + | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs + | otherwise = z:combineEq' x xs + + +-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [(k,a)] -> Map k a +fromDistinctAscList xs + = build const (length xs) xs + where + -- 1) use continutations so that we use heap space instead of stack space. + -- 2) special case for n==5 to build bushier trees. + build c 0 xs = c Tip xs + build c 5 xs = case xs of + ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) + -> c (bin k4 x4 (bin k2 x2 (single k1 x1) (single k3 x3)) (single k5 x5)) xx + build c n xs = seq nr $ build (buildR nr c) nl xs + where + nl = n `div` 2 + nr = n - nl - 1 + + buildR n c l ((k,x):ys) = build (buildB l k x c) n ys + buildB l k x c r zs = c (bin k x l r) zs + + + +{-------------------------------------------------------------------- + Utility functions that return sub-ranges of the original + tree. Some functions take a comparison function as argument to + allow comparisons against infinite values. A function [cmplo k] + should be read as [compare lo k]. + + [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT] + and [cmphi k == GT] for the key [k] of the root. + [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT] + [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT] + + [split k t] Returns two trees [l] and [r] where all keys + in [l] are <[k] and all keys in [r] are >[k]. + [splitLookup k t] Just like [split] but also returns whether [k] + was found in the tree. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + [trim lo hi t] trims away all subtrees that surely contain no + values between the range [lo] to [hi]. The returned tree is either + empty or the key of the root is between @lo@ and @hi@. +--------------------------------------------------------------------} +trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a +trim cmplo cmphi Tip = Tip +trim cmplo cmphi t@(Bin sx kx x l r) + = case cmplo kx of + LT -> case cmphi kx of + GT -> t + le -> trim cmplo cmphi l + ge -> trim cmplo cmphi r + +trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a) +trimLookupLo lo cmphi Tip = (Nothing,Tip) +trimLookupLo lo cmphi t@(Bin sx kx x l r) + = case compare lo kx of + LT -> case cmphi kx of + GT -> (lookup lo t, t) + le -> trimLookupLo lo cmphi l + GT -> trimLookupLo lo cmphi r + EQ -> (Just x,trim (compare lo) cmphi r) + + +{-------------------------------------------------------------------- + [filterGt k t] filter all keys >[k] from tree [t] + [filterLt k t] filter all keys <[k] from tree [t] +--------------------------------------------------------------------} +filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a +filterGt cmp Tip = Tip +filterGt cmp (Bin sx kx x l r) + = case cmp kx of + LT -> join kx x (filterGt cmp l) r + GT -> filterGt cmp r + EQ -> r + +filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a +filterLt cmp Tip = Tip +filterLt cmp (Bin sx kx x l r) + = case cmp kx of + LT -> filterLt cmp l + GT -> join kx x l (filterLt cmp r) + EQ -> l + +{-------------------------------------------------------------------- + Split +--------------------------------------------------------------------} +-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where +-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. +split :: Ord k => k -> Map k a -> (Map k a,Map k a) +split k Tip = (Tip,Tip) +split k (Bin sx kx x l r) + = case compare k kx of + LT -> let (lt,gt) = split k l in (lt,join kx x gt r) + GT -> let (lt,gt) = split k r in (join kx x l lt,gt) + EQ -> (l,r) + +-- | /O(log n)/. The expression (@splitLookup k map@) splits a map just +-- like 'split' but also returns @lookup k map@. +splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a) +splitLookup k Tip = (Nothing,Tip,Tip) +splitLookup k (Bin sx kx x l r) + = case compare k kx of + LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r) + GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt) + EQ -> (Just x,l,r) + +{-------------------------------------------------------------------- + Utility functions that maintain the balance properties of the tree. + All constructors assume that all values in [l] < [k] and all values + in [r] > [k], and that [l] and [r] are valid trees. + + In order of sophistication: + [Bin sz k x l r] The type constructor. + [bin k x l r] Maintains the correct size, assumes that both [l] + and [r] are balanced with respect to each other. + [balance k x l r] Restores the balance and size. + Assumes that the original tree was balanced and + that [l] or [r] has changed by at most one element. + [join k x l r] Restores balance and size. + + Furthermore, we can construct a new tree from two trees. Both operations + assume that all values in [l] < all values in [r] and that [l] and [r] + are valid: + [glue l r] Glues [l] and [r] together. Assumes that [l] and + [r] are already balanced with respect to each other. + [merge l r] Merges two trees and restores balance. + + Note: in contrast to Adam's paper, we use (<=) comparisons instead + of (<) comparisons in [join], [merge] and [balance]. + Quickcheck (on [difference]) showed that this was necessary in order + to maintain the invariants. It is quite unsatisfactory that I haven't + been able to find out why this is actually the case! Fortunately, it + doesn't hurt to be a bit more conservative. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a +join kx x Tip r = insertMin kx x r +join kx x l Tip = insertMax kx x l +join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) + | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz + | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r) + | otherwise = bin kx x l r + + +-- insertMin and insertMax don't perform potentially expensive comparisons. +insertMax,insertMin :: k -> a -> Map k a -> Map k a +insertMax kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> balance ky y l (insertMax kx x r) + +insertMin kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> balance ky y (insertMin kx x l) r + +{-------------------------------------------------------------------- + [merge l r]: merges two trees. +--------------------------------------------------------------------} +merge :: Map k a -> Map k a -> Map k a +merge Tip r = r +merge l Tip = l +merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry) + | delta*sizeL <= sizeR = balance ky y (merge l ly) ry + | delta*sizeR <= sizeL = balance kx x lx (merge rx r) + | otherwise = glue l r + +{-------------------------------------------------------------------- + [glue l r]: glues two trees together. + Assumes that [l] and [r] are already balanced with respect to each other. +--------------------------------------------------------------------} +glue :: Map k a -> Map k a -> Map k a +glue Tip r = r +glue l Tip = l +glue l r + | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r + | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r' + + +-- | /O(log n)/. Delete and find the minimal element. +deleteFindMin :: Map k a -> ((k,a),Map k a) +deleteFindMin t + = case t of + Bin _ k x Tip r -> ((k,x),r) + Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r) + Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) + +-- | /O(log n)/. Delete and find the maximal element. +deleteFindMax :: Map k a -> ((k,a),Map k a) +deleteFindMax t + = case t of + Bin _ k x l Tip -> ((k,x),l) + Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r') + Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip) + + +{-------------------------------------------------------------------- + [balance l x r] balances two trees with value x. + The sizes of the trees should balance after decreasing the + size of one of them. (a rotation). + + [delta] is the maximal relative difference between the sizes of + two trees, it corresponds with the [w] in Adams' paper. + [ratio] is the ratio between an outer and inner sibling of the + heavier subtree in an unbalanced setting. It determines + whether a double or single rotation should be performed + to restore balance. It is correspondes with the inverse + of $\alpha$ in Adam's article. + + Note that: + - [delta] should be larger than 4.646 with a [ratio] of 2. + - [delta] should be larger than 3.745 with a [ratio] of 1.534. + + - A lower [delta] leads to a more 'perfectly' balanced tree. + - A higher [delta] performs less rebalancing. + + - Balancing is automaic for random data and a balancing + scheme is only necessary to avoid pathological worst cases. + Almost any choice will do, and in practice, a rather large + [delta] may perform better than smaller one. + + Note: in contrast to Adam's paper, we use a ratio of (at least) [2] + to decide whether a single or double rotation is needed. Allthough + he actually proves that this ratio is needed to maintain the + invariants, his implementation uses an invalid ratio of [1]. +--------------------------------------------------------------------} +delta,ratio :: Int +delta = 5 +ratio = 2 + +balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r + | sizeL + sizeR <= 1 = Bin sizeX k x l r + | sizeR >= delta*sizeL = rotateL k x l r + | sizeL >= delta*sizeR = rotateR k x l r + | otherwise = Bin sizeX k x l r + where + sizeL = size l + sizeR = size r + sizeX = sizeL + sizeR + 1 + +-- rotate +rotateL k x l r@(Bin _ _ _ ly ry) + | size ly < ratio*size ry = singleL k x l r + | otherwise = doubleL k x l r + +rotateR k x l@(Bin _ _ _ ly ry) r + | size ry < ratio*size ly = singleR k x l r + | otherwise = doubleR k x l r + +-- basic rotations +singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 +singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) + +doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) +doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) + + +{-------------------------------------------------------------------- + The bin constructor maintains the size of the tree +--------------------------------------------------------------------} +bin :: k -> a -> Map k a -> Map k a -> Map k a +bin k x l r + = Bin (size l + size r + 1) k x l r + + +{-------------------------------------------------------------------- + Eq converts the tree to a list. In a lazy setting, this + actually seems one of the faster methods to compare two trees + and it is certainly the simplest :-) +--------------------------------------------------------------------} +instance (Eq k,Eq a) => Eq (Map k a) where + t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) + +{-------------------------------------------------------------------- + Functor +--------------------------------------------------------------------} +instance Functor (Map k) where + fmap f m = map f m + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance (Show k, Show a) => Show (Map k a) where + showsPrec d m = showMap (toAscList m) + +showMap :: (Show k,Show a) => [(k,a)] -> ShowS +showMap [] + = showString "{}" +showMap (x:xs) + = showChar '{' . showElem x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . showElem x . showTail xs + + showElem (k,x) = shows k . showString ":=" . shows x + + +-- | /O(n)/. Show the tree that implements the map. The tree is shown +-- in a compressed, hanging format. +showTree :: (Show k,Show a) => Map k a -> String +showTree m + = showTreeWith showElem True False m + where + showElem k x = show k ++ ":=" ++ show x + + +{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows + the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. + +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]] +> (4,()) +> +--(2,()) +> | +--(1,()) +> | +--(3,()) +> +--(5,()) +> +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]] +> (4,()) +> | +> +--(2,()) +> | | +> | +--(1,()) +> | | +> | +--(3,()) +> | +> +--(5,()) +> +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]] +> +--(5,()) +> | +> (4,()) +> | +> | +--(3,()) +> | | +> +--(2,()) +> | +> +--(1,()) + +-} +showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String +showTreeWith showelem hang wide t + | hang = (showsTreeHang showelem wide [] t) "" + | otherwise = (showsTree showelem wide [] [] t) "" + +showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS +showsTree showelem wide lbars rbars t + = case t of + Tip -> showsBars lbars . showString "|\n" + Bin sz kx x Tip Tip + -> showsBars lbars . showString (showelem kx x) . showString "\n" + Bin sz kx x l r + -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showelem kx x) . showString "\n" . + showWide wide lbars . + showsTree showelem wide (withEmpty lbars) (withBar lbars) l + +showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS +showsTreeHang showelem wide bars t + = case t of + Tip -> showsBars bars . showString "|\n" + Bin sz kx x Tip Tip + -> showsBars bars . showString (showelem kx x) . showString "\n" + Bin sz kx x l r + -> showsBars bars . showString (showelem kx x) . showString "\n" . + showWide wide bars . + showsTreeHang showelem wide (withBar bars) l . + showWide wide bars . + showsTreeHang showelem wide (withEmpty bars) r + + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Assertions +--------------------------------------------------------------------} +-- | /O(n)/. Test if the internal map structure is valid. +valid :: Ord k => Map k a -> Bool +valid t + = balanced t && ordered t && validsize t + +ordered t + = bounded (const True) (const True) t + where + bounded lo hi t + = case t of + Tip -> True + Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r + +-- | Exported only for "Debug.QuickCheck" +balanced :: Map k a -> Bool +balanced t + = case t of + Tip -> True + Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && + balanced l && balanced r + + +validsize t + = (realsize t == Just (size t)) + where + realsize t + = case t of + Tip -> Just 0 + Bin sz kx x l r -> case (realsize l,realsize r) of + (Just n,Just m) | n+m+1 == sz -> Just sz + other -> Nothing + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree xs = fromList [(x,"*") | x <- xs] +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where + arbitrary = sized (arbtree 0 maxkey) + where maxkey = 10000 + +arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a) +arbtree lo hi n + | n <= 0 = return Tip + | lo >= hi = return Tip + | otherwise = do{ x <- arbitrary + ; i <- choose (lo,hi) + ; m <- choose (1,30) + ; let (ml,mr) | m==(1::Int)= (1,2) + | m==2 = (2,1) + | m==3 = (1,1) + | otherwise = (2,2) + ; l <- arbtree lo (i-1) (n `div` ml) + ; r <- arbtree (i+1) hi (n `div` mr) + ; return (bin (toEnum i) x l r) + } + + +{-------------------------------------------------------------------- + Valid tree's +--------------------------------------------------------------------} +forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property +forValid f + = forAll arbitrary $ \t -> +-- classify (balanced t) "balanced" $ + classify (size t == 0) "empty" $ + classify (size t > 0 && size t <= 10) "small" $ + classify (size t > 10 && size t <= 64) "medium" $ + classify (size t > 64) "large" $ + balanced t ==> f t + +forValidIntTree :: Testable a => (Map Int Int -> a) -> Property +forValidIntTree f + = forValid f + +forValidUnitTree :: Testable a => (Map Int () -> a) -> Property +forValidUnitTree f + = forValid f + + +prop_Valid + = forValidUnitTree $ \t -> valid t + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Int -> Bool +prop_Single k x + = (insert k x empty == single k x) + +prop_InsertValid :: Int -> Property +prop_InsertValid k + = forValidUnitTree $ \t -> valid (insert k () t) + +prop_InsertDelete :: Int -> Map Int () -> Property +prop_InsertDelete k t + = (lookup k t == Nothing) ==> delete k (insert k () t) == t + +prop_DeleteValid :: Int -> Property +prop_DeleteValid k + = forValidUnitTree $ \t -> + valid (delete k (insert k () t)) + +{-------------------------------------------------------------------- + Balance +--------------------------------------------------------------------} +prop_Join :: Int -> Property +prop_Join k + = forValidUnitTree $ \t -> + let (l,r) = split k t + in valid (join k () l r) + +prop_Merge :: Int -> Property +prop_Merge k + = forValidUnitTree $ \t -> + let (l,r) = split k t + in valid (merge l r) + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionValid :: Property +prop_UnionValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (union t1 t2) + +prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool +prop_UnionInsert k x t + = union (single k x) t == insert k x t + +prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: Map Int Int -> Map Int Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == unionWith (\x y -> y) t2 t1) + +prop_UnionWithValid + = forValidIntTree $ \t1 -> + forValidIntTree $ \t2 -> + valid (unionWithKey (\k x y -> x+y) t1 t2) + +prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_UnionWith xs ys + = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) + == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) + +prop_DiffValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (difference t1 t2) + +prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_Diff xs ys + = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) + +prop_IntValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (intersection t1 t2) + +prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_Int xs ys + = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [(x,()) | x <- [0..n::Int]] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) +-} diff --git a/lib/DData/MultiSet.hs b/lib/DData/MultiSet.hs new file mode 100644 --- /dev/null +++ b/lib/DData/MultiSet.hs @@ -0,0 +1,421 @@ +-------------------------------------------------------------------------------- +{-| Module : MultiSet + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An implementation of multi sets on top of the "Map" module. A multi set + differs from a /bag/ in the sense that it is represented as a map from elements + to occurrence counts instead of retaining all elements. This means that equality + on elements should be defined as a /structural/ equality instead of an + equivalence relation. If this is not the case, operations that observe the + elements, like 'filter' and 'fold', should be used with care. +-} +---------------------------------------------------------------------------------} +module MultiSet ( + -- * MultiSet type + MultiSet -- instance Eq,Show + + -- * Operators + , (\\) + + -- *Query + , isEmpty + , size + , distinctSize + , member + , occur + + , subset + , properSubset + + -- * Construction + , empty + , single + , insert + , insertMany + , delete + , deleteAll + + -- * Combine + , union + , difference + , intersection + , unions + + -- * Filter + , filter + , partition + + -- * Fold + , fold + , foldOccur + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteMinAll + , deleteMaxAll + + -- * Conversion + , elems + + -- ** List + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- ** Occurrence lists + , toOccurList + , toAscOccurList + , fromOccurList + , fromAscOccurList + + -- ** Map + , toMap + , fromMap + , fromOccurMap + + -- * Debugging + , showTree + , showTreeWith + , valid + ) where + +import Prelude hiding (map,filter) +import qualified Prelude (map,filter) + +import qualified Map as M + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +b1 \\ b2 = difference b1 b2 + +{-------------------------------------------------------------------- + MultiSets are a simple wrapper around Maps, 'Map.Map' +--------------------------------------------------------------------} +-- | A multi set of values @a@. +newtype MultiSet a = MultiSet (M.Map a Int) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the multi set empty? +isEmpty :: MultiSet a -> Bool +isEmpty (MultiSet m) + = M.isEmpty m + +-- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@). +distinctSize :: MultiSet a -> Int +distinctSize (MultiSet m) + = M.size m + +-- | /O(n)/. The number of elements in the multi set. +size :: MultiSet a -> Int +size b + = foldOccur (\x n m -> n+m) 0 b + +-- | /O(log n)/. Is the element in the multi set? +member :: Ord a => a -> MultiSet a -> Bool +member x m + = (occur x m > 0) + +-- | /O(log n)/. The number of occurrences of an element in the multi set. +occur :: Ord a => a -> MultiSet a -> Int +occur x (MultiSet m) + = case M.lookup x m of + Nothing -> 0 + Just n -> n + +-- | /O(n+m)/. Is this a subset of the multi set? +subset :: Ord a => MultiSet a -> MultiSet a -> Bool +subset (MultiSet m1) (MultiSet m2) + = M.subsetBy (<=) m1 m2 + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) +properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool +properSubset b1 b2 + | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2) + | distinctSize b1 < distinctSize b2 = (subset b1 b2) + | otherwise = False + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty multi set. +empty :: MultiSet a +empty + = MultiSet (M.empty) + +-- | /O(1)/. Create a singleton multi set. +single :: a -> MultiSet a +single x + = MultiSet (M.single x 0) + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(log n)/. Insert an element in the multi set. +insert :: Ord a => a -> MultiSet a -> MultiSet a +insert x (MultiSet m) + = MultiSet (M.insertWith (+) x 1 m) + +-- | /O(min(n,W))/. The expression (@insertMany x count mset@) +-- inserts @count@ instances of @x@ in the multi set @mset@. +insertMany :: Ord a => a -> Int -> MultiSet a -> MultiSet a +insertMany x count (MultiSet m) + = MultiSet (M.insertWith (+) x count m) + +-- | /O(log n)/. Delete a single element. +delete :: Ord a => a -> MultiSet a -> MultiSet a +delete x (MultiSet m) + = MultiSet (M.updateWithKey f x m) + where + f x n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete all occurrences of an element. +deleteAll :: Ord a => a -> MultiSet a -> MultiSet a +deleteAll x (MultiSet m) + = MultiSet (M.delete x m) + +{-------------------------------------------------------------------- + Combine +--------------------------------------------------------------------} +-- | /O(n+m)/. Union of two multisets. The union adds the elements together. +-- +-- > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,1,1,2,2,2,3} +union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +union (MultiSet t1) (MultiSet t2) + = MultiSet (M.unionWith (+) t1 t2) + +-- | /O(n+m)/. Intersection of two multisets. +-- +-- > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,2} +intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +intersection (MultiSet t1) (MultiSet t2) + = MultiSet (M.intersectionWith min t1 t2) + +-- | /O(n+m)/. Difference between two multisets. +-- +-- > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1} +difference :: Ord a => MultiSet a -> MultiSet a -> MultiSet a +difference (MultiSet t1) (MultiSet t2) + = MultiSet (M.differenceWithKey f t1 t2) + where + f x n m | n-m > 0 = Just (n-m) + | otherwise = Nothing + +-- | The union of a list of multisets. +unions :: Ord a => [MultiSet a] -> MultiSet a +unions multisets + = MultiSet (M.unions [m | MultiSet m <- multisets]) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a +filter p (MultiSet m) + = MultiSet (M.filterWithKey (\x n -> p x) m) + +-- | /O(n)/. Partition the multi set according to some predicate. +partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a) +partition p (MultiSet m) + = (MultiSet l,MultiSet r) + where + (l,r) = M.partitionWithKey (\x n -> p x) m + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over each element in the multi set. +fold :: (a -> b -> b) -> b -> MultiSet a -> b +fold f z (MultiSet m) + = M.foldWithKey apply z m + where + apply x n z | n > 0 = apply x (n-1) (f x z) + | otherwise = z + +-- | /O(n)/. Fold over all occurrences of an element at once. +foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b +foldOccur f z (MultiSet m) + = M.foldWithKey f z m + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal element of a multi set. +findMin :: MultiSet a -> a +findMin (MultiSet m) + = fst (M.findMin m) + +-- | /O(log n)/. The maximal element of a multi set. +findMax :: MultiSet a -> a +findMax (MultiSet m) + = fst (M.findMax m) + +-- | /O(log n)/. Delete the minimal element. +deleteMin :: MultiSet a -> MultiSet a +deleteMin (MultiSet m) + = MultiSet (M.updateMin f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete the maximal element. +deleteMax :: MultiSet a -> MultiSet a +deleteMax (MultiSet m) + = MultiSet (M.updateMax f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete all occurrences of the minimal element. +deleteMinAll :: MultiSet a -> MultiSet a +deleteMinAll (MultiSet m) + = MultiSet (M.deleteMin m) + +-- | /O(log n)/. Delete all occurrences of the maximal element. +deleteMaxAll :: MultiSet a -> MultiSet a +deleteMaxAll (MultiSet m) + = MultiSet (M.deleteMax m) + + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The list of elements. +elems :: MultiSet a -> [a] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Create a list with all elements. +toList :: MultiSet a -> [a] +toList s + = toAscList s + +-- | /O(n)/. Create an ascending list of all elements. +toAscList :: MultiSet a -> [a] +toAscList (MultiSet m) + = [y | (x,n) <- M.toAscList m, y <- replicate n x] + + +-- | /O(n*log n)/. Create a multi set from a list of elements. +fromList :: Ord a => [a] -> MultiSet a +fromList xs + = MultiSet (M.fromListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list in linear time. +fromAscList :: Eq a => [a] -> MultiSet a +fromAscList xs + = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [a] -> MultiSet a +fromDistinctAscList xs + = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs]) + +-- | /O(n)/. Create a list of element\/occurrence pairs. +toOccurList :: MultiSet a -> [(a,Int)] +toOccurList b + = toAscOccurList b + +-- | /O(n)/. Create an ascending list of element\/occurrence pairs. +toAscOccurList :: MultiSet a -> [(a,Int)] +toAscOccurList (MultiSet m) + = M.toAscList m + +-- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs. +fromOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromOccurList xs + = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +-- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs. +fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromAscOccurList xs + = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +{-------------------------------------------------------------------- + Maps +--------------------------------------------------------------------} +-- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences. +toMap :: MultiSet a -> M.Map a Int +toMap (MultiSet m) + = m + +-- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +fromMap :: Ord a => M.Map a Int -> MultiSet a +fromMap m + = MultiSet (M.filter (>0) m) + +-- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +-- Assumes that the 'Map.Map' contains only elements that occur at least once. +fromOccurMap :: M.Map a Int -> MultiSet a +fromOccurMap m + = MultiSet m + +{-------------------------------------------------------------------- + Eq, Ord +--------------------------------------------------------------------} +instance Eq a => Eq (MultiSet a) where + (MultiSet m1) == (MultiSet m2) = (m1==m2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show a => Show (MultiSet a) where + showsPrec d b = showSet (toAscList b) + +showSet :: Show a => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree +-- is shown as a compressed and /hanging/. +showTree :: (Show a) => MultiSet a -> String +showTree mset + = showTreeWith True False mset + +-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows +-- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version +-- is shown. +showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String +showTreeWith hang wide (MultiSet m) + = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m + + +-- | /O(n)/. Is this a valid multi set? +valid :: Ord a => MultiSet a -> Bool +valid (MultiSet m) + = M.valid m && (M.isEmpty (M.filter (<=0) m)) diff --git a/lib/DData/Queue.hs b/lib/DData/Queue.hs new file mode 100644 --- /dev/null +++ b/lib/DData/Queue.hs @@ -0,0 +1,280 @@ +-------------------------------------------------------------------------------- +{-| Module : Queue + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of queues (FIFO buffers). Based on: + + * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\", + Journal of Functional Programming 5(4):583-592, October 1995. +-} +---------------------------------------------------------------------------------} +module Queue ( + -- * Queue type + Queue -- instance Eq,Show + + -- * Operators + , (<>) + + -- * Query + , isEmpty + , length + , head + , tail + , front + + -- * Construction + , empty + , single + , insert + , append + + -- * Filter + , filter + , partition + + -- * Fold + , foldL + , foldR + + -- * Conversion + , elems + + -- ** List + , toList + , fromList + ) where + +import qualified Prelude as P (length,filter) +import Prelude hiding (length,head,tail,filter) +import qualified List + +-- just for testing +-- import QuickCheck + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixr 5 <> + +-- | /O(n)/. Append two queues, see 'append'. +(<>) :: Queue a -> Queue a -> Queue a +s <> t + = append s t + +{-------------------------------------------------------------------- + Queue. + Invariants for @(Queue xs ys zs)@: + * @length ys <= length xs@ + * @length zs == length xs - length ys@ +--------------------------------------------------------------------} +-- A queue of elements @a@. +data Queue a = Queue [a] [a] [a] + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} + +-- | /O(1)/. Is the queue empty? +isEmpty :: Queue a -> Bool +isEmpty (Queue xs ys zs) + = null xs + +-- | /O(n)/. The number of elements in the queue. +length :: Queue a -> Int +length (Queue xs ys zs) + = P.length xs + P.length ys + +-- | /O(1)/. The element in front of the queue. Raises an error +-- when the queue is empty. +head :: Queue a -> a +head (Queue xs ys zs) + = case xs of + (x:xx) -> x + [] -> error "Queue.head: empty queue" + +-- | /O(1)/. The tail of the queue. +-- Raises an error when the queue is empty. +tail :: Queue a -> Queue a +tail (Queue xs ys zs) + = case xs of + (x:xx) -> queue xx ys zs + [] -> error "Queue.tail: empty queue" + +-- | /O(1)/. The head and tail of the queue. +front :: Queue a -> Maybe (a,Queue a) +front (Queue xs ys zs) + = case xs of + (x:xx) -> Just (x,queue xx ys zs) + [] -> Nothing + + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty queue. +empty :: Queue a +empty + = Queue [] [] [] + +-- | /O(1)/. A queue of one element. +single :: a -> Queue a +single x + = Queue [x] [] [x] + +-- | /O(1)/. Insert an element at the back of a queue. +insert :: a -> Queue a -> Queue a +insert x (Queue xs ys zs) + = queue xs (x:ys) zs + + +-- | /O(n)/. Append two queues. +append :: Queue a -> Queue a -> Queue a +append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2) + = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2) + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter elements according to some predicate. +filter :: (a -> Bool) -> Queue a -> Queue a +filter pred (Queue xs ys zs) + = balance xs' ys' + where + xs' = P.filter pred xs + ys' = P.filter pred ys + +-- | /O(n)/. Partition the elements according to some predicate. +partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a) +partition pred (Queue xs ys zs) + = (balance xs1 ys1, balance xs2 ys2) + where + (xs1,xs2) = List.partition pred xs + (ys1,ys2) = List.partition pred ys + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements from left to right (ie. head to tail). +foldL :: (b -> a -> b) -> b -> Queue a -> b +foldL f z (Queue xs ys zs) + = foldr (flip f) (foldl f z xs) ys + +-- | /O(n)/. Fold over the elements from right to left (ie. tail to head). +foldR :: (a -> b -> b) -> b -> Queue a -> b +foldR f z (Queue xs ys zs) + = foldr f (foldl (flip f) z ys) xs + + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a queue. +elems :: Queue a -> [a] +elems q + = toList q + +-- | /O(n)/. Convert to a list. +toList :: Queue a -> [a] +toList (Queue xs ys zs) + = xs ++ reverse ys + +-- | /O(n)/. Convert from a list. +fromList :: [a] -> Queue a +fromList xs + = Queue xs [] xs + + +{-------------------------------------------------------------------- + instance Eq, Show +--------------------------------------------------------------------} +instance Eq a => Eq (Queue a) where + q1 == q2 = toList q1 == toList q2 + +instance Show a => Show (Queue a) where + showsPrec d q = showsPrec d (toList q) + + +{-------------------------------------------------------------------- + Smart constructor: + Note that @(queue xs ys zs)@ is always called with + @(length zs == length xs - length ys + 1)@. and thus + @rotate@ is always called when @(length xs == length ys+1)@. +--------------------------------------------------------------------} +balance :: [a] -> [a] -> Queue a +balance xs ys + = Queue qs [] qs + where + qs = xs ++ reverse ys + +queue :: [a] -> [a] -> [a] -> Queue a +queue xs ys (z:zs) = Queue xs ys zs +queue xs ys [] = Queue qs [] qs + where + qs = rotate xs ys [] + +-- @(rotate xs ys []) == xs ++ reverse ys)@ +rotate :: [a] -> [a] -> [a] -> [a] +rotate [] [y] zs = y:zs +rotate (x:xs) (y:ys) zs = x:rotate xs ys (y:zs) +rotate xs ys zs = error "Queue.rotate: unbalanced queue" + + +valid :: Queue a -> Bool +valid (Queue xs ys zs) + = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs) + +{- +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 10000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced queues +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Queue a) where + arbitrary = do{ qs <- arbitrary + ; let (ys,xs) = splitAt (P.length qs `div` 2) qs + ; return (Queue xs ys (xs ++ reverse ys)) + } + + +prop_Valid :: Queue Int -> Bool +prop_Valid q + = valid q + +prop_InsertLast :: [Int] -> Property +prop_InsertLast xs + = not (null xs) ==> head (foldr insert empty xs) == last xs + +prop_InsertValid :: [Int] -> Bool +prop_InsertValid xs + = valid (foldr insert empty xs) + +prop_Queue :: [Int] -> Bool +prop_Queue xs + = toList (foldl (flip insert) empty xs) == foldr (:) [] xs + +prop_List :: [Int] -> Bool +prop_List xs + = toList (fromList xs) == xs + +prop_TailValid :: [Int] -> Bool +prop_TailValid xs + = valid (tail (foldr insert empty (1:xs))) +-} diff --git a/lib/DData/Scc.hs b/lib/DData/Scc.hs new file mode 100644 --- /dev/null +++ b/lib/DData/Scc.hs @@ -0,0 +1,308 @@ +-------------------------------------------------------------------------------- +{-| Module : Scc + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Compute the /strongly connected components/ of a directed graph. + The implementation is based on the following article: + + * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/, + ACM Principles of Programming Languages, San Francisco, 1995. + + In contrast to their description, this module doesn't use lazy state + threads but is instead purely functional -- using the "Map" and "Set" module. + This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but + due to the hidden constant factor, this implementation performs very well in practice. +-} +---------------------------------------------------------------------------------} +module Scc ( scc ) where + +import qualified Map +import qualified Set + +{- +-- just for testing +import Debug.QuickCheck +import List(nub,sort) +-} + +{-------------------------------------------------------------------- + Graph +--------------------------------------------------------------------} +-- | A @Graph v@ is a directed graph with nodes @v@. +newtype Graph v = Graph (Map.Map v [v]) + +-- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from +-- node @x@ to node @y@. +type Edge v = (v,v) +type Node v = (v,[v]) + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +nodes :: Graph v -> [Node v] +nodes (Graph g) + = Map.toList g + +graph :: Ord v => [Node v] -> Graph v +graph es + = Graph (Map.fromListWith (++) es) + +{-------------------------------------------------------------------- + Graph functions +--------------------------------------------------------------------} +edges :: Graph v -> [Edge v] +edges g + = [(v,w) | (v,vs) <- nodes g, w <- vs] + +vertices :: Graph v -> [v] +vertices g + = [v | (v,vs) <- nodes g] + +successors :: Ord v => v -> Graph v -> [v] +successors v (Graph g) + = Map.findWithDefault [] v g + +transpose :: Ord v => Graph v -> Graph v +transpose g@(Graph m) + = Graph (foldr add empty (edges g)) + where + empty = Map.map (const []) m + add (v,w) m = Map.adjust (v:) w m + + +{-------------------------------------------------------------------- + Depth first search and forests +--------------------------------------------------------------------} +data Tree v = Node v (Forest v) +type Forest v = [Tree v] + +dff :: Ord v => Graph v -> Forest v +dff g + = dfs g (vertices g) + +dfs :: Ord v => Graph v -> [v] -> Forest v +dfs g vs + = prune (map (tree g) vs) + +tree :: Ord v => Graph v -> v -> Tree v +tree g v + = Node v (map (tree g) (successors v g)) + +prune :: Ord v => Forest v -> Forest v +prune fs + = snd (chop Set.empty fs) + where + chop ms [] = (ms,[]) + chop ms (Node v vs:fs) + | visited = chop ms fs + | otherwise = let ms0 = Set.insert v ms + (ms1,vs') = chop ms0 vs + (ms2,fs') = chop ms1 fs + in (ms2,Node v vs':fs') + where + visited = Set.member v ms + +{-------------------------------------------------------------------- + Orderings +--------------------------------------------------------------------} +preorder :: Ord v => Graph v -> [v] +preorder g + = preorderF (dff g) + +preorderF fs + = concatMap preorderT fs + +preorderT (Node v fs) + = v:preorderF fs + +postorder :: Ord v => Graph v -> [v] +postorder g + = postorderF (dff g) + +postorderT t + = postorderF [t] + +postorderF ts + = postorderF' ts [] + where + -- efficient concatenation by passing the tail around. + postorderF' [] tl = tl + postorderF' (t:ts) tl = postorderT' t (postorderF' ts tl) + postorderT' (Node v fs) tl = postorderF' fs (v:tl) + + +{-------------------------------------------------------------------- + Strongly connected components +--------------------------------------------------------------------} + +{- | + Compute the strongly connected components of a graph. The algorithm + is tailored toward the needs of compiler writers that need to compute + recursive binding groups (for example, the original order is preserved + as much as possible). + + The expression (@scc xs@) computes the strongly connectected components + of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node + label and @ws@ a list of nodes where @v@ points to, ie. there is an + arrow\/dependency from @v@ to each node in @ws@. Here is an example + of @scc@: + +> Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])] +> [[3],[1,2],[0],[4]] + + In an expression @(scc xs)@, the graph @xs@ should contain an entry for + every node in the graph, ie: + +> all (`elem` nodes) targets +> where nodes = map fst xs +> targets = concat (map snd xs) + + Furthermore, the returned components consist exactly of the original nodes: + +> sort (concat (scc xs)) == sort (map fst xs) + + The connected components are sorted by dependency, ie. there are + no arrows\/dependencies from left-to-right. Furthermore, the original order + is preserved as much as possible. +-} +scc :: Ord v => [(v,[v])] -> [[v]] +scc nodes + = sccG (graph nodes) + +sccG :: Ord v => Graph v -> [[v]] +sccG g + = map preorderT (sccF g) + +sccF :: Ord v => Graph v -> Forest v +sccF g + = reverse (dfs (transpose g) (topsort g)) + +topsort g + = reverse (postorder g) + +{-------------------------------------------------------------------- + Reachable and path +--------------------------------------------------------------------} +reachable v g + = preorderF (dfs g [v]) + +path v w g + = elem w (reachable v g) + + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show v => Show (Graph v) where + showsPrec d (Graph m) = shows m + +instance Show v => Show (Tree v) where + showsPrec d (Node v []) = shows v + showsPrec d (Node v fs) = shows v . showList fs + + +{-------------------------------------------------------------------- + Quick Test +--------------------------------------------------------------------} +tgraph0 :: Graph Int +tgraph0 = graph + [(0,[1]) + ,(1,[2,1,3]) + ,(2,[1]) + ,(3,[]) + ] + +tgraph1 = graph + [ ('a',"jg") + , ('b',"ia") + , ('c',"he") + , ('d',"") + , ('e',"jhd") + , ('f',"i") + , ('g',"fb") + , ('h',"") + ] + +{- +{-------------------------------------------------------------------- + Quickcheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary Graph's +--------------------------------------------------------------------} +instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where + arbitrary = sized arbgraph + + +arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v) +arbgraph n + = do nodes <- arbitrary + g <- mapM (targets nodes) nodes + return (graph g) + where + targets nodes v + = do sz <- choose (0,length nodes-1) + ts <- mapM (target nodes) [1..sz] + return (v,ts) + + target nodes _ + = do idx <- choose (0,length nodes-1) + return (nodes!!idx) + +{-------------------------------------------------------------------- + Properties +--------------------------------------------------------------------} +prop_ValidGraph :: Graph Int -> Bool +prop_ValidGraph g + = all (`elem` srcs) targets + where + srcs = map fst (nodes g) + targets = concatMap snd (nodes g) + +-- all scc nodes are in the original graph and the other way around +prop_SccComplete :: Graph Int -> Bool +prop_SccComplete g + = sort (concat (sccG g)) == sort (vertices g) + +-- all scc nodes have only backward dependencies +prop_SccForward :: Graph Int -> Bool +prop_SccForward g + = all noforwards (zip prevs ss) + where + ss = sccG g + prevs = scanl1 (++) ss + + noforwards (prev,xs) + = all (noforward prev) xs + + noforward prev x + = all (`elem` prev) (successors x g) + +-- all strongly connected components refer to each other +prop_SccConnected :: Graph Int -> Bool +prop_SccConnected g + = all connected (sccG g) + where + connected xs + = all (paths xs) xs + + paths xs x + = all (\y -> path x y g) xs + +-} diff --git a/lib/DData/Seq.hs b/lib/DData/Seq.hs new file mode 100644 --- /dev/null +++ b/lib/DData/Seq.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- +{-| Module : Seq + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An implementation of John Hughes's efficient catenable sequence type. A lazy sequence + @Seq a@ can be concatenated in /O(1)/ time. After + construction, the sequence in converted in /O(n)/ time into a list. +-} +---------------------------------------------------------------------------------} +module Seq( -- * Type + Seq + -- * Operators + , (<>) + + -- * Construction + , empty + , single + , cons + , append + + -- * Conversion + , toList + , fromList + ) where + + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixr 5 <> + +-- | /O(1)/. Append two sequences, see 'append'. +(<>) :: Seq a -> Seq a -> Seq a +s <> t + = append s t + +{-------------------------------------------------------------------- + Type +--------------------------------------------------------------------} +-- | Sequences of values @a@. +newtype Seq a = Seq ([a] -> [a]) + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty sequence. +empty :: Seq a +empty + = Seq (\ts -> ts) + +-- | /O(1)/. Create a sequence of one element. +single :: a -> Seq a +single x + = Seq (\ts -> x:ts) + +-- | /O(1)/. Put a value in front of a sequence. +cons :: a -> Seq a -> Seq a +cons x (Seq f) + = Seq (\ts -> x:f ts) + +-- | /O(1)/. Append two sequences. +append :: Seq a -> Seq a -> Seq a +append (Seq f) (Seq g) + = Seq (\ts -> f (g ts)) + + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +-- | /O(n)/. Convert a sequence to a list. +toList :: Seq a -> [a] +toList (Seq f) + = f [] + +-- | /O(n)/. Create a sequence from a list. +fromList :: [a] -> Seq a +fromList xs + = Seq (\ts -> xs++ts) + + + + + + + + diff --git a/lib/DData/Set.hs b/lib/DData/Set.hs new file mode 100644 --- /dev/null +++ b/lib/DData/Set.hs @@ -0,0 +1,1073 @@ +-------------------------------------------------------------------------------- +{-| Module : Set + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of sets. + + 1) The 'filter' function clashes with the "Prelude". + If you want to use "Set" unqualified, this function should be hidden. + + > import Prelude hiding (filter) + > import Set + + Another solution is to use qualified names. This is also the only way how + a "Map", "Set", and "MultiSet" can be used within one module. + + > import qualified Set + > + > ... Set.singleton "Paris" + + Or, if you prefer a terse coding style: + + > import qualified Set as S + > + > ... S.singleton "Berlin" + + 2) The implementation of "Set" is based on /size balanced/ binary trees (or + trees of /bounded balance/) as described by: + + * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional + Programming 3(4):553-562, October 1993, . + + * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\", + SIAM journal of computing 2(1), March 1973. + + 3) Note that the implementation /left-biased/ -- the elements of a first argument + are always perferred to the second, for example in 'union' or 'insert'. + Off course, left-biasing can only be observed when equality an equivalence relation + instead of structural equality. + + 4) Another implementation of sets based on size balanced trees + exists as "Data.Set" in the Ghc libraries. The good part about this library + is that it is highly tuned and thorougly tested. However, it is also fairly old, + it is implemented indirectly on top of "Data.FiniteMap" and only supports + the basic set operations. + The "Set" module overcomes some of these issues: + + * It tries to export a more complete and consistent set of operations, like + 'partition', 'subset' etc. + + * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' + (a /hedge/ algorithm is not applicable to 'intersection'). + + * It converts ordered lists in linear time ('fromAscList'). + + * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'. + + * It is implemented directly, instead of using a seperate finite map implementation. +-} +--------------------------------------------------------------------------------- +module Set ( + -- * Set type + Set -- instance Eq,Show + + -- * Operators + , (\\) + + -- * Query + , isEmpty + , Set.null + , size + , member + , subset + , properSubset + + -- * Construction + , empty + , singleton + , insert + , delete + + -- * Combine + , union, unions + , difference + , intersection + + -- * Filter + , filter + , partition + , split + , splitMember + + -- * Fold + , Set.map + , mapMonotonic + , fold + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + + -- * Conversion + + -- ** List + , elems + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- * Debugging + , showTree + , showTreeWith + , valid + ) where + +import Prelude hiding (filter,map) +import List (map) + +{- +-- just for testing +import QuickCheck +import List (nub,sort) +import qualified List +-} + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord a => Set a -> Set a -> Set a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Sets are size balanced trees +--------------------------------------------------------------------} +-- | A set of values @a@. +data Set a = Tip + | Bin !Size a !(Set a) !(Set a) + +type Size = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is this the empty set? +isEmpty :: Set a -> Bool +isEmpty t + = case t of + Tip -> True + Bin sz x l r -> False + +null :: Set a -> Bool +null = isEmpty + +-- | /O(1)/. The number of elements in the set. +size :: Set a -> Int +size t + = case t of + Tip -> 0 + Bin sz x l r -> sz + +-- | /O(log n)/. Is the element in the set? +member :: Ord a => a -> Set a -> Bool +member x t + = case t of + Tip -> False + Bin sz y l r + -> case compare x y of + LT -> member x l + GT -> member x r + EQ -> True + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: Set a +empty + = Tip + +-- | /O(1)/. Create a singleton set. +singleton :: a -> Set a +singleton x + = Bin 1 x Tip Tip + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(log n)/. Insert an element in a set. +insert :: Ord a => a -> Set a -> Set a +insert x t + = case t of + Tip -> singleton x + Bin sz y l r + -> case compare x y of + LT -> balance y (insert x l) r + GT -> balance y l (insert x r) + EQ -> Bin sz x l r + + +-- | /O(log n)/. Delete an element from a set. +delete :: Ord a => a -> Set a -> Set a +delete x t + = case t of + Tip -> Tip + Bin sz y l r + -> case compare x y of + LT -> balance y (delete x l) r + GT -> balance y l (delete x r) + EQ -> glue l r + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +properSubset :: Ord a => Set a -> Set a -> Bool +properSubset s1 s2 + = (size s1 < size s2) && (subset s1 s2) + + +-- | /O(n+m)/. Is this a subset? +subset :: Ord a => Set a -> Set a -> Bool +subset t1 t2 + = (size t1 <= size t2) && (subsetX t1 t2) + +subsetX Tip t = True +subsetX t Tip = False +subsetX (Bin _ x l r) t + = found && subsetX l lt && subsetX r gt + where + (found,lt,gt) = splitMember x t + + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal element of a set. +findMin :: Set a -> a +findMin (Bin _ x Tip r) = x +findMin (Bin _ x l r) = findMin l +findMin Tip = error "Set.findMin: empty set has no minimal element" + +-- | /O(log n)/. The maximal element of a set. +findMax :: Set a -> a +findMax (Bin _ x l Tip) = x +findMax (Bin _ x l r) = findMax r +findMax Tip = error "Set.findMax: empty set has no maximal element" + +-- | /O(log n)/. Delete the minimal element. +deleteMin :: Set a -> Set a +deleteMin (Bin _ x Tip r) = r +deleteMin (Bin _ x l r) = balance x (deleteMin l) r +deleteMin Tip = Tip + +-- | /O(log n)/. Delete the maximal element. +deleteMax :: Set a -> Set a +deleteMax (Bin _ x l Tip) = l +deleteMax (Bin _ x l r) = balance x l (deleteMax r) +deleteMax Tip = Tip + + +{-------------------------------------------------------------------- + Union. +--------------------------------------------------------------------} +-- | The union of a list of sets: (@unions == foldl union empty@). +unions :: Ord a => [Set a] -> Set a +unions ts + = foldlStrict union empty ts + + +-- | /O(n+m)/. The union of two sets. Uses the efficient /hedge-union/ algorithm. +union :: Ord a => Set a -> Set a -> Set a +union Tip t2 = t2 +union t1 Tip = t1 +union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) + | size t1 >= size t2 = hedgeUnion (const LT) (const GT) t1 t2 + | otherwise = hedgeUnion (const LT) (const GT) t2 t1 + +hedgeUnion cmplo cmphi t1 Tip + = t1 +hedgeUnion cmplo cmphi Tip (Bin _ x l r) + = join x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnion cmplo cmphi (Bin _ x l r) t2 + = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) + (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2)) + where + cmpx y = compare x y + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference of two sets. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +difference :: Ord a => Set a -> Set a -> Set a +difference Tip t2 = Tip +difference t1 Tip = t1 +difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2 + +hedgeDiff cmplo cmphi Tip t + = Tip +hedgeDiff cmplo cmphi (Bin _ x l r) Tip + = join x (filterGt cmplo l) (filterLt cmphi r) +hedgeDiff cmplo cmphi t (Bin _ x l r) + = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) + (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r) + where + cmpx y = compare x y + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. The intersection of two sets. +intersection :: Ord a => Set a -> Set a -> Set a +intersection Tip t = Tip +intersection t Tip = Tip +intersection t1 t2 -- intersection is more efficient on (bigset `intersection` smallset) + | size t1 >= size t2 = intersect t1 t2 + | otherwise = intersect t2 t1 + +intersect Tip t = Tip +intersect t Tip = Tip +intersect t (Bin _ x l r) + | found = join x tl tr + | otherwise = merge tl tr + where + (found,lt,gt) = splitMember x t + tl = intersect lt l + tr = intersect gt r + + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy the predicate. +filter :: Ord a => (a -> Bool) -> Set a -> Set a +filter p Tip = Tip +filter p (Bin _ x l r) + | p x = join x (filter p l) (filter p r) + | otherwise = merge (filter p l) (filter p r) + +-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy +-- the predicate and one with all elements that don't satisfy the predicate. +-- See also 'split'. +partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a) +partition p Tip = (Tip,Tip) +partition p (Bin _ x l r) + | p x = (join x l1 r1,merge l2 r2) + | otherwise = (merge l1 r1,join x l2 r2) + where + (l1,l2) = partition p l + (r1,r2) = partition p r + +{---------------------------------------------------------------------- + Map +----------------------------------------------------------------------} + +-- | /O(n*log n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. +-- +-- It's worth noting that the size of the result may be smaller if, +-- for some @(x,y)@, @x \/= y && f x == f y@ + +map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b +map f = fromList . List.map f . toList + +-- | /O(n)/. The +-- +-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapMonotonic f s == map f s +-- > where ls = toList s + +mapMonotonic :: (a->b) -> Set a -> Set b +mapMonotonic f Tip = Tip +mapMonotonic f (Bin sz x l r) = + Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r) + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold the elements of a set. +fold :: (a -> b -> b) -> b -> Set a -> b +fold f z s + = foldR f z s + +-- | /O(n)/. Post-order fold. +foldR :: (a -> b -> b) -> b -> Set a -> b +foldR f z Tip = z +foldR f z (Bin _ x l r) = foldR f (f x (foldR f z r)) l + + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a set. +elems :: Set a -> [a] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the set to a list of elements. +toList :: Set a -> [a] +toList s + = toAscList s + +-- | /O(n)/. Convert the set to an ascending list of elements. +toAscList :: Set a -> [a] +toAscList t + = foldR (:) [] t + + +-- | /O(n*log n)/. Create a set from a list of elements. +fromList :: Ord a => [a] -> Set a +fromList xs + = foldlStrict ins empty xs + where + ins t x = insert x t + +{-------------------------------------------------------------------- + Building trees from ascending/descending lists can be done in linear time. + + Note that if [xs] is ascending that: + fromAscList xs == fromList xs +--------------------------------------------------------------------} +-- | /O(n)/. Build a map from an ascending list in linear time. +fromAscList :: Eq a => [a] -> Set a +fromAscList xs + = fromDistinctAscList (combineEq xs) + where + -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] + combineEq xs + = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> combineEq' x xx + + combineEq' z [] = [z] + combineEq' z (x:xs) + | z==x = combineEq' z xs + | otherwise = z:combineEq' x xs + + +-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [a] -> Set a +fromDistinctAscList xs + = build const (length xs) xs + where + -- 1) use continutations so that we use heap space instead of stack space. + -- 2) special case for n==5 to build bushier trees. + build c 0 xs = c Tip xs + build c 5 xs = case xs of + (x1:x2:x3:x4:x5:xx) + -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx + build c n xs = seq nr $ build (buildR nr c) nl xs + where + nl = n `div` 2 + nr = n - nl - 1 + + buildR n c l (x:ys) = build (buildB l x c) n ys + buildB l x c r zs = c (bin x l r) zs + +{-------------------------------------------------------------------- + Eq converts the set to a list. In a lazy setting, this + actually seems one of the faster methods to compare two trees + and it is certainly the simplest :-) +--------------------------------------------------------------------} +instance Eq a => Eq (Set a) where + t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) + +{-------------------------------------------------------------------- + Ord +--------------------------------------------------------------------} +instance Ord a => Ord (Set a) where + compare s1 s2 = compare (toAscList s1) (toAscList s2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show a => Show (Set a) where + showsPrec d s = showSet (toAscList s) + +showSet :: (Show a) => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Utility functions that return sub-ranges of the original + tree. Some functions take a comparison function as argument to + allow comparisons against infinite values. A function [cmplo x] + should be read as [compare lo x]. + + [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT] + and [cmphi x == GT] for the value [x] of the root. + [filterGt cmp t] A tree where for all values [k]. [cmp k == LT] + [filterLt cmp t] A tree where for all values [k]. [cmp k == GT] + + [split k t] Returns two trees [l] and [r] where all values + in [l] are <[k] and all keys in [r] are >[k]. + [splitMember k t] Just like [split] but also returns whether [k] + was found in the tree. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + [trim lo hi t] trims away all subtrees that surely contain no + values between the range [lo] to [hi]. The returned tree is either + empty or the key of the root is between @lo@ and @hi@. +--------------------------------------------------------------------} +trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a +trim cmplo cmphi Tip = Tip +trim cmplo cmphi t@(Bin sx x l r) + = case cmplo x of + LT -> case cmphi x of + GT -> t + le -> trim cmplo cmphi l + ge -> trim cmplo cmphi r + +trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a) +trimMemberLo lo cmphi Tip = (False,Tip) +trimMemberLo lo cmphi t@(Bin sx x l r) + = case compare lo x of + LT -> case cmphi x of + GT -> (member lo t, t) + le -> trimMemberLo lo cmphi l + GT -> trimMemberLo lo cmphi r + EQ -> (True,trim (compare lo) cmphi r) + + +{-------------------------------------------------------------------- + [filterGt x t] filter all values >[x] from tree [t] + [filterLt x t] filter all values <[x] from tree [t] +--------------------------------------------------------------------} +filterGt :: (a -> Ordering) -> Set a -> Set a +filterGt cmp Tip = Tip +filterGt cmp (Bin sx x l r) + = case cmp x of + LT -> join x (filterGt cmp l) r + GT -> filterGt cmp r + EQ -> r + +filterLt :: (a -> Ordering) -> Set a -> Set a +filterLt cmp Tip = Tip +filterLt cmp (Bin sx x l r) + = case cmp x of + LT -> filterLt cmp l + GT -> join x l (filterLt cmp r) + EQ -> l + + +{-------------------------------------------------------------------- + Split +--------------------------------------------------------------------} +-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@ +-- where all elements in @set1@ are lower than @x@ and all elements in +-- @set2@ larger than @x@. +split :: Ord a => a -> Set a -> (Set a,Set a) +split x Tip = (Tip,Tip) +split x (Bin sy y l r) + = case compare x y of + LT -> let (lt,gt) = split x l in (lt,join y gt r) + GT -> let (lt,gt) = split x r in (join y l lt,gt) + EQ -> (l,r) + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Ord a => a -> Set a -> (Bool,Set a,Set a) +splitMember x Tip = (False,Tip,Tip) +splitMember x (Bin sy y l r) + = case compare x y of + LT -> let (found,lt,gt) = splitMember x l in (found,lt,join y gt r) + GT -> let (found,lt,gt) = splitMember x r in (found,join y l lt,gt) + EQ -> (True,l,r) + +{-------------------------------------------------------------------- + Utility functions that maintain the balance properties of the tree. + All constructors assume that all values in [l] < [x] and all values + in [r] > [x], and that [l] and [r] are valid trees. + + In order of sophistication: + [Bin sz x l r] The type constructor. + [bin x l r] Maintains the correct size, assumes that both [l] + and [r] are balanced with respect to each other. + [balance x l r] Restores the balance and size. + Assumes that the original tree was balanced and + that [l] or [r] has changed by at most one element. + [join x l r] Restores balance and size. + + Furthermore, we can construct a new tree from two trees. Both operations + assume that all values in [l] < all values in [r] and that [l] and [r] + are valid: + [glue l r] Glues [l] and [r] together. Assumes that [l] and + [r] are already balanced with respect to each other. + [merge l r] Merges two trees and restores balance. + + Note: in contrast to Adam's paper, we use (<=) comparisons instead + of (<) comparisons in [join], [merge] and [balance]. + Quickcheck (on [difference]) showed that this was necessary in order + to maintain the invariants. It is quite unsatisfactory that I haven't + been able to find out why this is actually the case! Fortunately, it + doesn't hurt to be a bit more conservative. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: a -> Set a -> Set a -> Set a +join x Tip r = insertMin x r +join x l Tip = insertMax x l +join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz) + | delta*sizeL <= sizeR = balance z (join x l lz) rz + | delta*sizeR <= sizeL = balance y ly (join x ry r) + | otherwise = bin x l r + + +-- insertMin and insertMax don't perform potentially expensive comparisons. +insertMax,insertMin :: a -> Set a -> Set a +insertMax x t + = case t of + Tip -> singleton x + Bin sz y l r + -> balance y l (insertMax x r) + +insertMin x t + = case t of + Tip -> singleton x + Bin sz y l r + -> balance y (insertMin x l) r + +{-------------------------------------------------------------------- + [merge l r]: merges two trees. +--------------------------------------------------------------------} +merge :: Set a -> Set a -> Set a +merge Tip r = r +merge l Tip = l +merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry) + | delta*sizeL <= sizeR = balance y (merge l ly) ry + | delta*sizeR <= sizeL = balance x lx (merge rx r) + | otherwise = glue l r + +{-------------------------------------------------------------------- + [glue l r]: glues two trees together. + Assumes that [l] and [r] are already balanced with respect to each other. +--------------------------------------------------------------------} +glue :: Set a -> Set a -> Set a +glue Tip r = r +glue l Tip = l +glue l r + | size l > size r = let (m,l') = deleteFindMax l in balance m l' r + | otherwise = let (m,r') = deleteFindMin r in balance m l r' + + +-- | /O(log n)/. Delete and find the minimal element. +deleteFindMin :: Set a -> (a,Set a) +deleteFindMin t + = case t of + Bin _ x Tip r -> (x,r) + Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r) + Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) + +-- | /O(log n)/. Delete and find the maximal element. +deleteFindMax :: Set a -> (a,Set a) +deleteFindMax t + = case t of + Bin _ x l Tip -> (x,l) + Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r') + Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip) + + +{-------------------------------------------------------------------- + [balance x l r] balances two trees with value x. + The sizes of the trees should balance after decreasing the + size of one of them. (a rotation). + + [delta] is the maximal relative difference between the sizes of + two trees, it corresponds with the [w] in Adams' paper, + or equivalently, [1/delta] corresponds with the $\alpha$ + in Nievergelt's paper. Adams shows that [delta] should + be larger than 3.745 in order to garantee that the + rotations can always restore balance. + + [ratio] is the ratio between an outer and inner sibling of the + heavier subtree in an unbalanced setting. It determines + whether a double or single rotation should be performed + to restore balance. It is correspondes with the inverse + of $\alpha$ in Adam's article. + + Note that: + - [delta] should be larger than 4.646 with a [ratio] of 2. + - [delta] should be larger than 3.745 with a [ratio] of 1.534. + + - A lower [delta] leads to a more 'perfectly' balanced tree. + - A higher [delta] performs less rebalancing. + + - Balancing is automatic for random data and a balancing + scheme is only necessary to avoid pathological worst cases. + Almost any choice will do in practice + + - Allthough it seems that a rather large [delta] may perform better + than smaller one, measurements have shown that the smallest [delta] + of 4 is actually the fastest on a wide range of operations. It + especially improves performance on worst-case scenarios like + a sequence of ordered insertions. + + Note: in contrast to Adams' paper, we use a ratio of (at least) 2 + to decide whether a single or double rotation is needed. Allthough + he actually proves that this ratio is needed to maintain the + invariants, his implementation uses a (invalid) ratio of 1. + He is aware of the problem though since he has put a comment in his + original source code that he doesn't care about generating a + slightly inbalanced tree since it doesn't seem to matter in practice. + However (since we use quickcheck :-) we will stick to strictly balanced + trees. +--------------------------------------------------------------------} +delta,ratio :: Int +delta = 4 +ratio = 2 + +balance :: a -> Set a -> Set a -> Set a +balance x l r + | sizeL + sizeR <= 1 = Bin sizeX x l r + | sizeR >= delta*sizeL = rotateL x l r + | sizeL >= delta*sizeR = rotateR x l r + | otherwise = Bin sizeX x l r + where + sizeL = size l + sizeR = size r + sizeX = sizeL + sizeR + 1 + +-- rotate +rotateL x l r@(Bin _ _ ly ry) + | size ly < ratio*size ry = singleL x l r + | otherwise = doubleL x l r + +rotateR x l@(Bin _ _ ly ry) r + | size ry < ratio*size ly = singleR x l r + | otherwise = doubleR x l r + +-- basic rotations +singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3 +singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3) + +doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4) +doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4) + + +{-------------------------------------------------------------------- + The bin constructor maintains the size of the tree +--------------------------------------------------------------------} +bin :: a -> Set a -> Set a -> Set a +bin x l r + = Bin (size l + size r + 1) x l r + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the set. The tree is shown +-- in a compressed, hanging format. +showTree :: Show a => Set a -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the set. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. + +> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5] +> 4 +> +--2 +> | +--1 +> | +--3 +> +--5 +> +> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5] +> 4 +> | +> +--2 +> | | +> | +--1 +> | | +> | +--3 +> | +> +--5 +> +> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5] +> +--5 +> | +> 4 +> | +> | +--3 +> | | +> +--2 +> | +> +--1 + +-} +showTreeWith :: Show a => Bool -> Bool -> Set a -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS +showsTree wide lbars rbars t + = case t of + Tip -> showsBars lbars . showString "|\n" + Bin sz x Tip Tip + -> showsBars lbars . shows x . showString "\n" + Bin sz x l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . shows x . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + +showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS +showsTreeHang wide bars t + = case t of + Tip -> showsBars bars . showString "|\n" + Bin sz x Tip Tip + -> showsBars bars . shows x . showString "\n" + Bin sz x l r + -> showsBars bars . shows x . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + +{-------------------------------------------------------------------- + Assertions +--------------------------------------------------------------------} +-- | /O(n)/. Test if the internal set structure is valid. +valid :: Ord a => Set a -> Bool +valid t + = balanced t && ordered t && validsize t + +ordered t + = bounded (const True) (const True) t + where + bounded lo hi t + = case t of + Tip -> True + Bin sz x l r -> (lo x) && (hi x) && bounded lo (x) hi r + +balanced :: Set a -> Bool +balanced t + = case t of + Tip -> True + Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && + balanced l && balanced r + + +validsize t + = (realsize t == Just (size t)) + where + realsize t + = case t of + Tip -> Just 0 + Bin sz x l r -> case (realsize l,realsize r) of + (Just n,Just m) | n+m+1 == sz -> Just sz + other -> Nothing + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> Set Int +testTree xs = fromList xs +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance (Enum a) => Arbitrary (Set a) where + arbitrary = sized (arbtree 0 maxkey) + where maxkey = 10000 + +arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a) +arbtree lo hi n + | n <= 0 = return Tip + | lo >= hi = return Tip + | otherwise = do{ i <- choose (lo,hi) + ; m <- choose (1,30) + ; let (ml,mr) | m==(1::Int)= (1,2) + | m==2 = (2,1) + | m==3 = (1,1) + | otherwise = (2,2) + ; l <- arbtree lo (i-1) (n `div` ml) + ; r <- arbtree (i+1) hi (n `div` mr) + ; return (bin (toEnum i) l r) + } + + +{-------------------------------------------------------------------- + Valid tree's +--------------------------------------------------------------------} +forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property +forValid f + = forAll arbitrary $ \t -> +-- classify (balanced t) "balanced" $ + classify (size t == 0) "empty" $ + classify (size t > 0 && size t <= 10) "small" $ + classify (size t > 10 && size t <= 64) "medium" $ + classify (size t > 64) "large" $ + balanced t ==> f t + +forValidIntTree :: Testable a => (Set Int -> a) -> Property +forValidIntTree f + = forValid f + +forValidUnitTree :: Testable a => (Set Int -> a) -> Property +forValidUnitTree f + = forValid f + + +prop_Valid + = forValidUnitTree $ \t -> valid t + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Bool +prop_Single x + = (insert x empty == singleton x) + +prop_InsertValid :: Int -> Property +prop_InsertValid k + = forValidUnitTree $ \t -> valid (insert k t) + +prop_InsertDelete :: Int -> Set Int -> Property +prop_InsertDelete k t + = not (member k t) ==> delete k (insert k t) == t + +prop_DeleteValid :: Int -> Property +prop_DeleteValid k + = forValidUnitTree $ \t -> + valid (delete k (insert k t)) + +{-------------------------------------------------------------------- + Balance +--------------------------------------------------------------------} +prop_Join :: Int -> Property +prop_Join x + = forValidUnitTree $ \t -> + let (l,r) = split x t + in valid (join x l r) + +prop_Merge :: Int -> Property +prop_Merge x + = forValidUnitTree $ \t -> + let (l,r) = split x t + in valid (merge l r) + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionValid :: Property +prop_UnionValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (union t1 t2) + +prop_UnionInsert :: Int -> Set Int -> Bool +prop_UnionInsert x t + = union t (singleton x) == insert x t + +prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: Set Int -> Set Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == union t2 t1) + + +prop_DiffValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (difference t1 t2) + +prop_Diff :: [Int] -> [Int] -> Bool +prop_Diff xs ys + = toAscList (difference (fromList xs) (fromList ys)) + == List.sort ((List.\\) (nub xs) (nub ys)) + +prop_IntValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (intersection t1 t2) + +prop_Int :: [Int] -> [Int] -> Bool +prop_Int xs ys + = toAscList (intersection (fromList xs) (fromList ys)) + == List.sort (nub ((List.intersect) (xs) (ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [0..n::Int] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == toList (fromList xs)) +-} diff --git a/patch.icons b/patch.icons new file mode 100644 --- /dev/null +++ b/patch.icons @@ -0,0 +1,11 @@ +--- Blobs.app/Contents/Info.plist Tue Jul 26 15:24:41 2005 ++++ Blobs.app/Contents/Info.plist Tue Jul 26 15:16:53 2005 +@@ -11,7 +11,7 @@ + CFBundleExecutable + Blobs + CFBundleIconFile +- wxmac.icns ++ Blobs.icns + CFBundleName + Blobs + CFBundlePackageType diff --git a/simple.blobpalette b/simple.blobpalette new file mode 100644 --- /dev/null +++ b/simple.blobpalette @@ -0,0 +1,55 @@ + Palette + [ ("circle" + , ( Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 1 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 128 200 128 + } + , shapeRadius = 0.5 } + , Just [] )) + , ("square" + , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 2 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 200 128 200 + } + , shapePerimeter = [ DoublePoint -0.5 -0.5 + , DoublePoint 0.5 -0.5 + , DoublePoint 0.5 0.5 + , DoublePoint -0.5 0.5 ] } + , Just [] )) + , ("triangle left" + , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 128 200 200 + } + , shapePerimeter = [ DoublePoint -0.5 0 + , DoublePoint 0.5 -0.5 + , DoublePoint 0.5 0.5 ] } + , Just [] )) + , ("triangle right" + , ( Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 128 200 200 + } + , shapePerimeter = [ DoublePoint -0.5 -0.5 + , DoublePoint -0.5 0.5 + , DoublePoint 0.5 0.0 ] } + , Just [] )) + , ("wire" + , ( Composite { shapeSegments = + [ Lines { shapeStyle = ShapeStyle + { styleStrokeWidth = 2 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 128 128 128 + } + , shapePerimeter = [ DoublePoint 0.0 -0.5 + , DoublePoint -0.2 0.5 ] } + , Lines { shapeStyle = ShapeStyle + { styleStrokeWidth = 2 + , styleStrokeColour = RGB 0 0 0 + , styleFill = RGB 128 128 128 + } + , shapePerimeter = [ DoublePoint 0.2 -0.5 + , DoublePoint 0.0 0.5 ] } + ] } + , Just [] )) + ] diff --git a/src/Colors.hs b/src/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Colors.hs @@ -0,0 +1,86 @@ +module Colors where + +import Graphics.UI.WX +import Text.Parse + + +-- Different spelling of colour/color to distinguish local/wx datatypes. +data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read) + + +instance Parse Colour where + parse = do { isWord "RGB" + ; return RGB `apply` parse `apply` parse `apply` parse + } + +-- translate local to wx +wxcolor :: Colour -> Color +wxcolor (RGB r g b) = rgb r g b + +nodeColor, labelBackgroundColor, evidenceColor, evidenceHatchColor, + wrongProbabilitiesColor, paneBackgroundColor, activeSelectionColor, + inactiveSelectionColor :: Colour +nodeColor = lightBlue +evidenceColor = lightYellow +evidenceHatchColor = licorice +labelBackgroundColor = lightYellow +paneBackgroundColor = coconut +activeSelectionColor = licorice +inactiveSelectionColor = lightGrey +wrongProbabilitiesColor = lightRed + +testSelectionTestColor, testSelectionTargetColor :: Colour +testSelectionTestColor = RGB 0 255 0 +testSelectionTargetColor = RGB 255 0 0 + +lightYellow, lightBlue, lightRed, lightGrey, pink :: Colour +lightYellow = RGB 236 236 169 +lightBlue = RGB 200 255 255 +lightGrey = RGB 150 150 150 +lightRed = RGB 255 200 200 +pink = RGB 255 200 200 + +systemGrey :: Color -- wx type +systemGrey = colorSystem Color3DFace + +licorice, coconut :: Colour -- names black and white already taken by wx +licorice = RGB 0 0 0 +coconut = RGB 255 255 255 + +darkGreen, darkBlue, violet, indigo, darkRed, darkMagenta, darkOrange, + orange, lightPink, purple, lightGreen, mediumPurple, darkViolet, gray, + darkGrey, darkGray, lightGray, silver, whiteSmoke, aqua, teal, maroon, + olive, sienna, brown, fuchsia, turquoise, orangeRed, gold,darkSlateGray + :: Colour +darkGreen = RGB 0 100 0 +darkBlue = RGB 0 0 139 +violet = RGB 238 130 238 +indigo = RGB 75 0 130 +darkRed = RGB 139 0 0 +darkMagenta = RGB 139 0 139 +darkOrange = RGB 255 140 0 +orange = RGB 255 165 0 +lightPink = RGB 255 182 193 +purple = RGB 128 0 128 +lightGreen = RGB 144 238 144 +mediumPurple = RGB 147 112 219 +darkViolet = RGB 148 0 211 + +gray = RGB 128 128 128 +darkGrey = RGB 169 169 169 -- lighter than grey? +darkGray = RGB 169 169 169 +lightGray = RGB 211 211 211 +silver = RGB 192 192 192 +whiteSmoke = RGB 245 245 245 + +aqua = RGB 0 255 255 +teal = RGB 0 128 128 +maroon = RGB 128 0 0 +olive = RGB 128 128 0 +sienna = RGB 160 82 45 +brown = RGB 165 42 42 +fuchsia = RGB 255 0 255 +turquoise = RGB 64 224 208 +orangeRed = RGB 255 69 0 +gold = RGB 255 215 0 +darkSlateGray = RGB 47 79 79 diff --git a/src/Common.hs b/src/Common.hs new file mode 100644 --- /dev/null +++ b/src/Common.hs @@ -0,0 +1,159 @@ +module Common (module Common {-, module IOExts-}, module Colors) where + +import Colors +-- import IOExts(trace) +import Debug.Trace (trace) +import qualified Data.IntMap as IntMap +import Char(isSpace) +import GHC.Float(formatRealFloat, FFFormat(FFFixed)) +import List + +-- | return a list of all cartesian products for a list of lists +-- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]] +products :: [[a]] -> [[a]] +products [] = [[]] +products (xs:xss) = [ x:prod | x <- xs, prod <- products xss] + +trees :: Show a => String -> a -> a +trees msg a = trace ("{" ++ msg ++ ":" ++ show a ++ "}") a + +foreach :: Monad m => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +foreach_ :: Monad m => [a] -> (a -> m b) -> m () +foreach_ list fun = do + mapM fun list + return () + +ifJust :: Monad m => Maybe a -> (a -> m b) -> m () +ifJust ma f = + case ma of + Nothing -> return () + Just a -> do { f a; return () } + +internalError :: String -> String -> String -> a + +internalError moduleName functionName errorString = + error (moduleName ++ "." ++ functionName ++ ": " ++ errorString) + +parseDouble :: String -> Maybe Double +parseDouble string = + case reads (commasToDots . trim $ string) of + ((double, []):_) -> Just double + _ -> Nothing + where + commasToDots = map (\c -> if c == ',' then '.' else c) + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | A NumberMap maps integers to integers +type NumberMap = IntMap.IntMap Int + +-- | A NumberMap can be inverted (keys become values and values become keys) +invertMap :: NumberMap -> NumberMap +invertMap theMap = + let list = IntMap.toList theMap + invertedList = map (\(x, y) -> (y, x)) list + in IntMap.fromList invertedList + +-- | commasAnd combines a list of strings to one string by placing +-- commas in between and the word "and" just before the last element +commasAnd :: [String] -> String +commasAnd [] = "" +commasAnd [x] = x +commasAnd [x, y] = x ++ " and " ++ y +commasAnd (x:xs) = x ++ ", " ++ commasAnd xs + + +-- TODO: is niceFloat 2 0.0001 = "0.0" correct? (as opposed to "0.00") +-- | niceFloat prints a floating-point value with maximum +-- number of decimals +niceFloat :: Int -> Double -> String +niceFloat nrOfDigits f = + let s = formatRealFloat FFFixed (Just nrOfDigits) f + s' = reverse s -- s -- dropWhile (== '0') (reverse s) + s'' = if head s' == '.' then '0':s' else s' + in reverse s'' + +-- | niceFloatFix prints a floating-point value with fixed +-- number of decimals +niceFloatFix :: Int -> Double -> String +niceFloatFix nrOfDigits f = + let s = formatRealFloat FFFixed (Just nrOfDigits) f + in if head s == '.' then '0':s else s + +-- Compute the average of a list of fractionals, with average [] equal to 0. +average :: Fractional a => [a] -> a +average [] = 0 +average xs = (sum xs) / fromIntegral (length xs) + +-- | updateList changes the element at the given zero-based index in a list +-- Example: updateList 2 "yes" ["no","maybe","often","always"] ==> +-- ["no","maybe","yes","always"] +updateList :: Int -> a -> [a] -> [a] +updateList i x l = take i l ++ [x] ++ drop (i+1) l + +-- | groups splits a list into groups of given length. The +-- last group might be shorter. +-- Example: groups 3 [1..10] ==> [[1,2,3],[4,5,6],[7,8,9],[10]] +groups :: Int -> [a] -> [[a]] +groups _ [] = [] +groups n xs = let (col, rest) = splitAt n xs + in col: groups n rest + +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) + +-- remove the extension from a file name (or path). +removeExtension :: String -> String +removeExtension filename = + case break (=='.') $ reverse filename of + (_ , _ {- dot -}:properName) -> reverse properName + (_ , []) -> filename + +tabDelimited :: [[String]] -> String +tabDelimited = unlines . map (concat . intersperse "\t") + +singleton :: a -> [a] +singleton x = [x] + +-- | a version of Prelude.lookup that fails when the element is not present in the assoc-list +unsafeLookup :: (Show k, Eq k) => k -> [(k,v)] -> v +unsafeLookup x assocs = + case lookup x assocs of + Just v -> v + Nothing -> internalError "Common" "unsafeLookup" ("element " ++ show x ++ " not in list.") + +-- | a version of Prelude.elemIndex that fails when the element is not present in the list +unsafeElemIndex :: (Show a, Eq a) => a -> [a] -> Int +unsafeElemIndex x xs = + case elemIndex x xs of + Just i -> i + Nothing -> internalError "Common" "unsafeElemIndex" ("element " ++ show x ++ " not in list") + +-- Approximately equals +(~=) :: Double -> Double -> Bool +(~=) d1 d2 = abs (d1 - d2) < 0.000001 + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +safeIndex :: String -> [a] -> Int -> a +safeIndex msg xs i + | i >= 0 && i < length xs = xs !! i + | otherwise = internalError "Common" "safeIndex" msg + +-- reorderList [0,2,1] "hoi" ==> "hio" +reorderList :: Show a => [Int] -> [a] -> [a] +reorderList order xs + | sort order /= [0..length xs-1] = + internalError "Common" "reorderList" ("order = " ++ show order ++ ", list = " ++ show xs) + | otherwise = + [ xs !! i | i <- order ] diff --git a/src/CommonIO.hs b/src/CommonIO.hs new file mode 100644 --- /dev/null +++ b/src/CommonIO.hs @@ -0,0 +1,339 @@ +module CommonIO where + +import Math +import Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey) +import SafetyNet + +import Graphics.UI.WX +import Graphics.UI.WXCore +import List(elemIndex) +import System.Directory +import System.IO + +ignoreResult :: IO a -> IO () +ignoreResult action = do { action; return () } + +-- | Writes file to disk. If writing fails, an error +-- dialog is shown and False is returned +safeWriteFile :: Window a -> String -> String -> IO Bool +safeWriteFile parentWindow fileName contents = + do{ let tmpName = fileName ++ ".tmp" + + ; -- try to write to .tmp file + ; writeOkay <- + catch + (do { writeFile tmpName contents + ; return True + }) + (\ioExc -> + do{ errorDialog parentWindow "Save failed" + ( "Saving " ++ fileName ++ " failed.\n\n" + ++ "Technical reason: " ++ show ioExc ++ "\n\n" + ++ "Tip: do you have write permissions and enough disk space?" + ) + ; return False + } + ) + ; if not writeOkay then + return False + else + do{ -- remove old file if it exists and then rename .tmp to the real name + ; catch (do { exists <- doesFileExist fileName + ; when exists $ removeFile fileName + ; renameFile tmpName fileName + ; return True + }) + (\ioExc -> + do{ errorDialog parentWindow "Save failed" + ( "The file has been saved to " ++ show tmpName ++ "\nbut " + ++ "renaming it to " ++ show fileName ++ " failed.\n\n" + ++ "Technical reason: " ++ show ioExc + ) + ; return False + } + ) + }} + +strictReadFile :: String -> IO String +strictReadFile fname = + do{ contents <- readFile fname + ; seq (length contents) $ return contents -- force reading of entire file + } + +data TextCtrlSize = SingleLine | MultiLine + +myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool + -> IO (Maybe String) +myTextDialog parentWindow size dialogTitle initial selectAll = + do{ d <- dialog parentWindow [text := dialogTitle] + ; textInput <- (case size of SingleLine -> textEntry; + MultiLine -> textCtrl) + d [ alignment := AlignLeft, text := initial ] + ; ok <- button d [text := "Ok"] + ; can <- button d [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [layout := column 5 [ fill $ widget textInput + , floatBottomRight $ row 5 [widget ok, widget can] + ] + -- ,clientSize := case size of SingleLine -> sz 300 40 + -- MultiLine -> sz 500 200 + ,area := case size of SingleLine -> rect (pt 50 50) (sz 300 80) + MultiLine -> rect (pt 50 50) (sz 500 250) + ] + ; when (selectAll) $ do textCtrlSetSelection textInput 0 250 + ; when (not selectAll) $ do textCtrlSetInsertionPointEnd textInput + set d [ visible := True ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do theText <- get textInput text + stop (Just theText)] + set can [on command := safetyNet parentWindow $ stop Nothing] + } + +-- Dialog for selecting a multiple Strings (0 or more) +-- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings +multiSelectionDialog :: Window a -> String -> [String] -> [String] + -> IO (Maybe [String]) +multiSelectionDialog parentWindow dialogTitle strings initialSelection = + do{ d <- dialog parentWindow + [ text := dialogTitle + , resizeable := True + ] + ; p <- panel d [] + ; theListBox <- multiListBox p + [ items := strings + , selections := + [ case maybeIndex of + Nothing -> internalError "CommonIO" "multiSelectionDialog" + ( "initial selection " ++ show s + ++ " can not be found in " ++ show strings ) + Just i -> i + | s <- initialSelection + , let maybeIndex = elemIndex s strings + ] + ] + ; selectAll <- button p + [ text := "Select all" + , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ] + ] + ; selectNone <- button p + [ text := "Select none" + , on command := safetyNet parentWindow $ set theListBox [ selections := [] ] + ] + ; ok <- button p [text := "Ok"] + ; can <- button p [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [ layout := container p $ + column 10 [ vfill $ widget theListBox + , row 5 [widget selectAll, widget selectNone, widget ok, widget can] + ] + , clientSize := sz 300 400 + ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do indices <- get theListBox selections + stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))] + set can [on command := safetyNet parentWindow $ + stop Nothing] + } + +-- Dialog for selecting a single String +-- Returns Nothing if Cancel was pressed, otherwise it returns the selected string +singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String) + -> IO (Maybe String) +singleSelectionDialog _ _ [] _ = + internalError "CommonIO" "singleSelectionDialog" "no strings" +singleSelectionDialog parentWindow dialogTitle strings initialSelection = + do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ] + ; p <- panel d [] + ; theListBox <- singleListBox p [ items := strings, selection := 0] + ; ifJust initialSelection $ \selString -> + case elemIndex selString strings of + Nothing -> internalError "CommonIO" "singleSelectionDialog" + ( "initial selection " ++ show selString + ++ " can not be found in " ++ show strings ) + Just i -> set theListBox [ selection := i ] + ; ok <- button p [text := "Ok"] + ; can <- button p [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [ layout := container p $ + column 10 [ vfill $ widget theListBox + , row 5 [widget ok, widget can] + ] + , clientSize := sz 300 400 + ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do index <- get theListBox selection + stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))] + set can [on command := safetyNet parentWindow $ + stop Nothing] + } + +-- | Fill a grid from a list of lists of texts. Each list inside the +-- big list represents a row. Also set the given number or rows and +-- columns to be header: grey background and not editable. +-- This function assumes that the normal spreadsheet-like grid header row +-- and column have been made invisible. +fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO () +fillGridFromList _ _ _ [] = return () +fillGridFromList theGrid nrHeaderRows nrHeaderCols list = + do{ nrOfCols <- gridGetNumberCols theGrid + ; nrOfRows <- gridGetNumberRows theGrid + ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $ + internalError "Common" "fillGridFromList" "grid is not big enough" + ; sequence_ . concat $ + [ [ do{ gridSetCellValue theGrid rowNr colNr txt + ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols + ; gridSetCellBackgroundColour theGrid rowNr colNr + (if isHeaderCell then systemGrey else white) + ; gridSetReadOnly theGrid rowNr colNr isHeaderCell + } + | (txt, colNr) <- zip theRow [0..] + ] + | (theRow, rowNr) <- zip list [0..] + ] + } + +-- | Export some data (a list of lists of strings) to a tab delimited +-- file. The user is asked to choose a location +exportToTabFile :: Window a -> String -> String -> [[String]] -> IO () +exportToTabFile parentWindow description fileName theData = + do { mFilename <- fileSaveDialog + parentWindow + False -- remember current directory + True -- overwrite prompt + ("Export " ++ description) + [("Tab delimited files",["*.txt"])] + "" -- directory + fileName + ; ifJust mFilename $ \filename -> + ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData)) + } + +getScreenPPI :: IO Size +getScreenPPI = + do{ dc <- screenDCCreate + ; s <- dcGetPPI dc + ; screenDCDelete dc + ; return s + } + +screenToLogicalPoint :: Size -> Point -> DoublePoint +screenToLogicalPoint ppi p = + DoublePoint (screenToLogicalX ppi (pointX p)) + (screenToLogicalY ppi (pointY p)) + +logicalToScreenPoint :: Size -> DoublePoint -> Point +logicalToScreenPoint ppi doublePoint = + pt (logicalToScreenX ppi (doublePointX doublePoint)) + (logicalToScreenY ppi (doublePointY doublePoint)) + +screenToLogicalX :: Size -> Int -> Double +screenToLogicalX ppi x = + fromIntegral x / (fromIntegral (sizeW ppi) / 2.54) + +logicalToScreenX :: Size -> Double -> Int +logicalToScreenX ppi x = + truncate (x * fromIntegral (sizeW ppi) / 2.54) + +screenToLogicalY :: Size -> Int -> Double +screenToLogicalY ppi y = + fromIntegral y / (fromIntegral (sizeH ppi) / 2.54) + +logicalToScreenY :: Size -> Double -> Int +logicalToScreenY ppi y = + truncate (y * fromIntegral (sizeH ppi) / 2.54) + +-- Create a grid of which the standard labels (A,B,C... for columns +-- and 1,2,3... for rows) are invisible +mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ()) +mkNoLabelGrid thePanel nrOfRows nrOfCols = + do{ theGrid <- gridCreate thePanel idAny rectNull 0 + ; gridCreateGrid theGrid nrOfRows nrOfCols 0 + ; gridSetColLabelSize theGrid 0 + ; gridSetRowLabelSize theGrid 0 + ; return theGrid + } + +resizeGrid :: Grid () -> Int -> Int -> IO () +resizeGrid theGrid nrOfRows nrOfCols = + do{ oldNrOfRows <- gridGetNumberRows theGrid + ; oldNrOfCols <- gridGetNumberCols theGrid + ; when (nrOfRows > oldNrOfRows) . ignoreResult $ + gridAppendRows theGrid (nrOfRows - oldNrOfRows) False + ; when (nrOfRows < oldNrOfRows) . ignoreResult $ + gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False + ; when (nrOfCols > oldNrOfCols) . ignoreResult $ + gridAppendCols theGrid (nrOfCols - oldNrOfCols) False + ; when (nrOfCols < oldNrOfCols) . ignoreResult $ + gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False + } + +-- | Get the position of a frame, if the frame is minimized or maximized +-- it is restored to its normal size first. Otherwise, you get +-- (-32000, -32000) for a minimized window :-) +safeGetPosition :: Frame a -> IO (Int, Int) +safeGetPosition f = + do{ -- isMax <- frameIsMaximized f + isMax <- frameIsFullScreen f + -- ; isMin <- frameIsIconized f + -- ; when (isMax || isMin) $ frameRestore f + ; when (isMax) $ frameRestore f + ; p <- get f position + ; return (pointX p, pointY p) + } + +-- Show a dialog with a grid and a save button +gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]] + -> IO () -> IO () +gridDialogWithSave parentWindow title maybeNote matrixContents saveAction = + do{ + -- Create dialog and panel + ; theDialog <- dialog parentWindow + [ text := title + , resizeable := True + ] + ; p <- panel theDialog [] + + -- Create and fill grid + ; theGrid <- mkNoLabelGrid p height width + ; gridEnableEditing theGrid False + ; fillGridFromList theGrid 0 0 matrixContents + ; gridAutoSizeColumns theGrid False + + -- File menu + ; saveButton <- button p + [ text := "Save as..." + , on command := safetyNet parentWindow $ saveAction + ] + + -- Dialog layout + ; set theDialog + [ layout := minsize (sz 600 400) $ column 5 + ( case maybeNote of + Just note -> [ hfill $ label note ] + Nothing -> [] + ++ [ container p $ + column 5 [ fill $ widget theGrid + , row 0 [ widget saveButton, glue ] + ] + ] + ) + , visible := True + ] + } + where + width = maximum . map length $ matrixContents + height = length matrixContents + + +-- | Using bootstrapUI, a record containing all widgets and variables can be created +-- at the end of the create function, but still referred to before creation +-- NOTE: widgets should not be referred to in a strict way because this will +-- cause a loop +bootstrapUI :: (uistate -> IO uistate) -> IO () +bootstrapUI fIO = + do { fixIO fIO + ; return () + } diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -0,0 +1,26 @@ +module Constants where + +import Graphics.UI.WX +import Colors + +kSELECTED_WIDTH :: Int +kSELECTED_WIDTH = 3 + +kEDGE_CLICK_RANGE, kNODE_RADIUS, kARROW_SIZE:: Double +kEDGE_CLICK_RANGE = 0.2 +kNODE_RADIUS = 0.5 +kARROW_SIZE = 0.3 + +kSELECTED_OPTIONS :: [Prop (DC ())] +kSELECTED_OPTIONS = [ penWidth := kSELECTED_WIDTH ] + +kNodeLabelColour :: Colour +kNodeLabelColour = licorice + +kNodeInfoColour :: Colour +kNodeInfoColour = darkViolet + +kEdgeInfoColour :: Colour +kEdgeInfoColour = orangeRed + + diff --git a/src/ContextMenu.hs b/src/ContextMenu.hs new file mode 100644 --- /dev/null +++ b/src/ContextMenu.hs @@ -0,0 +1,186 @@ +module ContextMenu + ( canvas, edge, node, via ) where + +import State +import Network +import Document +import NetworkControl +import SafetyNet +import CommonIO +import Math (DoublePoint) +import qualified PersistentDocument as PD +import Palette +import InfoKind +import Text.Parse + +import Graphics.UI.WX +import Graphics.UI.WXCore(windowGetMousePosition) + +-- | Context menu for empty area of canvas +canvas :: (InfoKind n g, Show g, Parse g, Descriptor g) => + Frame () -> State g n e -> IO () +canvas theFrame state = + do{ contextMenu <- menuPane [] + ; menuItem contextMenu + [ text := "Add node (shift-click)" + , on command := safetyNet theFrame $ addNodeItem theFrame state + ] + ; g <- fmap (getGlobalInfo . getNetwork) + (PD.getDocument =<< getDocument state) + ; menuItem contextMenu + [ text := ("Edit "++descriptor g) + , on command := safetyNet theFrame $ changeGlobalInfo theFrame state + ] + + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +addNodeItem :: (InfoKind n g) => Frame () -> State g n e -> IO () +addNodeItem theFrame state = + do{ mousePoint <- windowGetMousePosition theFrame + ; ppi <- getScreenPPI + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; createNode doubleMousePoint state + } + +-- | Context menu for an edge +edge :: (InfoKind n g, InfoKind e g) => + EdgeNr -> Frame () -> DoublePoint -> State g n e -> IO () +edge edgeNr theFrame mousepoint state = + do{ contextMenu <- menuPane [] + + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + theEdge = getEdge edgeNr network + fromPort = getEdgeFromPort theEdge + toPort = getEdgeToPort theEdge + + ; menuItem contextMenu + [ text := "Add control point" + , on command := safetyNet theFrame $ createVia mousepoint state + ] + ; menuItem contextMenu + [ text := "Delete edge (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; menuItem contextMenu + [ text := "Edit info (i)" + , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state + ] + ; menuLine contextMenu + ; menuItem contextMenu + [ text := "from port "++show fromPort + ] + ; menuItem contextMenu + [ text := "to port "++show toPort + ] + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +-- | Context menu for a 'via' point +via :: Frame () -> State g n e -> IO () +via theFrame state = + do{ contextMenu <- menuPane [] + ; menuItem contextMenu + [ text := "Delete control point (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +-- | Context menu for a node +node :: (InfoKind n g, InfoKind e g) => Int -> Frame () -> State g n e -> IO () +node nodeNr theFrame state = + do{ contextMenu <- menuPane [] + + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + theNode = getNode nodeNr network + labelAbove = getNameAbove theNode + palette = getPalette network + theShape = getShape theNode + theInfo = getInfo theNode + (i,o) = maybe (0,0) id $ getArity theNode + + ; menuItem contextMenu + [ text := "Rename (r)" + , on command := safetyNet theFrame $ renameNode theFrame state + ] + ; menuItem contextMenu + [ text := "Edit info (i)" + , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state + ] + ; menuItem contextMenu + [ text := "Change arity (in/"++show i++", out/"++show o++")" + , on command := safetyNet theFrame $ reArityNode theFrame state + ] + ; menuItem contextMenu + [ text := "Delete (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; menuLine contextMenu + + ; menuItem contextMenu + [ text := "Label position:" ] + ; menuItem contextMenu + [ text := " above (up arrow)" + , checkable := True + , checked := labelAbove + , on command := safetyNet theFrame $ changeNamePosition True state + ] + ; menuItem contextMenu + [ text := " below (down arrow)" + , checkable := True + , checked := not labelAbove + , on command := safetyNet theFrame $ changeNamePosition False state + ] +-- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ] + + ; menuLine contextMenu + + -- work out whether to keep the info-field whilst changing shape + -- (change if shape's default; keep if different i.e. user has changed it) + ; let keepInfo = case theShape of + Left n -> case lookup n (shapes palette) of + Nothing -> const theInfo + Just (_,Nothing) -> const theInfo + Just (_,Just i) -> if i==theInfo then id + else const theInfo + Right _ -> const theInfo + ; menuItem contextMenu + [ text := "Shape:" ] + ; mapM_ (shapeItem theShape keepInfo contextMenu) (shapes palette) + ; otherShape theShape contextMenu + + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + + } + where + shapeItem curShape keepInfo contextMenu (name,(_shape,info)) = + menuItem contextMenu + [ text := (" "++name) + , checkable := True + , checked := case curShape of { Left n -> n==name; Right _ -> False; } + , on command := safetyNet theFrame $ changeNodeShape name newinfo state + ] + where newinfo = keepInfo (maybe blank id info) + otherShape curShape contextMenu = + case curShape of + Left _ -> return () + Right _ -> do{ menuItem contextMenu + [ text := "Other shape" + , checkable := True + , checked := True + ] + ; return () + } diff --git a/src/DisplayOptions.hs b/src/DisplayOptions.hs new file mode 100644 --- /dev/null +++ b/src/DisplayOptions.hs @@ -0,0 +1,16 @@ +module DisplayOptions where + +import List ((\\)) + +type ShowInfo = [What] +data What = GlobalInfo | NodeLabel | NodeInfo | EdgeInfo deriving (Eq) + +data DisplayOptions = DP + { dpShowInfo :: ShowInfo + } + +standard :: DisplayOptions +standard = DP [GlobalInfo, NodeLabel, NodeInfo, EdgeInfo] + +toggle :: What -> DisplayOptions -> DisplayOptions +toggle w (DP opts) = DP (if w `elem` opts then opts\\[w] else w:opts) diff --git a/src/Document.hs b/src/Document.hs new file mode 100644 --- /dev/null +++ b/src/Document.hs @@ -0,0 +1,94 @@ +{-| Module : Document + Maintainer : afie@cs.uu.nl + + This module contains functions to create documents + and to get and set components of the Document datatype. +-} + +module Document + ( Document + , Selection(..) + , empty + , getNetwork, setNetwork, unsafeSetNetwork + , getSelection, setSelection + + , updateNetwork, updateNetworkEx + ) where + +import qualified Network +import InfoKind +import Math + +{-------------------------------------------------- + -- TYPES + --------------------------------------------------} + +data Document g n e = Document + { docNetwork :: Network.Network g n e + , docSelection :: Selection + } deriving Show + +data Selection + = NoSelection + | NodeSelection Int + | EdgeSelection Int + | ViaSelection Int Int + | MultipleSelection (Maybe (DoublePoint,DoublePoint)) [Int] [(Int,Int)] + -- DoublePoint pair is for displaying dragged selection rectangle + deriving (Show, Read, Eq) + +{-------------------------------------------------- + -- CREATION + --------------------------------------------------} + + +-- | An empty document +empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e +empty g n e = + Document + { docNetwork = Network.empty g n e + , docSelection = NoSelection + } + +{-------------------------------------------------- + -- GETTERS + --------------------------------------------------} + +getNetwork :: Document g n e -> Network.Network g n e +getSelection :: Document g n e -> Selection + +getNetwork doc = docNetwork doc +getSelection doc = docSelection doc + +{-------------------------------------------------- + -- SETTERS + --------------------------------------------------} + +-- | setNetwork clears the selection because the node may not exist +-- in the new network +setNetwork :: Network.Network g n e -> Document g n e -> Document g n e +setNetwork theNetwork doc = + doc { docNetwork = theNetwork + , docSelection = NoSelection + } + +setSelection :: Selection -> Document g n e -> Document g n e +setSelection theSelection doc = doc { docSelection = theSelection } + +updateNetwork :: (Network.Network g n e -> Network.Network g n e) + -> Document g n e -> Document g n e +updateNetwork networkFun doc + = unsafeSetNetwork (networkFun (getNetwork doc)) + $ doc + +updateNetworkEx :: (Network.Network g n e -> (b, Network.Network g n e)) + -> Document g n e -> (b, Document g n e) +updateNetworkEx networkFun doc = + let (result, newNetwork) = networkFun (getNetwork doc) + in ( result + , unsafeSetNetwork newNetwork doc + ) + +-- | Doesn't clear the selection +unsafeSetNetwork :: Network.Network g n e -> Document g n e -> Document g n e +unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork } diff --git a/src/GUIEvents.hs b/src/GUIEvents.hs new file mode 100644 --- /dev/null +++ b/src/GUIEvents.hs @@ -0,0 +1,192 @@ +module GUIEvents where + +import List (nub,(\\)) +import NetworkView(clickedNode, clickedEdge, clickedVia) +import NetworkControl +import State +import Common +import CommonIO +import Document +import qualified ContextMenu +import qualified PersistentDocument as PD +import InfoKind +import Text.Parse + +import Graphics.UI.WX +import Graphics.UI.WXCore + +mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => + Bool -> Point -> Frame () -> State g n e -> IO () +mouseDown leftButton mousePoint theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Nothing -> + case clickedVia doubleMousePoint network of + Nothing -> + case clickedEdge doubleMousePoint network of + Nothing -> + if leftButton then + pickupArea doubleMousePoint state + else ContextMenu.canvas theFrame state + Just edgeNr -> + if leftButton then + selectEdge edgeNr state + else + do{ selectEdge edgeNr state + ; ContextMenu.edge edgeNr theFrame doubleMousePoint state + } + Just (edgeNr,viaNr) -> + if leftButton then + case getSelection doc of + MultipleSelection _ ns vs + | (edgeNr,viaNr) `elem` vs-> + pickupMultiple ns vs doubleMousePoint state + _ -> pickupVia edgeNr viaNr doubleMousePoint state + else + do{ selectVia edgeNr viaNr state + ; ContextMenu.via theFrame state + } + Just nodeNr -> + if leftButton then + case getSelection doc of + MultipleSelection _ ns vs | nodeNr `elem` ns -> + pickupMultiple ns vs doubleMousePoint state + _ -> pickupNode nodeNr doubleMousePoint state + else + do{ selectNode nodeNr state + ; ContextMenu.node nodeNr theFrame state + } + } + +leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) => + Point -> State g n e -> IO () +leftMouseDownWithShift mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Nothing -> + case clickedEdge doubleMousePoint network of + Nothing -> + -- shift click in empty area = create new node + createNode doubleMousePoint state + Just i -> + selectEdge i state -- shift click on edge = select + Just j -> do -- shift click on node = create edge (if possible) + case getSelection doc of + NodeSelection i | i /= j -> + createEdge i j state + _ -> selectNode j state + } + +leftMouseDownWithMeta :: (InfoKind n g, InfoKind e g) => + Point -> State g n e -> IO () +leftMouseDownWithMeta mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Just j -> do -- meta click on node = toggle whether node in selection + case getSelection doc of + NodeSelection i + | i == j -> selectNothing state + | i /= j -> selectMultiple Nothing (nub [i,j]) [] state + ViaSelection e v -> selectMultiple Nothing [j] [(e,v)] state + MultipleSelection _ ns vs + | j `elem` ns -> selectMultiple Nothing (ns\\[j]) vs state + | otherwise -> selectMultiple Nothing (j:ns) vs state + _ -> selectNode j state + Nothing -> + case clickedVia doubleMousePoint network of + Just via@(e,v) -> -- meta click on via point = toggle inclusion + case getSelection doc of + NodeSelection i -> selectMultiple Nothing [i] [(e,v)] state + ViaSelection e' v' + | e==e' && v==v' -> selectNothing state + | otherwise -> selectMultiple Nothing [] [via,(e',v')] + state + MultipleSelection _ ns vs + | via `elem` vs -> selectMultiple Nothing ns (vs\\[via]) + state + | otherwise -> selectMultiple Nothing ns (via:vs) state + _ -> selectVia e v state + Nothing -> return () + } + +leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO () +leftMouseDrag mousePoint canvas state = + do{ dragging <- getDragging state + ; ppi <- getScreenPPI + ; ifJust dragging $ \_ -> + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case getSelection doc of + NodeSelection nodeNr -> + dragNode nodeNr doubleMousePoint canvas state + ViaSelection edgeNr viaNr -> + dragVia edgeNr viaNr doubleMousePoint canvas state + MultipleSelection Nothing ns vs -> + dragMultiple ns vs doubleMousePoint canvas state + MultipleSelection _ _ _ -> + dragArea doubleMousePoint state + _ -> return () + } + } + +leftMouseUp :: Point -> State g n e -> IO () +leftMouseUp mousePoint state = + do{ dragging <- getDragging state + ; ppi <- getScreenPPI + ; ifJust dragging $ \(hasMoved, offset) -> + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case getSelection doc of + NodeSelection nodeNr -> + dropNode hasMoved nodeNr offset doubleMousePoint state + ViaSelection edgeNr viaNr -> + dropVia hasMoved edgeNr viaNr offset doubleMousePoint state + MultipleSelection Nothing ns vs -> + dropMultiple hasMoved ns vs offset doubleMousePoint state + MultipleSelection _ _ _ -> + dropArea offset doubleMousePoint state + _ -> return () + } + } + +deleteKey :: State g n e -> IO () +deleteKey state = + deleteSelection state + +backspaceKey :: State g n e -> IO () +backspaceKey state = + deleteSelection state + +f2Key :: Frame () -> State g n e -> IO () -- due for demolition +f2Key theFrame state = + renameNode theFrame state + +pressRKey :: Frame () -> State g n e -> IO () +pressRKey theFrame state = + renameNode theFrame state + +pressIKey :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO () +pressIKey theFrame state = + reinfoNodeOrEdge theFrame state + +upKey :: State g n e -> IO () +upKey state = + changeNamePosition True state + +downKey :: State g n e -> IO () +downKey state = + changeNamePosition False state diff --git a/src/InfoKind.hs b/src/InfoKind.hs new file mode 100644 --- /dev/null +++ b/src/InfoKind.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module InfoKind where + +import Text.Parse +--import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.XmlContent.Haskell + +-- | The @InfoKind@ class is a predicate that ensures we can always create +-- at least a blank (empty) information element, that we can read and +-- write them to/from the user, and that there exists some method of +-- determining the correctness of the value (completeness/consistency etc) +-- against some global type. +class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where + blank :: a + check :: String -> g -> a -> [String] -- returns warnings + -- ^ first arg is container label for error reporting. + -- second arg is global value + +-- A basic instance representing "no info" +instance InfoKind () () where + blank = () + check _ _ () = [] +-- Assume that info is mandatory, but not supplied a priori. +instance InfoKind a b => InfoKind (Maybe a) b where + blank = Nothing + check n _ Nothing = ["No info value stored with "++n] + check n g (Just a) = check n g a + +-- A "showType"-style class. Descriptor should always ignore its argument, +-- and return a constant string describing the type instead. +class (Show a) => Descriptor a where + descriptor :: a -> String + descriptor _ = "type descriptor was left undefined" +instance Descriptor () where + descriptor _ = "null global info type" + +-- ----------------------------------------------- +{- +instance XmlContent () where + toContents = undefined + parseContents = undefined +-} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Main (main, gain) where + +import NetworkUI +import Graphics.UI.WX +import State +import InfoKind + +import Network +import Operations +--import IntMap (IntMap) +import qualified Data.IntMap as IntMap +import List (nub) +import Maybe (fromJust) + +main :: IO () +main = start $ + do{ state <- State.empty + ; NetworkUI.create state () -- global state is just the unit value + undefined -- dummy node state (for typechecker) + undefined -- dummy edge state (for typechecker) + graphOps -- operations available from menu + } + +-- Some basic kinds of info to store in the nodes/edges +instance InfoKind Int () where + blank = 0 + check n _ i | i<0 = ["Number should not be negative in "++n] + | otherwise = [] +instance InfoKind [Int] () where + blank = [] + check _ _ _ = [] + +-- A simple range of operations on a graph network. +graphOps :: GraphOps () [Int] [Int] +graphOps = GraphOps { ioOps = map pureGraphOp + [ ("push numbers one step", onePush) + , ("clear all numbers", revert) ] } + where + onePush (g, nodemap, edgemap) = + (g, IntMap.mapWithKey (\k v-> (edgemap `accumulateIn` k) v) nodemap + , IntMap.map (\e-> nodemap `pushAlongEdge` e) edgemap) + revert (g, nodemap, edgemap) = + (g, IntMap.map (setInfo blank) nodemap + , IntMap.map (setEdgeInfo blank) edgemap) + +-- Every edge is augmented with the sum of the numbers in its from-node. +pushAlongEdge :: IntMap.IntMap (Node [Int]) -> Edge [Int] -> Edge [Int] +nodemap `pushAlongEdge` edge = setEdgeInfo (nub (sum n: getEdgeInfo edge)) edge + where n = (getInfo . fromJust . flip IntMap.lookup nodemap . getEdgeFrom) + edge + +-- Every node is augmented with a list of all the numbers in its incoming edges. +accumulateIn :: IntMap.IntMap (Edge [Int]) -> NodeNr -> Node [Int] -> Node [Int] +(edgemap `accumulateIn` nr) node = setInfo (nub (es++getInfo node)) node + where es = (concat . IntMap.elems + . IntMap.map getEdgeInfo + . IntMap.filter (\e-> getEdgeTo e == nr) ) + edgemap + +gain :: IO () +gain = main -- :-) diff --git a/src/Math.hs b/src/Math.hs new file mode 100644 --- /dev/null +++ b/src/Math.hs @@ -0,0 +1,110 @@ +module Math + ( DoublePoint(..), Vector + , doublePointX, doublePointY + , intPointToDoublePoint + , doublePointToIntPoint + , translatePolar + , distancePointPoint + , distanceSegmentPoint + , subtractDoublePoint + , subtractDoublePointVector + , vectorLength + , vectorAngle + , origin + , translate + , enclosedInRectangle + ) where + +import Graphics.UI.WX(Point, point, pointX, pointY) +import Text.Parse + +{- +data DoublePoint = DoublePoint + { doublePointX :: !Double + , doublePointY :: !Double + } + deriving (Show, Eq, Read) +-} +data DoublePoint = DoublePoint !Double !Double + deriving (Show, Eq, Read) + +instance Parse DoublePoint where + parse = do { isWord "DoublePoint" + ; return DoublePoint `apply` parse `apply` parse + } + +data Vector = Vector !Double !Double + +doublePointX (DoublePoint x _) = x +doublePointY (DoublePoint _ y) = y + +origin :: DoublePoint +origin = DoublePoint 0 0 + +-- | Compute distance between two points +distancePointPoint :: DoublePoint -> DoublePoint -> Double +distancePointPoint (DoublePoint x0 y0) (DoublePoint x1 y1) = + sqrt (square (x0 - x1) + square (y0 - y1)) + +square :: Double -> Double +square d = d*d + +-- | Compute distance from a segment (as opposed to a line) to a point +-- Formulas taken from +-- +distanceSegmentPoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double +distanceSegmentPoint p0 p1 p = + let v = p1 `subtractDoublePointVector` p0 + w = p `subtractDoublePointVector` p0 + c1 = dotProduct w v + c2 = dotProduct v v + in if c1 <= 0 then distancePointPoint p p0 + else if c2 <= c1 then distancePointPoint p p1 + else distanceLinePoint p0 p1 p + +-- | Compute distance from a line to a point +distanceLinePoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double +distanceLinePoint (DoublePoint x0 y0) (DoublePoint x1 y1) (DoublePoint x y) = + abs ( ( (y0 - y1) * x + (x1 - x0) * y + (x0 * y1 - x1 * y0) ) / + sqrt (square (x1 - x0) + square (y1 - y0)) + ) + +subtractDoublePointVector :: DoublePoint -> DoublePoint -> Vector +subtractDoublePointVector (DoublePoint x0 y0) (DoublePoint x1 y1) = + Vector (x0 - x1) (y0 - y1) + +-- | Translate a point relative to a new origin +translate :: DoublePoint -> DoublePoint -> DoublePoint +translate (DoublePoint originX originY) (DoublePoint x y) = + DoublePoint (x+originX) (y+originY) + +subtractDoublePoint :: DoublePoint -> DoublePoint -> DoublePoint +subtractDoublePoint (DoublePoint x0 y0) (DoublePoint x1 y1) = + DoublePoint (x0 - x1) (y0 - y1) + +dotProduct :: Vector -> Vector -> Double +dotProduct (Vector v1 v2) (Vector w1 w2) = v1 * w1 + v2 * w2 + +translatePolar :: Double -> Double -> DoublePoint -> DoublePoint +translatePolar angle distance (DoublePoint x y) = + DoublePoint (x + cos angle * distance) (y + sin angle * distance) + +doublePointToIntPoint :: DoublePoint -> Point +doublePointToIntPoint (DoublePoint x y) = point (round x) (round y) + +intPointToDoublePoint :: Point -> DoublePoint +intPointToDoublePoint pt = + DoublePoint (fromIntegral (pointX pt)) (fromIntegral (pointY pt)) + +vectorAngle :: Vector -> Double +vectorAngle (Vector v1 v2) = atan2 v2 v1 + +vectorLength :: Vector -> Double +vectorLength (Vector v1 v2) = sqrt (square v1 + square v2) + +enclosedInRectangle :: DoublePoint -> DoublePoint -> DoublePoint -> Bool +enclosedInRectangle (DoublePoint x y) (DoublePoint x0 y0) (DoublePoint x1 y1) = + between x x0 x1 && between y y0 y1 + where + between i j k | j <= k = j <= i && i <= k + | otherwise = k <= i && i <= j diff --git a/src/Network.hs b/src/Network.hs new file mode 100644 --- /dev/null +++ b/src/Network.hs @@ -0,0 +1,578 @@ +module Network + ( + -- * Types + Network, Node, Edge + , NodeNr, EdgeNr, ViaNr + , networkNodes -- dangerous + , networkEdges -- dangerous + + -- * Creating and printing a network + , Network.empty + , dumpNetwork + + , getNodeNrs + , getNodeAssocs, setNodeAssocs + , getEdgeAssocs, setEdgeAssocs + , getCanvasSize, setCanvasSize + , getPalette, setPalette + , getGlobalInfo, setGlobalInfo + + , getNode + , getEdge + , getNodes + , getEdges + , getChildren + , getParents + , getParentMap, ParentMap + + , nodeExists, edgeExists + , findEdge, findNodeNrsByName + + , updateNode + , updateEdge + , updateVia + + , mapNodeNetwork + + , addNode, addNodes, removeNode, addNodeEx + , addEdge, addEdges, removeEdge, addEdgeWithPorts + , removeAllEdges + , newViaEdge, removeVia + + , constructNode + , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape + , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape + , getNodeArity + , setNodeArity + , getInfo, getName, getPosition, getNameAbove, getShape, getArity + , setInfo, setName, setPosition, setNameAbove, setShape, setArity + + , constructEdge + , getEdgeFrom, getEdgeTo, getEdgeVia, getEdgeInfo + , setEdgeFrom, setEdgeTo, setEdgeVia, setEdgeInfo + , getEdgeFromPort, getEdgeToPort + , setEdgeFromPort, setEdgeToPort + ) where + +import Common +import Math +import InfoKind +import Shape +import Palette hiding (delete) + +import qualified Data.IntMap as IntMap -- hiding (map) + +data Network g n e = Network + { networkNodes :: !(IntMap.IntMap (Node n)) -- ^ maps node numbers to nodes + , networkEdges :: !(IntMap.IntMap (Edge e)) -- ^ maps edge numbers to edges + , networkPalette :: Palette n + , networkCanvasSize :: (Double, Double) + , networkInfo :: g + } deriving Show + +data Edge e = Edge + { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts + , edgeTo :: !NodeNr -- ^ the number of the node the edge points to + , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing + , edgeInfo :: e + , edgeFromPort :: !PortNr -- ^ the connection port on the 'from' node + , edgeToPort :: !PortNr -- ^ the connection port on the 'to' node + } deriving (Show, Read, Eq) + +data Node n = Node + { nodePosition :: DoublePoint -- ^ the position of the node on screen + , nodeName :: !String + , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False) + , nodeShape :: Either String Shape -- ^ name from palette, or shape + , nodeInfo :: n + , nodeArity :: Maybe (PortNr,PortNr) -- ^ number of in/out connection ports + } deriving (Show, Read) + +type NodeNr = Int +type EdgeNr = Int +type ViaNr = Int +type PortNr = Int + +-- | Create an empty network +empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e +empty g _ _ = Network + { networkNodes = IntMap.empty + , networkEdges = IntMap.empty + , networkPalette = Palette.empty + , networkCanvasSize = (15, 9) + , networkInfo = g + } + +-- | Map a function over the nodes, possibly changes the type +-- of the Network (i.e. the kind of values stored in the +-- probability tables) +mapNodeNetwork :: InfoKind m g => + (Node n->Node m) -> Network g n e -> Network g m e +mapNodeNetwork nodeFun network = + let numberedNodes = getNodeAssocs network + newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ] + in Network + { networkNodes = IntMap.fromList newNodes + , networkEdges = networkEdges network + , networkPalette = fmap (const blank) $ networkPalette network + , networkCanvasSize = networkCanvasSize network + , networkInfo = networkInfo network + } + +constructEdge :: NodeNr -> PortNr -> NodeNr -> PortNr + -> [DoublePoint] -> e -> Edge e +constructEdge fromNr fromPort toNr toPort via info = + Edge + { edgeFrom = fromNr + , edgeTo = toNr + , edgeVia = via + , edgeInfo = info + , edgeFromPort = fromPort + , edgeToPort = toPort + } + +getEdgeFrom :: Edge e -> NodeNr +getEdgeFrom = edgeFrom + +getEdgeFromPort :: Edge e -> PortNr +getEdgeFromPort = edgeFromPort + +getEdgeTo :: Edge e -> NodeNr +getEdgeTo = edgeTo + +getEdgeToPort :: Edge e -> PortNr +getEdgeToPort = edgeToPort + +getEdgeVia :: Edge e -> [DoublePoint] +getEdgeVia = edgeVia + +getEdgeInfo :: Edge e -> e +getEdgeInfo = edgeInfo + +setEdgeFrom :: NodeNr -> Edge e -> Edge e +setEdgeFrom fromNr edge = edge { edgeFrom = fromNr } + +setEdgeFromPort :: PortNr -> Edge e -> Edge e +setEdgeFromPort fromPortNr edge = edge { edgeFromPort = fromPortNr } + +setEdgeTo :: NodeNr -> Edge e -> Edge e +setEdgeTo toNr edge = edge { edgeTo = toNr } + +setEdgeToPort :: PortNr -> Edge e -> Edge e +setEdgeToPort toPortNr edge = edge { edgeToPort = toPortNr } + +setEdgeVia :: [DoublePoint] -> Edge e -> Edge e +setEdgeVia via edge = edge { edgeVia = via } + +setEdgeInfo :: e -> Edge oldInfo -> Edge e +setEdgeInfo info edge = edge { edgeInfo = info } + +constructNode :: (InfoKind n g) => + String -> DoublePoint -> Bool + -> Either String Shape -> n -> Maybe (PortNr,PortNr) -> Node n +constructNode name position nameAbove shape info arity = + Node + { nodeName = name + , nodePosition = position + , nodeNameAbove = nameAbove + , nodeShape = shape + , nodeInfo = info + , nodeArity = arity + } + +getNodeName :: Network g n e -> NodeNr -> String +getNodeName network nodeNr = nodeName (networkNodes network IntMap.! nodeNr) + +setNodeName :: NodeNr -> String -> Network g n e -> Network g n e +setNodeName nodeNr name network = + network { networkNodes = IntMap.insert nodeNr (node { nodeName = name }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodePosition :: Network g n e -> NodeNr -> DoublePoint +getNodePosition network nodeNr = nodePosition (networkNodes network IntMap.! nodeNr) + +setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e +setNodePosition nodeNr position network = + network { networkNodes = IntMap.insert nodeNr (node { nodePosition = position }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeNameAbove :: Network g n e -> NodeNr -> Bool +getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network IntMap.! nodeNr) + +setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e +setNodeNameAbove nodeNr nameAbove network = + network { networkNodes = IntMap.insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeShape :: Network g n e -> NodeNr -> Either String Shape +getNodeShape network nodeNr = nodeShape (networkNodes network IntMap.! nodeNr) + +setNodeShape :: NodeNr -> Either String Shape -> Network g n e -> Network g n e +setNodeShape nodeNr shape network = + network { networkNodes = IntMap.insert nodeNr (node { nodeShape = shape }) + (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeInfo :: Network g n e -> NodeNr -> n +getNodeInfo network nodeNr = nodeInfo (networkNodes network IntMap.! nodeNr) + +setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e +setNodeInfo nodeNr info network = + network { networkNodes = IntMap.insert nodeNr (node { nodeInfo = info }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeArity :: Network g n e -> NodeNr -> Maybe (PortNr,PortNr) +getNodeArity network nodeNr = nodeArity (networkNodes network IntMap.! nodeNr) + +setNodeArity :: NodeNr -> Maybe (PortNr,PortNr) -> Network g n e + -> Network g n e +setNodeArity nodeNr arity network = + network { networkNodes = IntMap.insert nodeNr (node { nodeArity = arity }) + (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNameAbove :: Node a -> Bool +getNameAbove node = nodeNameAbove node + +getName :: Node a -> String +getName node = nodeName node + +getShape :: Node a -> Either String Shape +getShape node = nodeShape node + +getPosition :: Node a -> DoublePoint +getPosition node = nodePosition node + +getInfo :: Node a -> a +getInfo node = nodeInfo node + +getArity :: Node a -> Maybe (PortNr,PortNr) +getArity node = nodeArity node + +-- | Set whether the name should appear above (True) or below (False) the node +setNameAbove :: Bool -> Node a -> Node a +setNameAbove above node = node { nodeNameAbove = above } + +setName :: String -> Node a -> Node a +setName name node = node { nodeName = name } + +setShape :: Either String Shape -> Node a -> Node a +setShape s node = node { nodeShape = s } + +setPosition :: DoublePoint -> Node a -> Node a +setPosition position node = node { nodePosition = position } + +setInfo :: a -> Node a -> Node a +setInfo info node = node { nodeInfo = info } + +setArity :: Maybe (PortNr,PortNr) -> Node a -> Node a +setArity arity node = node { nodeArity = arity } + +-- | Get the next unused node number +getUnusedNodeNr :: Network g n e -> NodeNr +getUnusedNodeNr network | null used = 1 + | otherwise = maximum used + 1 + where + used = IntMap.keys (networkNodes network) + +-- | Get the next unused edge number +getUnusedEdgeNr :: Network g n e -> EdgeNr +getUnusedEdgeNr network | null used = 1 + | otherwise = maximum used + 1 + where + used = IntMap.keys (networkEdges network) + +-- | Get the node numbers of the parents of a given node +getParents :: Network g n e -> NodeNr -> [NodeNr] +getParents network child = + [ parent + | edge <- getEdges network + , edgeTo edge == child + , let parent = edgeFrom edge + ] + +type ParentMap = IntMap.IntMap [NodeNr] + +-- | getParents is quite expensive (see above) and so +-- we store the parent relationship in an IntMap +getParentMap :: Network g n e -> ParentMap +getParentMap network = + IntMap.fromList + [ (nodeNr, getParents network nodeNr) + | nodeNr <- getNodeNrs network + ] + +-- | Get the node numbers of the children of a given node +getChildren :: Network g n e -> NodeNr -> [NodeNr] +getChildren network parent = + [ child + | edge <- getEdges network + , edgeFrom edge == parent + , let child = edgeTo edge + ] + + +-- | Get node with given index, raises exception if node number does not exist +getNode :: NodeNr -> Network g n e -> Node n +getNode nodeNr network + | IntMap.member nodeNr nodesMap = nodesMap IntMap.! nodeNr + | otherwise = internalError "Network" "getNode" "illegal node number" + where + nodesMap = networkNodes network + +-- | Get edge with given index, raises exception if edge number does not exist +getEdge :: EdgeNr -> Network g n e -> Edge e +getEdge edgeNr network = networkEdges network IntMap.! edgeNr + +-- | Get all of the nodes in the network +getNodes :: Network g n e -> [Node n] +getNodes network = IntMap.elems (networkNodes network) + +-- | Get all of the edges in the network +getEdges :: Network g n e -> [Edge e] +getEdges network = IntMap.elems (networkEdges network) + +-- | Get all of the node numbers in the network +getNodeNrs :: Network g n e -> [NodeNr] +getNodeNrs network = IntMap.keys (networkNodes network) + +getPalette :: Network g n e -> Palette n +getPalette network = networkPalette network + +getCanvasSize :: Network g n e -> (Double, Double) +getCanvasSize network = networkCanvasSize network + +getGlobalInfo :: Network g n e -> g +getGlobalInfo network = networkInfo network + +-- | Find the number of an edge given start and end node number +findEdge :: NodeNr -> NodeNr -> Network g n e -> Maybe EdgeNr +findEdge fromNodeNr toNodeNr network = + let hits = IntMap.filter + (sameFromAndTo (Edge { edgeFrom = fromNodeNr + , edgeTo = toNodeNr + , edgeVia = undefined + , edgeInfo = undefined + , edgeFromPort = 0 + , edgeToPort = 0 })) + (networkEdges network) + in case IntMap.keys hits of + [key] -> Just key + _ -> Nothing + +-- | Find node numbers given a node name +findNodeNrsByName :: String -> Network g n e -> [NodeNr] +findNodeNrsByName theNodeName network = + [ nodeNr + | nodeNr <- getNodeNrs network + , getNodeName network nodeNr == theNodeName + ] + +-- | Get a list of pairs where each pair contains a node number and the corresponding node +getNodeAssocs :: Network g n e -> [(NodeNr, Node n)] +getNodeAssocs network = IntMap.assocs (networkNodes network) + +setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e +setNodeAssocs nodeAssocs network = + network { networkNodes = IntMap.fromList nodeAssocs } + +-- | Get a list of pairs where each pair contains a edge number and the corresponding edge +getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)] +getEdgeAssocs network = IntMap.assocs (networkEdges network) + +setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e +setEdgeAssocs edgeAssocs network = + network { networkEdges = IntMap.fromList edgeAssocs } + +-- | Create a string that describes the network +dumpNetwork :: InfoKind e g => Network g String e -> String +dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network) + +-- | Test for existence of a node number +nodeExists :: NodeNr -> Network g n e -> Bool +nodeExists nodeNr network = + IntMap.member nodeNr (networkNodes network) + +-- | Test for existence of an edge number +edgeExists :: EdgeNr -> Network g n e -> Bool +edgeExists edgeNr network = + IntMap.member edgeNr (networkEdges network) + +{----------------------------------- + Functions that change the network + -----------------------------------} + +-- | Add a node to the network +addNode :: InfoKind n g + => Network g n e -- ^ the network to add the node to + -> (NodeNr, Network g n e) -- ^ the number of the new node and + -- the extended network +addNode network = + addNodeEx ("Node " ++ show nodeNr) + (DoublePoint 0.0 0.0) + True + (Right Shape.circle) + blank + Nothing + network + where + nodeNr = getUnusedNodeNr network + +addNodes :: InfoKind n g => Int -> Network g n e -> ([NodeNr], Network g n e) +addNodes 0 network = ([], network) +addNodes n network1 = + let (nodeNr, network2) = addNode network1 + (nodeNrs, network3) = addNodes (n-1) network2 + in (nodeNr:nodeNrs, network3) + +addNodeEx :: InfoKind n g => + String -> DoublePoint -> Bool -> Either String Shape -> n + -> Maybe (PortNr,PortNr) + -> Network g n e -> (NodeNr, Network g n e) +addNodeEx name position labelAbove shape info arity network = + ( nodeNr + , network { networkNodes = IntMap.insert nodeNr node (networkNodes network) } + ) + where + nodeNr = getUnusedNodeNr network + node = constructNode name position labelAbove shape info arity + + +-- | Add an edge to the network. +addEdge :: InfoKind e g => NodeNr -> NodeNr -> Network g n e -> Network g n e +addEdge fromNodeNr toNodeNr network + | any (sameFromAndTo edge) edgesList || -- prohibit double edges + any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction + network + | otherwise = + let edgeNr = getUnusedEdgeNr network + in setNodeArity fromNodeNr (updateFromArity fromArity) $ + setNodeArity toNodeNr (updateToArity toArity) $ + network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } + where + edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank + edgesList = IntMap.elems (networkEdges network) + fromArity = getNodeArity network fromNodeNr + toArity = getNodeArity network toNodeNr + fromPortNr = 1 + (maybe 0 snd $ fromArity) + toPortNr = 1 + (maybe 0 fst $ toArity) + updateFromArity Nothing = Just (0,1) + updateFromArity (Just (n,m)) = Just (n,m+1) + updateToArity Nothing = Just (1,0) + updateToArity (Just (n,m)) = Just (n+1,m) + +-- | Add an edge to the network, with specific connection ports. +addEdgeWithPorts :: InfoKind e g => + NodeNr -> PortNr -> NodeNr -> PortNr + -> Network g n e -> Network g n e +addEdgeWithPorts fromNodeNr fromPortNr toNodeNr toPortNr network + | any (sameFromAndTo edge) edgesList || -- prohibit double edges + any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction + network + | otherwise = + let edgeNr = getUnusedEdgeNr network + networkPlusEdge = network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } + in networkPlusEdge + where + edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank + -- edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] + -- , edgeInfo = blank, edgeFromPort = fromPortNr + -- , edgeToPort = toPortNr } + edgesList = IntMap.elems (networkEdges network) + +addEdges :: InfoKind e g => [(NodeNr,NodeNr)] -> Network g n e -> Network g n e +addEdges edgeTuples network = + foldr (\(fromNr, toNr) net -> addEdge fromNr toNr net) network edgeTuples + +-- | Insert a new 'via' control point in the middle of an edge. +newViaEdge :: EdgeNr -> ViaNr -> DoublePoint + -> Network g n e -> Network g n e +newViaEdge edgeNr viaNr point network = + network { networkEdges = IntMap.adjust (\e->e{ edgeVia= take viaNr (edgeVia e) + ++[point] + ++drop viaNr (edgeVia e) }) + edgeNr + (networkEdges network) } + +-- | Remove node with given index, raises exception if node number does not exist. +-- This function also removes all edges that start or end in this node. +removeNode :: NodeNr -> Network g n e -> Network g n e +removeNode nodeNr network = + let involvedEdges = [ i + | (i, edge) <- getEdgeAssocs network + , edgeFrom edge == nodeNr || edgeTo edge == nodeNr + ] + networkWithoutEdges = foldr removeEdge network involvedEdges + networkWithoutNode = networkWithoutEdges { networkNodes = IntMap.delete nodeNr (networkNodes networkWithoutEdges) } + in networkWithoutNode + +-- | Remove an edge from the network. The probability table of the target node is updated: +-- the corresponding dimension is removed and all values are zeroed. +-- An exception is raised if edge number does not exist. +removeEdge :: EdgeNr -> Network g n e -> Network g n e +removeEdge edgeNr network = + setNodeArity fromNodeNr (Just (fi,fo-1)) $ + setNodeArity toNodeNr (Just (ti-1,to)) $ + network { networkEdges = IntMap.delete edgeNr (networkEdges network) } + where + (fi,fo) = maybe (0,1) id $ getNodeArity network fromNodeNr + (ti,to) = maybe (1,0) id $ getNodeArity network toNodeNr + edge = getEdge edgeNr network + fromNodeNr = getEdgeFrom edge + toNodeNr = getEdgeTo edge + + +-- | Remove all edges from the network. The probability tables of all node are zeroed. +removeAllEdges :: Network g n e -> Network g n e +removeAllEdges network = + let networkWithoutEdges = network { networkEdges = IntMap.empty } + in networkWithoutEdges + +-- | Remove a control point from an edge. +removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e +removeVia edgeNr viaNr network = + let remove n e = e { edgeVia = take n (edgeVia e) + ++ drop (n+1) (edgeVia e) } in + network { networkEdges = IntMap.adjust (remove viaNr) + edgeNr (networkEdges network) } + +setPalette :: Palette n -> Network g n e -> Network g n e +setPalette palette network = network { networkPalette = palette } + +setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e +setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize } + +setGlobalInfo :: g -> Network g n e -> Network g n e +setGlobalInfo info network = network { networkInfo = info } + +{----------------------------------- + Local functions + -----------------------------------} + +sameFromAndTo :: Edge e -> Edge e -> Bool +sameFromAndTo edge1 edge2 = + edgeFrom edge1 == edgeFrom edge2 && edgeTo edge1 == edgeTo edge2 + +reverseEdge :: Edge e -> Edge e +reverseEdge edge = + edge { edgeFrom = edgeTo edge, edgeTo = edgeFrom edge } + +-- | Update node with given number by applying the function to it +-- Dangerous (wrt network consistency, do not export) +updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e +updateNode nodeNr nodeFunction network = + let node = getNode nodeNr network in + network { networkNodes = IntMap.insert nodeNr (nodeFunction node) + (networkNodes network) } + +updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e +updateEdge edgeNr edgeFunction network = + network { networkEdges = IntMap.adjust edgeFunction edgeNr + (networkEdges network) } + +updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e +updateVia edgeNr viaNr v network = + network { networkEdges = + IntMap.adjust (\e-> e { edgeVia = take viaNr (edgeVia e) + ++[v]++drop (viaNr+1) (edgeVia e) }) + edgeNr (networkEdges network) } diff --git a/src/NetworkControl.hs b/src/NetworkControl.hs new file mode 100644 --- /dev/null +++ b/src/NetworkControl.hs @@ -0,0 +1,513 @@ +module NetworkControl + ( createNode, selectNode + , createEdge, selectEdge + , createVia, selectVia + , selectNothing, selectMultiple + , pickupNode, dragNode, dropNode + , pickupVia, dragVia, dropVia + , pickupMultiple, dragMultiple, dropMultiple + , pickupArea, dragArea, dropArea + , deleteSelection + , changeNamePosition + , changeNodeShape + , renameNode, reinfoNodeOrEdge + , reArityNode + , changeGlobalInfo + ) where + +import State +import StateUtil +import Network +import NetworkView (edgeContains) +import Document +import Common +import CommonIO +import Math +import Shape +import qualified PersistentDocument as PD +import InfoKind +import Palette (shapes) +import Text.Parse +import Char (isSpace) + +import Graphics.UI.WX hiding (Selection) +import Graphics.UI.WXCore + +changeNamePosition :: Bool -> State g n e -> IO () +changeNamePosition above state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "move label" + (updateNetwork + (updateNode nodeNr + (setNameAbove above))) pDoc + ; repaintAll state + } + _ -> return () + } + +changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO () +changeNodeShape shapename info state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "change shape" + (updateNetwork + (updateNode nodeNr + (setInfo info . setShape (Left shapename)))) pDoc + ; repaintAll state + } + _ -> return () + } + +deleteSelection :: State g n e -> IO () +deleteSelection state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "delete node" + ( setSelection NoSelection + . updateNetwork (removeNode nodeNr) + ) pDoc + ; repaintAll state + } + EdgeSelection edgeNr -> + do{ PD.updateDocument "delete edge" + ( setSelection NoSelection + . updateNetwork (removeEdge edgeNr) + ) pDoc + ; repaintAll state + } + ViaSelection edgeNr viaNr -> + do{ PD.updateDocument "delete control point" + ( setSelection NoSelection + . updateNetwork (removeVia edgeNr viaNr) + ) pDoc + ; repaintAll state + } + _ -> return () + } + +createNode :: InfoKind n g => DoublePoint -> State g n e -> IO () +createNode mousePoint state = + do{ pDoc <- getDocument state + ; doc1 <- PD.getDocument pDoc + ; let (shape,info) = case (shapes . getPalette . getNetwork) doc1 of + [] -> (Right Shape.circle, blank) + ((s,(_,Nothing)):_) -> (Left s, blank) + ((s,(_,Just i)):_) -> (Left s, i) + ; let (nodeNr, doc2) = updateNetworkEx addNode doc1 + doc3 = updateNetwork (updateNode nodeNr (setPosition mousePoint + . setShape shape + . setInfo info)) + doc2 + doc4 = setSelection (NodeSelection nodeNr) doc3 + ; PD.setDocument "add node" doc4 pDoc + ; repaintAll state + } + +selectNothing :: State g n e -> IO () +selectNothing state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection NoSelection) pDoc + ; repaintAll state + } + +selectEdge :: Int -> State g n e -> IO () +selectEdge edgeNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (EdgeSelection edgeNr)) pDoc + ; repaintAll state + } + +createEdge :: (InfoKind e g) => Int -> Int -> State g n e -> IO () +createEdge fromNodeNr toNodeNr state = + do{ pDoc <- getDocument state + ; PD.updateDocument "add edge" + ( setSelection (NodeSelection fromNodeNr) + . updateNetwork (addEdge fromNodeNr toNodeNr) + ) pDoc + ; repaintAll state + } + +createVia :: DoublePoint -> State g n e -> IO () +createVia mousepoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + EdgeSelection edgeNr -> + do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network) + $ \viaNr-> + do{ PD.updateDocument "add control point to edge" + ( setSelection (ViaSelection edgeNr viaNr) + . updateNetwork (newViaEdge edgeNr viaNr mousepoint) + ) pDoc + ; repaintAll state + } + } + _ -> return () + } + +selectVia :: Int -> Int -> State g n e -> IO () +selectVia edgeNr viaNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (ViaSelection edgeNr viaNr)) + pDoc + ; repaintAll state + } + +pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO () +pickupVia edgeNr viaNr mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr + ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state + ; selectVia edgeNr viaNr state + } + +selectNode :: Int -> State g n e -> IO () +selectNode nodeNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (NodeSelection nodeNr)) pDoc + ; repaintAll state + } + +pickupNode :: Int -> DoublePoint -> State g n e -> IO () +pickupNode nodeNr mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + nodePos = getNodePosition network nodeNr + ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state + ; selectNode nodeNr state + } + +dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () +dragNode nodeNr mousePoint canvas state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (hasMoved, offset) <- getDragging state + ; let newPosition = mousePoint `subtractDoublePoint` offset + oldPosition = getNodePosition (getNetwork doc) nodeNr + ; when (newPosition /= oldPosition) $ + do{ -- The first time the node is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move node" + else PD.superficialUpdateDocument) + (updateNetwork (updateNode nodeNr + (setPosition newPosition))) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, offset)) state + -- yes, the node has really moved + } + } + +dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () +dropNode hasMoved nodeNr offset mousePoint state = + do{ when hasMoved $ + do{ let newPosition = mousePoint `subtractDoublePoint` offset + ; pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork (updateNode nodeNr + (setPosition newPosition))) pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () +dragVia edgeNr viaNr mousePoint canvas state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (hasMoved, offset) <- getDragging state + ; let newPosition = mousePoint `subtractDoublePoint` offset + oldPosition = (getEdgeVia (getEdge edgeNr (getNetwork doc)))!!viaNr + ; when (newPosition /= oldPosition) $ + do{ -- The first time the point is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument) + (updateNetwork (updateVia edgeNr viaNr newPosition)) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, offset)) state + -- yes, the point has really moved + } + } + +dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () +dropVia hasMoved edgeNr viaNr offset mousePoint state = + do{ when hasMoved $ + do{ let newPosition = mousePoint `subtractDoublePoint` offset + ; pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork (updateVia edgeNr viaNr newPosition)) + pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)] + -> State g n e -> IO () +selectMultiple area nodeNrs viaNrs state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument + (setSelection (MultipleSelection area nodeNrs viaNrs)) + pDoc + ; repaintAll state + } + +pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO () +pickupMultiple _nodeNrs _viaNrs mousePoint state = + do{ setDragging (Just (False, mousePoint)) state +-- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected + } + +dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> ScrolledWindow () + -> State g n e -> IO () +dragMultiple nodeNrs viaNrs mousePoint canvas state = + do{ pDoc <- getDocument state + -- ; doc <- PD.getDocument pDoc + ; Just (hasMoved, origin) <- getDragging state + ; let offset = mousePoint `subtractDoublePoint` origin + ; when (mousePoint /= origin) $ + do{ -- The first time the point is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument) + (updateNetwork (updateMultiple nodeNrs viaNrs offset)) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, mousePoint)) state + -- yes, the point has really moved + } + } + +updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e + -> Network g n e +updateMultiple ns vs o network = + ( foldr (\n z-> updateNode n (offsetNode o) . z) id ns + . foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs + ) network + where + offsetNode off node = setPosition (getPosition node `translate` off) node + offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via) + `translate` off + +dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint + -> State g n e -> IO () +dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state = + do{ when hasMoved $ + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork + (updateMultiple nodeNrs viaNrs + (mousePoint`subtractDoublePoint`origin))) + pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +pickupArea :: DoublePoint -> State g n e -> IO () +pickupArea mousePoint state = + do{ setDragging (Just (False, mousePoint)) state + ; selectMultiple (Just (mousePoint,mousePoint)) [] [] state + } + +-- dragArea is not like dragging a selection. It does not move anything. +-- It only adds items into a multiple selection. +dragArea :: DoublePoint -> State g n e -> IO () +dragArea mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (_, origin) <- getDragging state + ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (getNetwork doc) + ; selectMultiple (Just (origin,mousePoint)) ns vs state + } + where + itemsEnclosedWithin p0 p1 network = + ( ( Prelude.map fst + . Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1) + . getNodeAssocs ) network + , ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j)) + (Prelude.filter + (\ (_,v)-> enclosedInRectangle + v p0 p1) + (zip [0..] (getEdgeVia e)))) + . getEdgeAssocs ) network + ) + +dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO () +dropArea _origin mousePoint state = + do{ dragArea mousePoint state -- calculate enclosure area + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + MultipleSelection _ [] [] -> + PD.superficialUpdateDocument (setSelection NoSelection) pDoc + MultipleSelection _ ns vs -> + PD.superficialUpdateDocument + (setSelection (MultipleSelection Nothing ns vs)) pDoc + _ -> return () + ; setDragging Nothing state + ; repaintAll state + } + + +renameNode :: Frame () -> State g n e -> IO () +renameNode theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldName = getNodeName network nodeNr + ; result <- myTextDialog theFrame SingleLine + "Rename node" oldName True + ; ifJust result $ \newName -> + do{ PD.updateDocument "rename node" + (updateNetwork + (updateNode nodeNr (setName newName))) pDoc + ; repaintAll state + } + } + _ -> return () + } + +reArityNode :: Frame () -> State g n e -> IO () +reArityNode theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldArity = getNodeArity network nodeNr + ; result <- myTextDialog theFrame SingleLine + "Change arity of node" (show oldArity) + True + ; ifJust result $ \newArity -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newArity of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; PD.updateDocument "change node arity" + (updateNetwork + (updateNode nodeNr (setArity x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + _ -> return () + } + +reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) => + Frame () -> State g n e -> IO () +reinfoNodeOrEdge theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldInfo = getNodeInfo network nodeNr + ; result <- myTextDialog theFrame MultiLine + "Edit node info" (show oldInfo) True + ; ifJust result $ \newInfo -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; case check (getNodeName network nodeNr) + (getGlobalInfo network) x of + [] -> return () + e -> errorDialog theFrame "Validity warning" + ("Validity check fails:\n" + ++unlines e) + ; PD.updateDocument "edit node info" + (updateNetwork + (updateNode nodeNr (setInfo x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + EdgeSelection edgeNr -> + do{ let oldInfo = getEdgeInfo (getEdge edgeNr network) + ; result <- myTextDialog theFrame MultiLine + "Edit edge info" (show oldInfo) True + ; ifJust result $ \newInfo -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; case check "edge" + (getGlobalInfo network) x of + [] -> return () + e -> errorDialog theFrame "Validity warning" + ("Validity check fails:\n" + ++unlines e) + ; PD.updateDocument "edit edge info" + (updateNetwork + (updateEdge edgeNr (setEdgeInfo x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + _ -> return () + } + +changeGlobalInfo :: (Show g, Parse g, Descriptor g) => + Frame () -> State g n e -> IO () +changeGlobalInfo theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + info = getGlobalInfo network + ; result <- myTextDialog theFrame MultiLine ("Edit "++descriptor info) + (show info) True + ; ifJust result $ \newInfo-> + --do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; PD.updateDocument ("edit "++descriptor info) + (updateNetwork (setGlobalInfo x)) pDoc + ; repaintAll state -- no visible change? + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + diff --git a/src/NetworkFile.hs b/src/NetworkFile.hs new file mode 100644 --- /dev/null +++ b/src/NetworkFile.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE UndecidableInstances #-} +module NetworkFile where + +import Network +import Math +import Common +import Colors +import Shape +import InfoKind +import Palette + +import Text.XML.HaXml.Types +import Text.XML.HaXml.Escape +import Text.XML.HaXml.Posn (noPos) +import Text.XML.HaXml.Parse hiding (element) +-- import Text.XML.HaXml.XmlContent as XML +import Text.XML.HaXml.XmlContent.Haskell as XML +import Text.XML.HaXml.Combinators (replaceAttrs) +import Text.XML.HaXml.Verbatim +import Text.XML.HaXml.TypeMapping (toDTD,toHType) +import Text.PrettyPrint.HughesPJ +import qualified Text.XML.HaXml.Pretty as Pretty +import Char +import Maybe +import Monad(when) +import List(nub,isPrefixOf) + +-- | Print the network data structure to an XML text +toString :: (InfoKind n g, InfoKind e g, XmlContent g) => + Network g n e -> String +toString network = render . Pretty.document $ + Document (Prolog Nothing [] (Just (toDTD (toHType network))) []) emptyST + (f (toContents network)) [] + where + f [CElem e _] = e + f _ = error "bad" -- shouldn't happen + +-- | Parses a string to the network data structure +-- Returns either an error message (Left) or the network, +-- a list of warnings (Right) and a boolean indicating whether +-- the file was an old Dazzle file +fromString :: (InfoKind n g, InfoKind e g, XmlContent g) => + String -> Either String (Network g n e, [String], Bool) +fromString xml = + case xmlParse' "input file" xml of + Left err -> Left err -- lexical or initial (generic) parse error + Right (Document _ _ e _) -> + case runParser parseContents [CElem e noPos] of + (Left err, _) -> Left err -- secondary (typeful) parse error + (Right v, _) -> Right (v,[],False) + +{- +-- non-XML output +toStringShow :: (Show g, Show n, Show e) => Network g n e -> String +toStringShow network = + show ( getNodeAssocs network + , getEdgeAssocs network + , getCanvasSize network + , getGlobalInfo network + ) + +fromStringShow :: (Read g, InfoKind n g, InfoKind e g) => + String -> Either String (Network g n e) +fromStringShow txt = + case reads txt of + ((tuple,[]):_) -> + let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple + in Right ( setNodeAssocs nodeAssocs + . setEdgeAssocs edgeAssocs + . setCanvasSize canvasSize + $ Network.empty globalInfo undefined undefined + ) + _ -> Left "File is not a Blobs network" +-} + +--------------------------------------------------------- +-- Internal type isomorphic to (index,value) pairs +-- (but permits instances of classes) +--------------------------------------------------------- +data AssocN n = AssocN Int (Node n) +deAssocN :: AssocN n -> (Int,Node n) +deAssocN (AssocN n v) = (n,v) +data AssocE e = AssocE Int (Edge e) +deAssocE :: AssocE e -> (Int,Edge e) +deAssocE (AssocE n v) = (n,v) + +--------------------------------------------------------- +-- Convert our data type to/from an XML tree +--------------------------------------------------------- +instance (HTypeable g, HTypeable n, HTypeable e) + => HTypeable (Network g n e) where + toHType _ = Defined "Network" [] [Constr "Network" [] []] + -- toHType g = Defined "Network" [] [Constr "Network" [] + -- [ Tagged "Width" [String] + -- , Tagged "Height" [String] + -- , toHType (getGlobalInfo g) + -- , toHType (getPalette g) + -- , toHType (getNodeAssocs g) + -- , toHType (getEdgeAssocs g) + -- ]] +instance (InfoKind n g, InfoKind e g, XmlContent g) => + XmlContent (Network g n e) where + toContents network = + [CElem (Elem "Network" [] + [ simpleString "Width" (show width) + , simpleString "Height" (show height) + , makeTag "Info" (toContents netInfo) + , makeTag "Palette" (toContents (getPalette network)) + , makeTag "Nodes" (concatMap toContents nodeAssocs) + , makeTag "Edges" (concatMap toContents edgeAssocs) + ]) () ] + where + nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network + edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network + (width, height) = getCanvasSize network + netInfo = getGlobalInfo network + parseContents = do + { inElement "Network" $ do + { w <- inElement "Width" $ fmap read XML.text + ; h <- inElement "Height" $ fmap read XML.text + ; i <- inElement "Info" $ parseContents + ; p <- inElement "Palette"$ parseContents + ; ns <- inElement "Nodes" $ many1 parseContents + ; es <- inElement "Edges" $ many1 parseContents + ; networkValid ns es + ; return ( setCanvasSize (w,h) + . setPalette p + . setNodeAssocs (map deAssocN ns) + . setEdgeAssocs (map deAssocE es) + $ Network.empty i undefined undefined) + } + } + +peekAttributes :: String -> XMLParser [(String,AttValue)] +peekAttributes t = + do{ (p, e@(Elem _ as _)) <- posnElement [t] + ; reparse [CElem e p] + ; return as + } + +instance HTypeable (AssocN n) where + toHType _ = Defined "Node" [] [Constr "Node" [] []] +instance (InfoKind n g) => XmlContent (AssocN n) where + toContents (AssocN n node) = + concatMap (replaceAttrs [("id",'N':show n)]) (toContents node) + parseContents = do + { [("id",n)] <- peekAttributes "Node" + ; n' <- num n + ; node <- parseContents + ; return (AssocN n' node) + } + where num (AttValue [Left ('N':n)]) = return (read n) + num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s) + +instance HTypeable (AssocE e) where + toHType _ = Defined "Edge" [] [Constr "Edge" [] []] +instance (InfoKind e g) => XmlContent (AssocE e) where + toContents (AssocE n edge) = + concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge) + parseContents = do + { [("id",n)] <- peekAttributes "Edge" + ; n' <- num n + ; edge <- parseContents + ; return (AssocE n' edge) + } + where num (AttValue [Left ('E':n)]) = return (read n) + num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s) + +instance HTypeable (Node n) where + toHType _ = Defined "Node" [] [Constr "Node" [] []] +instance (InfoKind n g) => XmlContent (Node n) where + toContents node = + [ makeTag "Node" + (toContents (getPosition node) ++ + [ escapeString "Name" (getName node) + , simpleString "LabelAbove" (show (getNameAbove node)) + , makeTag "Shape" (toContents (getShape node)) + , makeTag "Info" (toContents (getInfo node)) + , makeTag "Arity" (toContents (getArity node)) + ]) + ] + parseContents = do + { inElement "Node" $ do + { p <- parseContents -- position + ; n <- inElement "Name" $ XML.text + ; a <- inElement "LabelAbove" $ fmap read XML.text + ; s <- inElement "Shape" $ parseContents + ; i <- inElement "Info" $ parseContents + ; r <- (inElement "Arity" $ parseContents) + `onFail` (return Nothing) + ; return (constructNode n p a s i r) + } + } + +instance HTypeable DoublePoint where + toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []] +instance XmlContent DoublePoint where + toContents (DoublePoint x y) = + [ simpleString "X" (show x) + , simpleString "Y" (show y) + ] + parseContents = do + { x <- inElement "X" $ fmap read XML.text + ; y <- inElement "Y" $ fmap read XML.text + ; return (DoublePoint x y) + } + +instance HTypeable (Edge e) where + toHType _ = Defined "Edge" [] [Constr "Edge" [] []] +instance InfoKind e g => XmlContent (Edge e) where + toContents edge = + [ makeTag "Edge" + [ simpleString "From" (show (getEdgeFrom edge)) + , simpleString "To" (show (getEdgeTo edge)) + , makeTag "Via" (concatMap toContents (getEdgeVia edge)) + , makeTag "Info" (toContents (getEdgeInfo edge)) + , makeTag "FromPort" (toContents (getEdgeFromPort edge)) + , makeTag "ToPort" (toContents (getEdgeToPort edge)) + ] + ] + parseContents = do + { inElement "Edge" $ do + { f <- inElement "From" $ fmap read XML.text + ; t <- inElement "To" $ fmap read XML.text + ; v <- inElement "Via" $ many parseContents + ; i <- inElement "Info" $ parseContents + ; fp <- (inElement "FromPort" $ parseContents) + `onFail` (return 0) + ; tp <- (inElement "ToPort" $ parseContents) + `onFail` (return 0) + ; return (constructEdge f fp t tp v i) + } + } + +{- derived by DrIFT -} +instance HTypeable Colour where + toHType v = Defined "Colour" [] + [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]] + where (RGB aa ab ac) = v +instance XmlContent Colour where + parseContents = do + { inElement "RGB" $ do + { aa <- parseContents + ; ab <- parseContents + ; ac <- parseContents + ; return (RGB aa ab ac) + } + } + toContents v@(RGB aa ab ac) = + [mkElemC (showConstr 0 (toHType v)) + (concat [toContents aa, toContents ab, toContents ac])] + +{- derived by DrIFT -} +instance HTypeable Shape where + toHType v = Defined "Shape" [] + [Constr "Circle" [] [toHType aa,toHType ab] + ,Constr "Polygon" [] [toHType ac,toHType ad] + ,Constr "Lines" [] [toHType ae,toHType af] + ,Constr "Composite" [] [toHType ag]] + where + (Circle aa ab) = v + (Polygon ac ad) = v + (Lines ae af) = v + (Composite ag) = v +instance XmlContent Shape where + parseContents = do + { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] + ; case t of + _ | "Polygon" `isPrefixOf` t -> interior e $ + do { ac <- parseContents + ; ad <- parseContents + ; return (Polygon ac ad) + } + | "Lines" `isPrefixOf` t -> interior e $ + do { ae <- parseContents + ; af <- parseContents + ; return (Lines ae af) + } + | "Composite" `isPrefixOf` t -> interior e $ + fmap Composite parseContents + | "Circle" `isPrefixOf` t -> interior e $ + do { aa <- parseContents + ; ab <- parseContents + ; return (Circle aa ab) + } + } + toContents v@(Circle aa ab) = + [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa, + toContents ab])] + toContents v@(Polygon ac ad) = + [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac, + toContents ad])] + toContents v@(Lines ae af) = + [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae, + toContents af])] + toContents v@(Composite ag) = + [mkElemC (showConstr 3 (toHType v)) (toContents ag)] + +{- derived by DrIFT -} +instance HTypeable ShapeStyle where + toHType v = Defined "ShapeStyle" [] + [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]] + where (ShapeStyle aa ab ac) = v +instance XmlContent ShapeStyle where + parseContents = do + { inElement "ShapeStyle" $ do + { aa <- parseContents + ; ab <- parseContents + ; ac <- parseContents + ; return (ShapeStyle aa ab ac) + } + } + toContents v@(ShapeStyle aa ab ac) = + [mkElemC (showConstr 0 (toHType v)) + (concat [toContents aa, toContents ab, toContents ac])] + +{- handwritten -} +instance HTypeable a => HTypeable (Palette a) where + toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []] + where (Palette ((_,(_,Just a)):_)) = p +instance XmlContent a => XmlContent (Palette a) where + toContents (Palette shapes) = + [ mkElemC "Palette" (concatMap toContents shapes) ] + parseContents = do + { inElement "Palette" $ fmap Palette (many1 parseContents) } + +{- +instance XmlContent a => XmlContent (Either String a) where + toContents (Left str) = [ simpleString "ShapeName" (show str) ] + toContents (Right shape) = (toContents shape) + + parseContents = do + return () -- Need to implement this +-} +---- UTILITY FUNCTIONS + +-- Abbreviations +makeTag :: String -> [Content i] -> Content i +makeTag name children = CElem (Elem name [] children) undefined + +tagWithId :: String -> String -> [Content i] -> Content i +tagWithId name identity children = + CElem (Elem name [("id", AttValue [Left identity])] children) undefined + +-- | A simple string contains no spaces or unsafe characters +simpleString :: String -> String -> Content i +simpleString tag value = + CElem (Elem tag [] [ CString False value undefined ]) undefined + +-- | The string value may contain spaces and unsafe characters +escapeString :: String -> String -> Content i +escapeString key value = + CElem ((if isSafe value then id else escape) $ + Elem key [] [ CString (any isSpace value) value undefined ]) + undefined + where + isSafe cs = all isSafeChar cs + isSafeChar c = isAlpha c || isDigit c || c `elem` "- ." + + escape :: Element i -> Element i + escape = xmlEscape stdXmlEscaper + +comment :: String -> Content i +comment s = CMisc (Comment (commentEscape s)) undefined + +-- Replace occurences of "-->" with "==>" in a string so that the string +-- becomes safe for an XML comment +commentEscape :: String -> String +commentEscape [] = [] +commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs +commentEscape (x:xs) = x : commentEscape xs + +--------------------------------------------------------- +-- Check whether the network read from file is valid +--------------------------------------------------------- + +networkValid :: [AssocN n] -> [AssocE e] -> XMLParser () +networkValid nodeAssocs edgeAssocs + | containsDuplicates nodeNrs = + fail "Node numbers should be unique" + | containsDuplicates edgeNrs = + fail "Edge numbers should be unique" + | otherwise = + do{ mapM_ (checkEdge nodeNrs) edgeAssocs + ; -- determine whether there are multiple edges between any two nodes + ; let multipleEdges = duplicatesBy betweenSameNodes edges + ; when (not (null multipleEdges)) $ + fail $ "There are multiple edges between the following node pairs: " ++ + commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", " + ++ show (getEdgeTo e) ++ ")" + | e <- multipleEdges + ] + ; return () + } + where + nodeNrs = map (fst . deAssocN) nodeAssocs + (edgeNrs, edges) = unzip (map deAssocE edgeAssocs) + +-- Check whether edges refer to existing node numbers and whether +-- there are no edges that start and end in the same node +checkEdge :: [NodeNr] -> AssocE e -> XMLParser () +checkEdge nodeNrs (AssocE edgeNr edge) + | fromNr == toNr = + fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same" + | fromNr `notElem` nodeNrs = nonExistingNode fromNr + | toNr `notElem` nodeNrs = nonExistingNode toNr + | otherwise = return () + where + fromNr = getEdgeFrom edge + toNr = getEdgeTo edge + nonExistingNode nodeNr = + fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node " + ++ show nodeNr + +containsDuplicates :: Eq a => [a] -> Bool +containsDuplicates xs = length (nub xs) /= length xs + +-- Partial equality on edges +betweenSameNodes :: Edge e -> Edge e -> Bool +betweenSameNodes e1 e2 = + (getEdgeFrom e1 == getEdgeFrom e2 && getEdgeTo e1 == getEdgeTo e2) + || + (getEdgeFrom e1 == getEdgeTo e2 && getEdgeTo e1 == getEdgeFrom e1) + +-- Returns elements that appear more than once in a list +duplicates :: Eq a => [a] -> [a] +duplicates [] = [] +duplicates (x:xs) + | x `elem` xs = x : duplicates (filter (/= x) xs) + | otherwise = duplicates xs + +-- Returns elements that appear more than once in a list, using given Eq op +duplicatesBy :: (a->a->Bool) -> [a] -> [a] +duplicatesBy _ [] = [] +duplicatesBy eq (x:xs) + | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs) + | otherwise = duplicatesBy eq xs + diff --git a/src/NetworkUI.hs b/src/NetworkUI.hs new file mode 100644 --- /dev/null +++ b/src/NetworkUI.hs @@ -0,0 +1,435 @@ +module NetworkUI + ( create + , getConfig, Config + ) where + +import GUIEvents +import SafetyNet +import State +import StateUtil +import Network +import NetworkView +import NetworkFile +import Document +import Common +import CommonIO +import qualified PersistentDocument as PD +import qualified PDDefaults as PD +import Palette +import InfoKind +import DisplayOptions +--import Text.XML.HaXml.XmlContent (XmlContent) +import Text.XML.HaXml.XmlContent.Haskell (XmlContent) +import Text.Parse +import Operations +import NetworkControl (changeGlobalInfo) + +import Graphics.UI.WX hiding (Child, upKey, downKey) +import Graphics.UI.WXCore +import Maybe + +data Config = NFC + { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height + , nfcFileName :: Maybe String + , nfcSelection :: Document.Selection + } + deriving (Read, Show) + +getConfig :: State g n e -> IO Config +getConfig state = + do{ theFrame <- getNetworkFrame state + ; (x, y) <- safeGetPosition theFrame + ; winSize <- get theFrame clientSize + ; pDoc <- getDocument state + ; maybeFileName <- PD.getFileName pDoc + ; doc <- PD.getDocument pDoc + ; return (NFC + { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize) + , nfcFileName = maybeFileName + , nfcSelection = getSelection doc + }) + } + +create :: (InfoKind n g, InfoKind e g + , XmlContent g, Parse g, Show g, Descriptor g) => + State g n e -> g -> n -> e -> GraphOps g n e -> IO () +create state g n e ops = + do{ theFrame <- frame [ text := "Diagram editor" + , position := pt 200 20 + , clientSize := sz 300 240 ] + ; setNetworkFrame theFrame state + + -- Create page setup dialog and save in state + ; pageSetupData <- pageSetupDialogDataCreate + ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData + ; objectDelete pageSetupData + ; setPageSetupDialog initialPageSetupDialog state + + -- Drawing area + ; let (width, height) = getCanvasSize (Network.empty g n e) + ; ppi <- getScreenPPI + ; canvas <- scrolledWindow theFrame + [ virtualSize := sz (logicalToScreenX ppi width) + (logicalToScreenY ppi height) + , scrollRate := sz 10 10 + , bgcolor := wxcolor paneBackgroundColor + , fullRepaintOnResize := False + ] + ; State.setCanvas canvas state + + -- Dummy persistent document to pass around + ; pDoc <- getDocument state + + -- Attach handlers to drawing area + ; set canvas + [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc + , on mouse := \p -> safetyNet theFrame $ + do mouseEvent p canvas theFrame state + --; focusOn canvas + , on keyboard := \k -> safetyNet theFrame $ + do keyboardEvent theFrame state k + --; focusOn canvas + ] + + -- File menu + ; fileMenu <- menuPane [ text := "&File" ] + ; menuItem fileMenu + [ text := "New\tCtrl+N" + , on command := safetyNet theFrame $ newItem state g n e + ] + ; menuItem fileMenu + [ text := "Open...\tCtrl+O" + , on command := safetyNet theFrame $ openItem theFrame state + ] + ; saveItem <- menuItem fileMenu + [ text := "Save\tCtrl+S" + , on command := safetyNet theFrame $ PD.save pDoc + ] + ; menuItem fileMenu + [ text := "Save as..." + , on command := safetyNet theFrame $ PD.saveAs pDoc + ] + + ; menuLine fileMenu + + ; menuItem fileMenu + [ text := "Page setup..." + , on command := safetyNet theFrame $ + do{ psd <- getPageSetupDialog state + ; dialogShowModal psd + ; return () + } + ] + + ; menuItem fileMenu + [ text := "Print..." + , on command := safetyNet theFrame $ + let printFun _ printInfo _ dc _ = + do { dcSetUserScale dc + (fromIntegral (sizeW (printerPPI printInfo)) + / fromIntegral (sizeW (screenPPI printInfo))) + (fromIntegral (sizeH (printerPPI printInfo)) + / fromIntegral (sizeH (screenPPI printInfo))) + ; paintHandler state dc + } + pageFun _ _ _ = (1, 1) + in + do{ psd <- getPageSetupDialog state + ; printDialog psd "Blobs print" pageFun printFun + } + ] + + ; menuItem fileMenu + [ text := "Print preview" + , on command := safetyNet theFrame $ + let printFun _ _ _ dc _ = paintHandler state dc + pageFun _ _ _ = (1, 1) + in + do{ psd <- getPageSetupDialog state + ; printPreview psd "Blobs preview" pageFun printFun + } + ] + + ; menuLine fileMenu + + ; menuItem fileMenu + [ text := "E&xit" + , on command := close theFrame + ] + + -- Edit menu + ; editMenu <- menuPane [ text := "&Edit" ] + ; undoItem <- menuItem editMenu + [ on command := safetyNet theFrame $ do PD.undo pDoc; repaintAll state ] + ; redoItem <- menuItem editMenu + [ on command := safetyNet theFrame $ do PD.redo pDoc; repaintAll state ] + ; menuLine editMenu + ; menuItem editMenu + [ text := "Edit "++descriptor g++"..." + , on command := safetyNet theFrame $ changeGlobalInfo theFrame state + ] + ; menuItem editMenu + [ text := "Change shape palette..." + , on command := safetyNet theFrame $ openPalette theFrame state + ] + + -- View menu + ; viewMenu <- menuPane [ text := "&View" ] + ; (DP opts) <- getDisplayOptions state + ; menuItem viewMenu + [ text := descriptor g + , checkable := True + , checked := GlobalInfo `elem` opts + , on command := safetyNet theFrame $ do + { changeDisplayOptions (toggle GlobalInfo) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Node Labels" + , checkable := True + , checked := NodeLabel `elem` opts + , on command := safetyNet theFrame $ do + { changeDisplayOptions (toggle NodeLabel) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Node Info" + , checkable := True + , checked := NodeInfo `elem` opts + , on command := safetyNet theFrame $ do + { changeDisplayOptions (toggle NodeInfo) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Edge Info" + , checkable := True + , checked := EdgeInfo `elem` opts + , on command := safetyNet theFrame $ do + { changeDisplayOptions (toggle EdgeInfo) state + ; repaintAll state } ] + + -- Operations menu + ; opsMenu <- menuPane [ text := "&Operations" ] + ; mapM_ (\ (name,_)-> + menuItem opsMenu + [ text := name + , on command := safetyNet theFrame $ do + { callGraphOp name ops state + ; repaintAll state } + ] + ) (ioOps ops) + + ; PD.initialise pDoc (PD.PD + { PD.document = Document.empty g n e + , PD.history = [] + , PD.future = [] + , PD.limit = Nothing + , PD.fileName = Nothing + , PD.dirty = False + , PD.saveToDisk = saveToDisk theFrame + , PD.updateUndo = PD.defaultUpdateUndo undoItem + , PD.updateRedo = PD.defaultUpdateRedo redoItem + , PD.updateSave = PD.defaultUpdateSave saveItem + , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame "Blobs" + , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame "Blobs" + , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions + }) + + -- Layout the main window + ; set theFrame + [ menuBar := [ fileMenu, editMenu, viewMenu, opsMenu ] + , layout := minsize (sz 300 240) $ fill $ widget canvas + , on closing := safetyNet theFrame $ exit state + ] + + -- ; set theFrame + -- [ position := pt 200 20 + -- , clientSize := sz 300 240 + -- ] + } + +paintHandler :: (InfoKind n g, InfoKind e g, Descriptor g) => + State g n e -> DC () -> IO () +paintHandler state dc = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; dp <- getDisplayOptions state + ; drawCanvas doc dc dp + } + +extensions :: [(String, [String])] +extensions = [ ("Blobs files (.blobs)", ["*.blobs"]) ] + +mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => + EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO () +mouseEvent eventMouse canvas theFrame state = case eventMouse of + MouseLeftDown mousePoint mods + | shiftDown mods -> leftMouseDownWithShift mousePoint state + | metaDown mods -> leftMouseDownWithMeta mousePoint state + | otherwise -> mouseDown True mousePoint theFrame state + MouseRightDown mousePoint _ -> + mouseDown False mousePoint theFrame state + MouseLeftDrag mousePoint _ -> + leftMouseDrag mousePoint canvas state + MouseLeftUp mousePoint _ -> + leftMouseUp mousePoint state + _ -> + return () + +keyboardEvent :: (InfoKind n g, InfoKind e g) => + Frame () -> State g n e -> EventKey -> IO () +keyboardEvent theFrame state (EventKey theKey _ _) = + case theKey of + KeyDelete -> deleteKey state + KeyBack -> backspaceKey state + KeyF2 -> f2Key theFrame state + KeyChar 'r' -> pressRKey theFrame state + KeyChar 'i' -> pressIKey theFrame state + KeyUp -> upKey state + KeyDown -> downKey state + _ -> propagateEvent + +closeDocAndThen :: State g n e -> IO () -> IO () +closeDocAndThen state action = + do{ pDoc <- getDocument state + ; continue <- PD.isClosingOkay pDoc + ; when continue $ action + } + +newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO () +newItem state g n e = + closeDocAndThen state $ + do{ pDoc <- getDocument state + ; PD.resetDocument Nothing (Document.empty g n e) pDoc + ; repaintAll state + } + +openItem :: (InfoKind n g, InfoKind e g, XmlContent g) => + Frame () -> State g n e -> IO () +openItem theFrame state = + do{ mbfname <- fileOpenDialog + theFrame + False -- change current directory + True -- allowReadOnly + "Open File" + extensions + "" "" -- no default directory or filename + ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame) + } + +-- Third argument: Nothing means exceptions are ignored (used in Configuration) +-- Just f means exceptions are shown in a dialog on top of frame f +openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) => + String -> State g n e -> Maybe (Frame ()) -> IO () +openNetworkFile fname state exceptionsFrame = + closeDocAndThen state $ + flip catch + (\exc -> case exceptionsFrame of + Nothing -> return () + Just f -> errorDialog f "Open network" + ( "Error while opening '" ++ fname ++ "'. \n\n" + ++ "Reason: " ++ show exc) + ) $ + do{ contents <- strictReadFile fname + ; let errorOrNetwork = NetworkFile.fromString contents + ; case errorOrNetwork of { + Left err -> ioError (userError err); + Right (network, warnings, oldFormat) -> + do{ -- "Open" document + ; let newDoc = setNetwork network (Document.empty undefined undefined undefined) + ; pDoc <- getDocument state + ; PD.resetDocument (if null warnings then Just fname else Nothing) + newDoc pDoc + ; applyCanvasSize state + ; when (not (null warnings)) $ + case exceptionsFrame of + Nothing -> return () + Just f -> + do{ errorDialog f "File read warnings" + ( "Warnings while reading file " ++ show fname ++ ":\n\n" + ++ unlines ( map ("* " ++) (take 10 warnings) + ++ if length warnings > 10 then ["..."] else [] + ) + ++ unlines + [ "" + , "Most likely you are reading a file that is created by a newer version of Blobs. If you save this file with" + , "this version of Blobs information may be lost. For safety the file name is set to \"untitled\" so that you do" + , "not accidentaly overwrite the file" + ] + ) + ; PD.setFileName pDoc Nothing + } + ; when oldFormat $ + do{ case exceptionsFrame of + Nothing -> return () + Just f -> + errorDialog f "File read warning" $ + unlines + [ "The file you opened has the old Blobs file format which will become obsolete in newer versions of Blobs." + , "When you save this network, the new file format will be used. To encourage you to do so the network has" + , "been marked as \"modified\"." + ] + ; PD.setDirty pDoc True + } + ; -- Redraw + ; repaintAll state + }}} + +openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO () +openPalette theFrame state = + do{ mbfname <- fileOpenDialog + theFrame + False -- change current directory + True -- allowReadOnly + "Open File" + [ ("Shape palettes (.blobpalette)", ["*.blobpalette"]) ] + "" "" -- no default directory or filename + ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame) + } + +-- Third argument: Nothing means exceptions are ignored (used in Configuration) +-- Just f means exceptions are shown in a dialog on top of frame f +openPaletteFile :: (InfoKind n g, Parse n) => + String -> State g n e -> Maybe (Frame ()) -> IO () +openPaletteFile fname state exceptionsFrame = + flip catch + (\exc -> case exceptionsFrame of + Nothing -> return () + Just f -> errorDialog f "Open shape palette" + ( "Error while opening '" ++ fname ++ "'. \n\n" + ++ "Reason: " ++ show exc) + ) $ + do{ contents <- readFile fname + -- ; return () -- Dummy out for now + ; case fst (runParser parse contents) of { + Left msg -> ioError (userError ("Cannot parse shape palette file: " + ++fname++"\n\t"++msg)); + Right p -> do{ pDoc <- getDocument state + ; PD.updateDocument "change palette" + (updateNetwork (setPalette p)) + -- really ought to go through network and + -- change all nodes' stored shape. + pDoc + } + } + } + +-- | Get the canvas size from the network and change the size of +-- the widget accordingly +applyCanvasSize :: State g n e -> IO () +applyCanvasSize state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + (width, height) = getCanvasSize network + ; canvas <- getCanvas state + ; ppi <- getScreenPPI + ; set canvas [ virtualSize := sz (logicalToScreenX ppi width) + (logicalToScreenY ppi height) ] + } + +saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) => + Frame () -> String -> Document.Document g n e -> IO Bool +saveToDisk theFrame fileName doc = + safeWriteFile theFrame fileName (NetworkFile.toString (getNetwork doc)) + +exit :: State g n e -> IO () +exit state = + closeDocAndThen state $ propagateEvent diff --git a/src/NetworkView.hs b/src/NetworkView.hs new file mode 100644 --- /dev/null +++ b/src/NetworkView.hs @@ -0,0 +1,342 @@ +module NetworkView + ( drawCanvas + , clickedNode + , clickedEdge + , clickedVia + , edgeContains + ) where + +import Constants +import CommonIO +import Network +import Document +import Colors +import Common +import Palette + +import Math +import Graphics.UI.WX as WX hiding (Vector) +import Graphics.UI.WXCore hiding (Document, screenPPI, Colour) +import Graphics.UI.WXCore.Draw +import Maybe +import Shape +import DisplayOptions +import InfoKind + +import Prelude hiding (catch) +import Control.Exception +import qualified Data.IntMap as IntMap + +drawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => + Document g n e -> DC () -> DisplayOptions -> IO () +drawCanvas doc dc opt = + do{ + + -- Scale if the DC we are drawing to has a different PPI from the screen + -- Printing, nudge, nudge + ; dcPPI <- dcGetPPI dc + ; screenPPI <- getScreenPPI + ; when (dcPPI /= screenPPI) $ + dcSetUserScale dc + (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI )) + (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI )) + + -- Set font + ; set dc [ fontFamily := FontDefault, fontSize := 10 ] + + ; catch (reallyDrawCanvas doc screenPPI dc opt) + (h1 dc dcPPI ) + {- + (\e -> logicalText dcPPI dc (DoublePoint 50 50) + ("Exception while drawing: "++show e) + (Justify LeftJ TopJ) [] ) + -} + } + +h1 :: DC () -> Size2D Int -> SomeException -> IO () +h1 dc dcPPI e = logicalText dcPPI dc (DoublePoint 50 50) + ("Exception while drawing: "++show e) + (Justify LeftJ TopJ) [] + + +reallyDrawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => + Document g n e -> Size -> DC () -> DisplayOptions -> IO () +reallyDrawCanvas doc ppi dc opt = + do{ + -- draw global info on diagram + ; let (width, _height) = Network.getCanvasSize network + ; when (GlobalInfo `elem` dpShowInfo opt) $ + drawLabel 0 False + (descriptor global++": "++(unwords.lines.show) global) + (DoublePoint (width/2) 1) (Justify CentreJ TopJ) + [ textColor := wxcolor kNodeLabelColour ] + -- draw edges, highlight the selected ones (if any) + ; mapM_ (\edge -> drawEdge edge []) (getEdges network) + ; case theSelection of + EdgeSelection edgeNr -> do + drawEdge (getEdge edgeNr network) kSELECTED_OPTIONS + ViaSelection edgeNr viaNr -> do + drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS + MultipleSelection _ _ viaNrs -> do + mapM_ (\ (e,v)-> drawVia (getEdge e network) v kSELECTED_OPTIONS) + viaNrs + _ -> return () + + -- draw nodes, highlight the selected ones (if any) + ; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network) + ; case theSelection of + NodeSelection nodeNr -> + drawNode nodeNr (kSELECTED_OPTIONS + ++ [ penColor := wxcolor activeSelectionColor ]) + MultipleSelection _ nodeNrs _ -> + mapM_ (\n-> drawNode n (kSELECTED_OPTIONS + ++ [ penColor := wxcolor activeSelectionColor ])) + nodeNrs + _ -> return () + + -- multiple selection drag area rectangle + ; case theSelection of + MultipleSelection (Just (p,q)) _ _ -> + logicalRect ppi dc (doublePointX p) (doublePointY p) + (doublePointX q - doublePointX p) + (doublePointY q - doublePointY p) + [ penColor := wxcolor lightGrey + , brushKind := BrushTransparent] + _ -> return () + + -- canvas size rectangle + -- ; let (width, height) = Network.getCanvasSize (getNetwork doc) + -- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent] + } + where + network = getNetwork doc + theSelection = getSelection doc + (Palette palette) = getPalette network + global = getGlobalInfo network + + drawNode :: Int -> [Prop (DC ())] -> IO () + drawNode nodeNr options = + do{ + -- draw node + ; logicalDraw ppi dc center shape options + -- ; logicalCircle ppi dc center kNODE_RADIUS options + -- draw label + ; when (NodeLabel `elem` dpShowInfo opt) $ + drawLabel (offset above) False (getName node) center + (justif above) [ textColor := wxcolor kNodeLabelColour ] + -- draw info + ; when (NodeInfo `elem` dpShowInfo opt) $ + drawLabel (offset (not above)) False (show (getInfo node)) + center (justif (not above)) + [ textColor := wxcolor kNodeInfoColour ] + } + where + node = getNode nodeNr network + above = getNameAbove node + center = getPosition node + shape = either (\name-> maybe Shape.circle fst + (Prelude.lookup name palette)) + id (getShape node) + offset b = (if b then negate else id) kNODE_RADIUS + justif b = Justify CentreJ (if b then BottomJ else TopJ) + + drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify + -> [Prop (DC ())] -> IO () + drawLabel voffset boxed text (DoublePoint x y) justify opts = + do{ -- draw background + when boxed $ do + { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text + ; let horizontalMargin = 0.2 -- centimeters + verticalMargin = 0.01 -- centimeters + topleftY = y+voffset - case justify of + Justify _ TopJ -> 0 + Justify _ MiddleJ -> textHeight/2 + Justify _ BottomJ -> textHeight + + ; logicalRect ppi dc + (x - textWidth/2 - horizontalMargin) (topleftY) + (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin) + (solidFill labelBackgroundColor) + } + -- draw text + ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts + } + + drawEdge :: InfoKind e g => Edge e -> [Prop (DC ())] -> IO () + drawEdge edge options = + do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options + -- arrow on the end + ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice) + -- draw info + ; when (EdgeInfo `elem` dpShowInfo opt) $ + -- logicalTextRotated ppi dc (middle via) (show info) 45 + -- [ textColor := wxcolor kEdgeInfoColour ] + drawLabel 0 False (show (getEdgeInfo edge)) (middle via) + (Justify CentreJ BottomJ) + [ textColor := wxcolor kEdgeInfoColour ] + } + where + fromNode = getNode (getEdgeFrom edge) network + toNode = getNode (getEdgeTo edge) network + + fromPoint = getPosition fromNode + toPoint = getPosition toNode + via = getEdgeVia edge + + fstEdgeVector = (head (via++[toPoint])) + `subtractDoublePointVector` fromPoint + fstTotalLen = vectorLength fstEdgeVector + fstAngle = vectorAngle fstEdgeVector + + penultimatePt = head (reverse (fromPoint:via)) + endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt + endTotalLen = vectorLength endEdgeVector + endAngle = vectorAngle endEdgeVector + + middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2) + ((doublePointY pt1 + doublePointY pt2)/2) + middle [p] = p + middle ps = middle (tail (reverse ps)) + + pt1 = translatePolar fstAngle kNODE_RADIUS fromPoint + pt2 = translatePolar endAngle (endTotalLen - kNODE_RADIUS) penultimatePt + + tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2 + tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2 + + drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO () + drawVia e n options = + let pt = (getEdgeVia e)!!n in + do logicalCircle ppi dc pt kEDGE_CLICK_RANGE + (options ++ solidFill violet) + +solidFill :: Colour -> [Prop (DC ())] +solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ] + +-- | Finds which node of the network is clicked by the mouse, if any +clickedNode :: DoublePoint -> Document g n e -> Maybe Int +clickedNode clickedPoint doc = + let network = getNetwork doc + nodeAssocs = case getSelection doc of + NodeSelection nodeNr -> [(nodeNr, getNode nodeNr network)] + _ -> [] + ++ reverse (getNodeAssocs network) + in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of + [] -> Nothing + ((i, _):_) -> Just i + +nodeContains :: Node n -> DoublePoint -> Bool +nodeContains node clickedPoint = + distancePointPoint (getPosition node) clickedPoint + < kNODE_RADIUS + +-- | Finds which edge of the network is clicked by the mouse, if any +clickedEdge :: DoublePoint -> Network g n e -> Maybe Int +clickedEdge clickedPoint network = + let assocs = getEdgeAssocs network + in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of + [] -> Nothing + ((i, _):_) -> Just i + +edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int +edgeContains edge clickedPoint network = + let p0 = getNodePosition network (getEdgeFrom edge) + p1 = getNodePosition network (getEdgeTo edge) + via= getEdgeVia edge + p = clickedPoint + numberedDistancesToSegments = zip [0..] $ + zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p) + (p0:via) (via++[p1]) + in case [ nr | (nr,dist) <- numberedDistancesToSegments + , dist < kEDGE_CLICK_RANGE ] of + [] -> Nothing + nrs -> Just (head nrs) + +-- | Finds which 'via' control point is clicked by the mouse, if any +clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int) +clickedVia clickedPoint network = + let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v)) + [0..] (getEdgeVia e)) + (IntMap.toList (networkEdges network)) + in case filter (\ (_,v)-> distancePointPoint v clickedPoint + < kEDGE_CLICK_RANGE) allVia of + [] -> Nothing + ((kn,_):_) -> Just kn + +-- Drawing operations in logical coordinates + +logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO () +logicalCircle ppi dc center radius options = + WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options + +logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO () +logicalRect ppi dc x y width height options = + drawRect dc + (rect + (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y)) + (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height))) + options + +data Justify = Justify Horizontal Vertical deriving Eq +data Horizontal = LeftJ | CentreJ | RightJ deriving Eq +data Vertical = TopJ | MiddleJ | BottomJ deriving Eq + +-- can deal with multi-line text +logicalText :: Size -> DC () -> DoublePoint -> String -> Justify + -> [Prop (DC ())] -> IO () +logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options = + do{ (width,height) <- logicalGetTextExtent ppi dc txt + ; eachLine width (startPos height) (lines txt) + } + where + startPos height = case vert of TopJ -> (x, y) + MiddleJ -> (x, y-height/2) + BottomJ -> (x, y-height) + eachLine _ _ [] = return () + eachLine maxwidth (x,y) (txt:txts) = + do{ (w,h) <- logicalGetTextExtent ppi dc txt + ; let thisX = case horiz of LeftJ -> x-maxwidth/2 + CentreJ -> x-w/2 + RightJ -> x+(maxwidth/2)-w + ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y)) + options + ; eachLine maxwidth (x,y+h) txts + } + +-- currently assumes only single line of text +logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double + -> [Prop (DC ())] -> IO () +logicalTextRotated ppi dc pos txt angle options = + draw dc txt (logicalToScreenPoint ppi pos) options + where + draw = if angle<1 && angle>(-1) then drawText + else (\a b c e -> rotatedText a b c angle e) + + +{- +logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO () +logicalLine ppi dc fromPoint toPoint options = + line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + +logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () +logicalLineSegments _ _ [p] options = return () +logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = + do{ line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + ; logicalLineSegments ppi dc (toPoint:ps) options + } +-} + +logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () +logicalPoly ppi dc points options = + polygon dc (map (logicalToScreenPoint ppi) points) options + +logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double) +logicalGetTextExtent ppi dc txt = + do{ textSizes <- mapM (getTextExtent dc) (lines txt) + ; return + ( screenToLogicalX ppi (maximum (map sizeW textSizes)) + , screenToLogicalY ppi (sum (map sizeH textSizes)) + ) + } diff --git a/src/Operations.hs b/src/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Operations.hs @@ -0,0 +1,50 @@ +module Operations where + +import InfoKind +import Network +import State +import Document +import qualified PersistentDocument as PD + +import qualified Data.IntMap as IntMap + +-- | @GraphOps@ is a data structure holding a bunch of named operations +-- on the graph network. An operation is simply executed in the I/O monad, +-- taking the entire state as argument - it is up to the action to do any +-- state updates it wants to. +data GraphOps g n e = GraphOps { ioOps :: [ (String, IOOp g n e) ] } + +callGraphOp :: String -> GraphOps g n e -> State g n e -> IO () +callGraphOp opName graphOps state = + maybe (return ()) ($ state) (Prelude.lookup opName (ioOps graphOps)) + +type PureOp g n e = -- (InfoKind n g, InfoKind e g) + (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) + -> (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) +type IOOp g n e = -- (InfoKind n g, InfoKind e g) => + State g n e + -> IO () + +-- | In general, operations can be classified into pure and I/O variants. +-- A pure operation takes a graph and returns a new graph, which is +-- stored back into the current document (can be reverted with the +-- standard 'undo' menu item), and displayed immediately. Use this +-- helper 'pureGraphOp' to turn your pure function into an I/O action +-- for the Operations menu. +pureGraphOp :: (String, PureOp g n e) -> (String, IOOp g n e) +pureGraphOp (opName,operation) = + (opName, \state-> do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + g = getGlobalInfo network + n = networkNodes network + e = networkEdges network + (g',n',e') = operation (g,n,e) + network' = setNodeAssocs (IntMap.assocs n') + $ setEdgeAssocs (IntMap.assocs e') + $ setGlobalInfo g' + $ network + ; PD.updateDocument opName (setNetwork network') pDoc + } + ) + diff --git a/src/PDDefaults.hs b/src/PDDefaults.hs new file mode 100644 --- /dev/null +++ b/src/PDDefaults.hs @@ -0,0 +1,92 @@ +{-| Module : PDDefaults + Author : Arjan van IJzendoorn + License : do whatever you like with this + + Maintainer : afie@cs.uu.nl + + Some defaults for the field of the persistent document + record. For example, the default undo update function + changes the text of a menu item to reflect what will be + undo and disables it if there is nothing to be undone. + You might want more than the defaults if you have a + more advanced GUI. Let's say you also have a button + in a toolbar to undo, then you might want to gray out + that button, too, if there is nothing to be undone. +-} + +module PDDefaults where + +import Graphics.UI.WX +import Graphics.UI.WXCore(wxID_CANCEL) + +type Extensions = [(String, [String])] + +-- Update the menu item "Undo" to show which +-- action will be undone. If there is nothing +-- to undo the corresponding menu item is disabled +defaultUpdateUndo :: MenuItem () -> Bool -> String -> IO () +defaultUpdateUndo undoItem enable message = + set undoItem + [ text := "Undo " ++ message ++ "\tCtrl+Z" + , enabled := enable + ] + +defaultUpdateRedo :: MenuItem () -> Bool -> String -> IO () +defaultUpdateRedo redoItem enable message = + set redoItem + [ text := "Redo " ++ message ++ "\tCtrl+Y" + , enabled := enable + ] + +-- Enable the save item only if the document is dirty +defaultUpdateSave :: MenuItem () -> Bool -> IO () +defaultUpdateSave saveItem enable = + set saveItem [ enabled := enable ] + +-- Update the title bar: program name - document name followed by "(modified)" if +-- the document is dirty +defaultUpdateTitlebar :: Frame () -> String -> Maybe String -> Bool -> IO () +defaultUpdateTitlebar theFrame programName theFileName modified = + let newTitle = programName + ++ " - " + ++ (case theFileName of Nothing -> "untitled"; Just name -> name) + ++ (if modified then " (modified)" else "") + in set theFrame [ text := newTitle ] + +-- | defaultSaveChangesDialog shows a dialog with three buttons with corresponding +-- return values: Don't Save -> Just False, Save -> Just True +-- Cancel -> Nothing +defaultSaveChangesDialog :: Frame () -> String -> IO (Maybe Bool) +defaultSaveChangesDialog parentWindow theProgramName = + do{ d <- dialog parentWindow [text := theProgramName] + ; p <- panel d [] + ; msg <- staticText p [text := "Do you want to save the changes?"] + ; dontsaveB <- button p [text := "Don't Save"] + ; saveB <- button p [text := "Save"] + ; cancelB <- button p [text := "Cancel", identity := wxID_CANCEL ] + ; set d [layout := margin 10 $ container p $ + column 10 [ hfill $ widget msg + , row 50 [ floatBottomLeft $ widget dontsaveB + , floatBottomRight $ row 5 [ widget saveB, widget cancelB] + ] + ] + ] + -- ; set p [ defaultButton := saveB ] + ; set d [ defaultButton := saveB ] + ; showModal d $ \stop -> + do set dontsaveB [on command := stop (Just False) ] + set saveB [on command := stop (Just True) ] + set cancelB [on command := stop Nothing ] + } + +defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String) +defaultSaveAsDialog theFrame extensions theFileName = + fileSaveDialog + theFrame + False -- remember current directory + True -- overwrite prompt + "Save file" + extensions + "" -- directory + (case theFileName of Nothing -> ""; Just name -> name) -- initial file name + diff --git a/src/Palette.hs b/src/Palette.hs new file mode 100644 --- /dev/null +++ b/src/Palette.hs @@ -0,0 +1,29 @@ +module Palette where + +import List (nub, (\\)) +import Shape +import Text.Parse + +data Palette a = Palette [ (String, (Shape, Maybe a)) ] + deriving (Eq, Show, Read) + +shapes :: Palette a -> [ (String,(Shape,Maybe a)) ] +shapes (Palette p) = p + +join :: Eq a => Palette a -> Palette a -> Palette a +join (Palette p) (Palette q) = Palette (nub (p++q)) + +delete :: Eq a => Palette a -> Palette a -> Palette a +delete (Palette p) (Palette q) = Palette (p\\q) + +-- cannot be completely empty, always one default shape +empty :: Palette a +empty = Palette [("circle", (Shape.circle, Nothing))] + +instance Functor Palette where + fmap _ (Palette p) = Palette (map (\ (n,(s,i))-> (n,(s,Nothing))) p) + + +instance Parse a => Parse (Palette a) where + parse = do{ isWord "Palette"; fmap Palette $ parse } + diff --git a/src/PersistentDocument.hs b/src/PersistentDocument.hs new file mode 100644 --- /dev/null +++ b/src/PersistentDocument.hs @@ -0,0 +1,339 @@ +{-| Module : PersistentDocument + Author : Arjan van IJzendoorn + License : do whatever you like with this + + Maintainer : afie@cs.uu.nl + + The persistent document abstraction takes care of dealing + with a document you want to open from and save to disk and + that supports undo. This functionality can be used by editors + of arbitrary documents and saves you a lot of quite subtle + coding. You only need to initialise a record with things like + your document, the file name and call-back functions. After + this, the framework takes care of the hard work. The framework + is highly parametrisable but there are defaults for many + parameters. + + The features in detail: + - unlimited undo & redo buffers (or limited, if you choose to) + - undo and redo items show what will be undone / redone + (e.g. "Undo delete node") + - undo and redo items are disabled if there is nothing to undo or redo + - maintains a dirty bit that tells you whether the document has + changed with respect to the version on disk + - the save menu item can be disabled if the document is not dirty + - the title bar can be updated to show the program name, the file name + and whether the document is dirty (shown as "modified") + - when trying to close the document, the user is asked whether he/she + wants to save the changes (if needed) + - handles interaction between saving a document and the dirty bits + of the document and of the documents in the history and future + - properly handles Cancel or failure at any stage, e.g. the user + closes a dirty document with no file name, "Do you want to save + the changes" dialog is shown, user selects "Save", a Save as + dialog is opened, user selects a location that happens to be + read-only, saving fails and the closing of the document is + cancelled. +-} + +module PersistentDocument + ( PersistentDocument, PDRecord(..) + + , PersistentDocument.dummy + , initialise + , resetDocument + + , setDocument, updateDocument + , superficialSetDocument, superficialUpdateDocument + + , getDocument + , getFileName, setFileName + , setDirty + + , undo, redo + , save, saveAs, isClosingOkay + ) where + +--import IOExts(IORef, newIORef, writeIORef, readIORef) +import Data.IORef(IORef, newIORef, writeIORef, readIORef) +import Monad(when) + +-- | A persistent document is a mutable variable. This way functions +-- operating on a document do not have to return the new value but +-- simply update it. +type PersistentDocument a = IORef (PDRecord a) + +-- | The persistent document record maintains all information needed +-- for undo, redo and file management +data PDRecord a = PD + { document :: a + + -- UNDO & REDO + , history :: [(String, Bool, a)] + -- ^ A history item contains a message (what will be undone), + -- the dirty bit and a copy of the document + , future :: [(String, Bool, a)] + -- ^ See history + , limit :: Maybe Int + -- ^ Maximum number of items of undo history. Or no limit + -- in the case of Nothing + + -- FILE MANAGEMENT + , fileName :: Maybe String + -- ^ Nothing means no file name yet (untitled) + , dirty :: Bool + -- ^ Has the document changed since saving? + + -- CALL-BACK FUNCTIONS + , updateUndo :: Bool -> String -> IO () + -- ^ This callback is called when the undo status changes. First parameter + -- means enable (True) or disable (False). Second parameter is the message + -- of the first item in the history + , updateRedo :: Bool -> String -> IO () + -- ^ See updateUndo + , updateSave :: Bool -> IO () + -- ^ This call-back is called when the save status changes. The boolean + -- indicates whether save is enabled (dirty document) or disabled (not dirty) + , updateTitleBar :: Maybe String -> Bool -> IO () + -- ^ This call-back is called when the title bar information changes: + -- file name and modified or not. + , saveToDisk :: String -> a -> IO Bool + -- ^ This callback should actually save the document to disk. It should + -- return False if saving fails (no permission, disk full...) + , saveChangesDialog :: IO (Maybe Bool) + -- ^ This call-back is called when the user should be prompted whether + -- he/she wants to save the changes or not. Results: + -- Don't Save -> Just False, Save -> Just True, Cancel -> Nothing + , saveAsDialog :: Maybe String -> IO (Maybe String) + -- ^ This call-back is called when the user should specify a + -- location and a name for the file. The parameter is the current + -- file name of the document + } + +-- | A dummy persistent document is needed because you need something to pass +-- to the command handlers of menu items BEFORE you can initialse the +-- persistent document with those menu items +dummy :: IO (PersistentDocument a) +dummy = newIORef (error $ "PersistentDocument.empty: call initialise before using " + ++ "the persistent document") + +-- | Initialise the persistent document with menu items (undo, redo, save), +-- information needed for open & save dialogs, for saving and for updating the +-- title bar +initialise :: PersistentDocument a -> PDRecord a -> IO () +initialise pDocRef pDoc = + do{ writeIORef pDocRef pDoc + ; updateGUI pDocRef + } + +-- | Clear the document and start with a given document with given file name +-- This function is typically called when you open a new document from disk +-- or start a fresh document that should replace the current document +resetDocument :: Maybe String -> a -> PersistentDocument a -> IO () +resetDocument theFileName doc pDocRef = + do{ updateIORef pDocRef (\pDoc -> pDoc + { document = doc + , history = [] + , future = [] + , fileName = theFileName + , dirty = False + }) + ; updateGUI pDocRef + } + +-- | Get the actual document stored within the persistent document +getDocument :: PersistentDocument a -> IO a +getDocument pDocRef = + do{ pDoc <- readIORef pDocRef + ; return (document pDoc) + } + +-- | Get the file name stored within the persistent document +getFileName :: PersistentDocument a -> IO (Maybe String) +getFileName pDocRef = + do{ pDoc <- readIORef pDocRef + ; return (fileName pDoc) + } + +-- | Get the file name stored within the persistent document +setFileName :: PersistentDocument a -> Maybe String -> IO () +setFileName pDocRef maybeName = + do{ pDoc <- readIORef pDocRef + ; writeIORef pDocRef (pDoc { fileName = maybeName }) + ; updateGUI pDocRef + } + +setDirty :: PersistentDocument a -> Bool -> IO () +setDirty pDocRef newDirtyBit = + do{ pDoc <- readIORef pDocRef + ; writeIORef pDocRef (pDoc { dirty = newDirtyBit }) + ; updateGUI pDocRef + } + +-- | Replace the document inside the persistent document. The current +-- document is remembered in the history list along with the given +-- message. The future list is cleared. +setDocument :: String -> a -> PersistentDocument a -> IO () +setDocument message newDoc pDocRef = + do{ pDoc <- readIORef pDocRef + ; let applyLimit = case limit pDoc of + Nothing -> id + Just nr -> take nr + newPDoc = + pDoc + { document = newDoc + , history = applyLimit $ (message,dirty pDoc,document pDoc):history pDoc + , future = [] + , dirty = True + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + } + + +-- | Get document, apply function, set document +updateDocument :: String -> (a -> a) -> PersistentDocument a -> IO () +updateDocument message fun pDocRef = + do{ doc <- getDocument pDocRef + ; setDocument message (fun doc) pDocRef + } + +-- | Replace the document without remembering the old document in +-- the history. Superficial updates are useful if something as +-- volatile as a selection is part of your document. If the selection +-- changes you don't want to be able to undo it or to mark +-- the document as dirty +superficialSetDocument :: a -> PersistentDocument a -> IO () +superficialSetDocument newDoc pDocRef = + updateIORef pDocRef (\pDoc -> pDoc { document = newDoc }) + +-- | Get document, apply function, superficial set document +superficialUpdateDocument :: (a -> a) -> PersistentDocument a -> IO () +superficialUpdateDocument fun pDocRef = + do{ doc <- getDocument pDocRef + ; superficialSetDocument (fun doc) pDocRef + } + +-- | Check whether closing the document is okay. If the document +-- is dirty, the user is asked whether he/she wants to save the +-- changes. Returns False if this process is cancelled or fails +-- at any point. +isClosingOkay :: PersistentDocument a -> IO Bool +isClosingOkay pDocRef = + do{ pDoc <- readIORef pDocRef + ; if not (dirty pDoc) then return True else + do{ result <- saveChangesDialog pDoc + ; case result of + Nothing -> return False + Just True -> + do{ hasBeenSaved <- save pDocRef + ; return hasBeenSaved + } + Just False -> return True + }} + +-- | Save should be called when "Save" is selected from the file menu. +-- If there is no file name yet, this function acts as if "Save as" +-- was called. It returns False if saving is cancelled or fails. +save :: PersistentDocument a -> IO Bool +save pDocRef = + do{ pDoc <- readIORef pDocRef + ; case fileName pDoc of + Nothing -> saveAs pDocRef + Just name -> performSave name pDocRef + } + +-- | saveAs should be called when "Save As" is selected from the file menu. +-- A dialog is shown where the user can select a location to save document. +-- This function returns False if saving is cancelled or fails. +saveAs :: PersistentDocument a -> IO Bool +saveAs pDocRef = + do{ pDoc <- readIORef pDocRef + ; mbfname <- saveAsDialog pDoc (fileName pDoc) + ; case mbfname of + Just fname -> performSave fname pDocRef + Nothing -> return False + } + + +-- | The current document is stored in the future list +-- and the first element of the history list is taken +-- as the new document +undo :: PersistentDocument a -> IO () +undo pDocRef = + do{ pDoc <- readIORef pDocRef + ; when (not (null (history pDoc))) $ + do{ let (msg, newDirty, newDoc) = head (history pDoc) + newPDoc = pDoc + { document = newDoc + , dirty = newDirty + , history = tail (history pDoc) + , future = (msg, dirty pDoc, document pDoc) : future pDoc + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + }} + +-- | The current document is stored in the history list +-- and the first element of the future list is taken +-- as the new document +redo :: PersistentDocument a -> IO () +redo pDocRef = + do{ pDoc <- readIORef pDocRef + ; when (not (null (future pDoc))) $ + do{ let (msg, newDirty, newDoc) = head (future pDoc) + newPDoc = pDoc + { document = newDoc + , dirty = newDirty + , future = tail (future pDoc) + , history = (msg, dirty pDoc, document pDoc) : history pDoc + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + }} + +-- FUNCTIONS THAT ARE NOT EXPORTED + +updateIORef :: IORef a -> (a -> a) -> IO () +updateIORef var fun = do { x <- readIORef var; writeIORef var (fun x) } + +-- Perform the actual save to disk. If this fails False is returned +-- otherwise the file name is set and the dirty bit is cleared. The +-- dirty bits of history and future documents are set. +performSave :: String -> PersistentDocument a -> IO Bool +performSave name pDocRef = + do{ pDoc <- readIORef pDocRef + ; hasBeenSaved <- (saveToDisk pDoc) name (document pDoc) + ; if not hasBeenSaved then return False else + do{ writeIORef pDocRef (pDoc { fileName = Just name }) + ; updateDirtyBitsOnSave pDocRef + ; updateGUI pDocRef + ; return True + }} + +-- updateDirtyBitsOnSave clears the dirty bit for the +-- current document and sets the dirty bits of all +-- documents in history and future lists +updateDirtyBitsOnSave :: PersistentDocument a -> IO () +updateDirtyBitsOnSave pDocRef = + updateIORef pDocRef (\pDoc -> pDoc + { history = map makeDirty (history pDoc) + , future = map makeDirty (future pDoc) + , dirty = False + }) + where + makeDirty (msg, _, doc) = (msg, True, doc) + +-- Shorthand to call all call-backs that update the GUI +updateGUI :: PersistentDocument a -> IO () +updateGUI pDocRef = + do{ pDoc <- readIORef pDocRef + ; case history pDoc of + [] -> updateUndo pDoc False "" + ((msg, _, _):_) -> updateUndo pDoc True msg + ; case future pDoc of + [] -> updateRedo pDoc False "" + ((msg, _, _):_) -> updateRedo pDoc True msg + ; updateSave pDoc (dirty pDoc) + ; updateTitleBar pDoc (fileName pDoc) (dirty pDoc) + } diff --git a/src/SafetyNet.hs b/src/SafetyNet.hs new file mode 100644 --- /dev/null +++ b/src/SafetyNet.hs @@ -0,0 +1,24 @@ +module SafetyNet where + +import Graphics.UI.WX hiding (window) +import Prelude hiding (catch) +import Control.Exception (SomeException,Exception,catch) + + +safetyNet :: Window a -> IO b -> IO () +safetyNet window computation = + do{ catch + (do { computation; return () }) + (handler window) + ; return () + } + +handler :: Window a -> SomeException -> IO () +handler window exception = + do{ putStrLn $ "SafetyNet exception: " ++ show exception + ; errorDialog window "Exception" + ( "An exception occurred; please report the following text exactly to the makers: \n\n" + ++ show exception ++ "\n\n" + ++ "Please save the network under a different name and quit Blobs" + ) + } diff --git a/src/Shape.hs b/src/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Shape.hs @@ -0,0 +1,170 @@ +module Shape where + +import CommonIO +import Graphics.UI.WX as WX +import Graphics.UI.WXCore hiding (Colour) +import Graphics.UI.WXCore.Draw +import Math +import Text.Parse +--import Text.XML.HaXml.XmlContent +--import NetworkFile + +import Colors +import Constants + +data Shape = + Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double } + | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } + -- centred on (0,0) + | Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } + -- no fill for open shape + | Composite { shapeSegments :: [Shape] } -- drawn in given order + deriving (Eq, Show, Read) + +data ShapeStyle = ShapeStyle + { styleStrokeWidth :: Int + , styleStrokeColour :: Colour + , styleFill :: Colour + } + deriving (Eq, Show, Read) + +instance Parse Shape where + parse = oneOf + [ do{ isWord "Circle" + ; return Circle + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapeRadius" + `discard` isWord "}" + } + , do{ isWord "Polygon" + ; return Polygon + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapePerimeter" + `discard` isWord "}" + } + , do{ isWord "Lines" + ; return Lines + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapePerimeter" + `discard` isWord "}" + } + , do{ isWord "Composite" + ; return Composite + `discard` isWord "{" `apply` field "shapeSegments" + `discard` isWord "}" + } + ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Composite)") + +instance Parse ShapeStyle where + parse = do{ isWord "ShapeStyle" + ; return ShapeStyle + `discard` isWord "{" `apply` field "styleStrokeWidth" + `discard` isWord "," `apply` field "styleStrokeColour" + `discard` isWord "," `apply` field "styleFill" + `discard` isWord "}" + } + +{- +instance HTypeable Shape where + toHType s = Defined "Shape" [] [ Constr "Circle" [] [] + , Constr "Polygon" [] [] + , Constr "Lines" [] [] + , Constr "Composite" [] [] + ] +instance XmlContent Shape where + toContents s@(Circle{}) = + [ mkElemC "Circle" (toContents (shapeStyle s) + ++ [mkElemC "radius" (toContents (shapeRadius s))]) ] + toContents s@(Polygon{}) = + [ mkElemC "Polygon" (toContents (shapeStyle s) + ++ [mkElemC "perimeter" (concatMap toContents + (shapePerimeter s))]) ] + toContents s@(Lines{}) = + [ mkElemC "Lines" (toContents (shapeStyle s) + ++ [mkElemC "perimeter" (concatMap toContents + (shapePerimeter s))]) ] + toContents s@(Composite{}) = + [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ] + parseContents = do + { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] + ; case t of + "Circle" -> interior e $ + do{ style <- parseContents + ; r <- inElement "radius" parseContents + ; return (Circle {shapeStyle=style, shapeRadius=r}) + } + "Polygon" -> interior e $ + do{ style <- parseContents + ; p <- inElement "perimeter" $ many1 parseContents + ; return (Polygon {shapeStyle=style, shapePerimeter=p}) + } + "Lines" -> interior e $ + do{ style <- parseContents + ; p <- inElement "perimeter" $ many1 parseContents + ; return (Lines {shapeStyle=style, shapePerimeter=p}) + } + "Composite" -> interior e $ do{ ss <- many1 parseContents + ; return (Composite {shapeSegments=ss}) + } + } + +instance HTypeable ShapeStyle where + toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []] +instance XmlContent ShapeStyle where + toContents s = + [ mkElemC "ShapeStyle" + [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s)) + , mkElemC "StrokeColour" (toContents (styleStrokeColour s)) + , mkElemC "Fill" (toContents (styleFill s)) + ] + ] + parseContents = inElement "ShapeStyle" $ do + { w <- inElement "StrokeWidth" parseContents + ; c <- inElement "StrokeColour" parseContents + ; f <- inElement "Fill" parseContents + ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c + , styleFill=f }) + } +-} + +logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO () +logicalDraw ppi dc centre shape options = + case shape of + Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre) + (logicalToScreenX ppi (shapeRadius shape)) + (style2options (shapeStyle shape)++options) + Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi + . translate centre) + (shapePerimeter shape)) + (style2options (shapeStyle shape)++options) + Lines {} -> logicalLineSegments ppi dc (map (translate centre) + (shapePerimeter shape)) + (style2options (shapeStyle shape)++options) + Composite {}-> mapM_ (\s-> logicalDraw ppi dc centre s options) + (shapeSegments shape) + +logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () +logicalLineSegments _ _ [_p] _options = return () +logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = + do{ line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + ; logicalLineSegments ppi dc (toPoint:ps) options + } + +circle :: Shape +circle = Circle { shapeStyle = defaultShapeStyle + , shapeRadius = kNODE_RADIUS } + +style2options :: ShapeStyle -> [Prop (DC ())] +style2options sty = + [ penWidth := styleStrokeWidth sty + , penColor := wxcolor (styleStrokeColour sty) + , brushKind := BrushSolid + , brushColor := wxcolor (styleFill sty) + ] + +defaultShapeStyle :: ShapeStyle +defaultShapeStyle = + ShapeStyle { styleStrokeWidth = 1 + , styleStrokeColour = licorice + , styleFill = nodeColor } diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -0,0 +1,108 @@ +module State + ( State + , State.empty + , ToolWindow(..) + + , getDocument + , getDragging, setDragging + , getCanvas, setCanvas + , getNetworkFrame, setNetworkFrame + , getPageSetupDialog, setPageSetupDialog + , getDisplayOptions, setDisplayOptions + , changeDisplayOptions + ) where + +import Document +import Math +import qualified PersistentDocument as PD +import DisplayOptions + +import Graphics.UI.WX +import Graphics.UI.WXCore hiding (Document, ToolWindow) + +type State g n e = Var (StateRecord g n e) + +data StateRecord g n e = St + { stDocument :: PD.PersistentDocument (Document g n e) + , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node) + , stNetworkFrame :: Frame () + , stCanvas :: ScrolledWindow () + , stPageSetupDialog :: PageSetupDialog () + , stDisplayOptions :: DisplayOptions + } + +data ToolWindow = TW + { twRepaint :: IO () + , twFrame :: Frame () + } + +empty :: IO (State g n e) +empty = + do{ dummy <- PD.dummy + + ; varCreate (St + { stDocument = dummy + , stNetworkFrame = error "State.empty: network frame has not been set" + , stDragging = Nothing + , stCanvas = error "State.empty: canvas has not been set" + , stPageSetupDialog = error "State.empty: page setup dialog has not been set" + , stDisplayOptions = DisplayOptions.standard + }) + } + +-- Getters + +getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e)) +getDocument = getFromState stDocument + +getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint)) +getDragging = getFromState stDragging + +getNetworkFrame :: State g n e -> IO (Frame ()) +getNetworkFrame = getFromState stNetworkFrame + +getCanvas :: State g n e -> IO (ScrolledWindow ()) +getCanvas = getFromState stCanvas + +getPageSetupDialog :: State g n e -> IO (PageSetupDialog ()) +getPageSetupDialog = getFromState stPageSetupDialog + +getDisplayOptions :: State g n e -> IO DisplayOptions +getDisplayOptions = getFromState stDisplayOptions + +-- Setters + +setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO () +setDragging theDragging stateRef = + varUpdate_ stateRef (\state -> state { stDragging = theDragging }) + +setNetworkFrame :: Frame () -> State g n e -> IO () +setNetworkFrame networkFrame stateRef = + varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame }) + +setCanvas :: ScrolledWindow () -> State g n e -> IO () +setCanvas canvas stateRef = + varUpdate_ stateRef (\state -> state { stCanvas = canvas }) + +setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO () +setPageSetupDialog thePageSetupDialog stateRef = + varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog }) + +setDisplayOptions :: DisplayOptions -> State g n e -> IO () +setDisplayOptions dp stateRef = + varUpdate_ stateRef (\state -> state { stDisplayOptions = dp }) + +changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO () +changeDisplayOptions dpf stateRef = + varUpdate_ stateRef + (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) }) + +-- Utility functions + +getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a +getFromState selector stateRef = do + state <- varGet stateRef + return (selector state) + +varUpdate_ :: Var a -> (a -> a) -> IO () +varUpdate_ var fun = do { varUpdate var fun; return () } diff --git a/src/StateUtil.hs b/src/StateUtil.hs new file mode 100644 --- /dev/null +++ b/src/StateUtil.hs @@ -0,0 +1,26 @@ +module StateUtil + ( repaintAll + , getNetworkName + ) where + +import State +import Common +import qualified PersistentDocument as PD + +import Maybe +import Graphics.UI.WX + +repaintAll :: State g n e -> IO () +repaintAll state = + do{ canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + } + +getNetworkName :: State g n e -> IO String +getNetworkName state = + do { pDoc <- getDocument state + ; mFilename <- PD.getFileName pDoc + ; case mFilename of + Just filename -> return $ removeExtension filename + Nothing -> return "Untitled" + } diff --git a/src/XTC.hs b/src/XTC.hs new file mode 100644 --- /dev/null +++ b/src/XTC.hs @@ -0,0 +1,458 @@ +{-# OPTIONS -fglasgow-exts #-} +{- + | Module : XTC + Maintainer : martijn@cs.uu.nl + + eXtended & Typed Controls for wxHaskell + + + TODO: - how to handle duplicates (up to presentation) in item lists + - check (!!) error that occured in Dazzle + - implement tSelecting and other events + - Check: instance selection etc. () or a + - Maybe it should be () to prevent subclassing (which may cause a problem + with the client data field + - Items w String?? + - value of selection when nothing selected? add Maybe? + - WxObject vs Object? +-} + +module XTC ( Labeled( toLabel ), + , TValued( tValue ), + , TItems( tItems ), + , TSelection( tSelection ), + , TSelections( tSelections ), + , RadioView, mkRadioView, mkRadioViewEx + , ListView, mkListView, mkListViewEx + , MultiListView, mkMultiListView, mkMultiListViewEx + , ChoiceView, mkChoiceView, mkChoiceViewEx + , ComboView, mkComboView, mkComboViewEx + , ValueEntry, mkValueEntry, mkValueEntryEx + , change -- TODO wx should take care of this +-- , ObservableVar, mkObservableVar -- temporarily disabled due to name clash + , xtc -- for testing, exported to avoid a warning in Dazzle + ) where + +import Graphics.UI.WX hiding (window, label) +import qualified Graphics.UI.WX +import Graphics.UI.WXCore hiding (label, Event) +import List +import Maybe + +class Labeled x where + toLabel :: x -> String + +instance Labeled String where + toLabel str = str + +class Selection w => TSelection x w | w -> x where + tSelection :: Attr w x + +class Selections w => TSelections x w | w -> x where + tSelections :: Attr w [x] + +class Items w String => TItems x w | w -> x where + tItems :: Attr w [x] + + +-- RadioView + +data CRadioView x b + +type RadioView x b = RadioBox (CRadioView x b) + +-- TODO: instance of tItems? +instance Labeled x => TSelection x (RadioView x ()) where + tSelection + = newAttr "tSelection" viewGetTSelection viewSetTSelection + +mkRadioView :: Labeled x => Window a -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ()) +mkRadioView window orientation viewItems props = + mkRadioViewEx window toLabel orientation viewItems props + +mkRadioViewEx :: Window a -> (x -> String) -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ()) +mkRadioViewEx window present orientation viewItems props = + do { model <- varCreate viewItems + ; radioView <- fmap objectCast $ radioBox window orientation (map present viewItems) [] + ; objectSetClientData radioView (return ()) (model, present) + ; set radioView props + ; return radioView + } -- cannot use mkViewEx because items must be set at creation (items is not writeable) + +-- ListView + +data CListView a b + +type ListView a b = SingleListBox (CListView a b) + +instance TSelection x (ListView x ()) where + tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection + +instance TItems x (ListView x ()) where + tItems = newAttr "tItems" viewGetTItems viewSetTItems + +mkListView :: Labeled x => Window a -> [Prop (ListView x ())] -> IO (ListView x ()) +mkListView window props = mkListViewEx window toLabel props + +mkListViewEx :: Window a -> (x -> String) -> [Prop (ListView x ())] -> IO (ListView x ()) +mkListViewEx window present props = mkViewEx singleListBox window present props + + +-- MultiListView + +data CMultiListView a b + +type MultiListView a b = MultiListBox (CMultiListView a b) + +instance Labeled x => TSelections x (MultiListView x ()) where + tSelections = newAttr "tSelections" multiListViewGetTSelections multiListViewSetTSelections + +instance Labeled x => TItems x (MultiListView x ()) where + tItems = newAttr "tItems" viewGetTItems viewSetTItems + +mkMultiListView :: Labeled x => Window a -> [Prop (MultiListView x ())] -> IO (MultiListView x ()) +mkMultiListView window props = mkMultiListViewEx window toLabel props + +mkMultiListViewEx :: Window a -> (x -> String) -> [Prop (MultiListView x ())] -> IO (MultiListView x ()) +mkMultiListViewEx window present props = mkViewEx multiListBox window present props + +multiListViewSetTSelections :: MultiListView x () -> [x] -> IO () +multiListViewSetTSelections (multiListView :: MultiListView x ()) selectionItems = + do { Just ((model, present) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData multiListView + ; viewItems <- get model value + ; let labels = map present selectionItems + ; let indices = catMaybes [ findIndex (\it -> present it == label) viewItems + | label <- labels ] + ; set multiListView [ selections := indices ] + } + +multiListViewGetTSelections :: MultiListView x () -> IO [x] +multiListViewGetTSelections multiListView = + do { Just ((model, _) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData multiListView + ; selectedIndices <- get multiListView selections + ; viewItems <- get model value + ; return (map (safeIndex "XTC.multiListViewGetTSelections" viewItems) + selectedIndices) + } + + +-- ChoiceView + +data CChoiceView a b + +type ChoiceView a b = Choice (CChoiceView a b) + +instance Selecting (ChoiceView x ()) where + select = newEvent "select" choiceGetOnCommand choiceOnCommand +-- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of +-- "Selecting (Choice a)". TODO: let/make Daan fix this + +instance Selection (ChoiceView x ()) where + selection = newAttr "selection" choiceGetSelection choiceSetSelection +-- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of +-- "Selection (Choice a)". + +instance TSelection x (ChoiceView x ()) where + tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection + +instance TItems x (ChoiceView x ()) where + tItems = newAttr "tItems" viewGetTItems viewSetTItems + +mkChoiceView :: Labeled x => Window a -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ()) +mkChoiceView window (props :: [Prop (ChoiceView x ())]) = + mkViewEx choice window (toLabel :: x -> String) props + +mkChoiceViewEx :: Window a -> (x -> String) -> Style -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ()) +mkChoiceViewEx window present stl props = + mkViewEx (\win -> choiceEx win stl) window present props + + +-- ComboView + +data CComboView a b + +type ComboView a b = ComboBox (CComboView a b) + + +instance TSelection x (ComboView x ()) where + tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection + +instance TItems x (ComboView x ()) where + tItems = newAttr "tItems" viewGetTItems viewSetTItems + +mkComboView :: Labeled x => Window a -> [Prop (ComboView x ())] -> IO (ComboView x ()) +mkComboView window (props :: [Prop (ComboView x ())]) = + mkViewEx comboBox window (toLabel :: x -> String) props + +mkComboViewEx :: Window a -> (x -> String) -> Style -> [Prop (ComboView x ())] -> IO (ComboView x ()) +mkComboViewEx window present stl props = + mkViewEx (\win -> comboBoxEx win stl) window present props + + + +-- generic mk function that puts a model and a present function in the client data +mkViewEx :: (parent -> [p] -> IO (Object a)) -> parent -> (x -> String) -> [Prop (WxObject b)] -> + IO (WxObject b) +mkViewEx mkView window present props = + do { model <- varCreate [] + ; view <- fmap objectCast $ mkView window [] + ; objectSetClientData view (return ()) (model, present) + ; set view props + ; return view + } + +-- generic set/getTSelection for RadioView, ListView, and ChoiceView + +viewGetTSelection :: TSelection x (WxObject a) => WxObject a -> IO x +viewGetTSelection view = + do { Just ((model, _) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData view + ; selectedIndex <- get view selection + ; viewItems <- get model value + ; return (safeIndex "XTC.viewGetTSelection" viewItems selectedIndex) + } + +-- if non unique, set to first viewItem with same label +-- selection is set to 0 if object is not found, maybe -1 is better? +viewSetTSelection :: TSelection x (WxObject a) => WxObject a -> x -> IO () +viewSetTSelection view selectionItem = + do { Just ((model, present) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData view + ; viewItems <- get model value + ; let label = present selectionItem + ; let index = findLabelIndex present label viewItems + ; set view [ selection := index ] + } + where findLabelIndex :: (x -> String) -> String -> [x] -> Int + findLabelIndex present label theItems = + case findIndex (\it -> present it == label) theItems of + Just ix -> ix + Nothing -> 0 + +viewGetTItems :: TItems x (WxObject a) => WxObject a -> IO [x] +viewGetTItems view = + do { Just ((model, _) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData view + ; viewItems <- get model value + ; return viewItems + } + +viewSetTItems :: TItems x (WxObject a) => WxObject a -> [x] -> IO () +viewSetTItems view viewItems = + do { Just ((model, present) :: (Var [x], x -> String)) <- + unsafeObjectGetClientData view + ; set model [ value := viewItems ] + ; set view [ items := map present viewItems ] + } + + + + + + +-- ValueEntry + +class Parseable x where + parse :: String -> Maybe x + +instance Parseable String where + parse = Just + +{- When a type is instance of Read, a simple Parseable instance can be declared with readParse + e.g. for Int: instance Parseable Int where parse = readParse + +TODO: can we make this some kind of default? +-} +readParse :: Read x => String -> Maybe x +readParse str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +class TValued x w | w -> x where + tValue :: Attr w (Maybe x) + +data CValueEntry x b + +type ValueEntry x b = TextCtrl (CValueEntry x b) + +instance TValued x (ValueEntry x ()) where + tValue + = newAttr "tValue" valueEntryGetTValue valueEntrySetTValue + +mkValueEntry :: (Show x, Read x) => Window b -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ()) +mkValueEntry window props = mkValueEntryEx window show readParse props + +mkValueEntryEx :: Window b -> (x -> String) -> (String -> Maybe x) -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ()) +mkValueEntryEx window present parse props = + do { valueEntry <- fmap objectCast $ textEntry window [] + ; objectSetClientData valueEntry (return ()) (present, parse) + ; set valueEntry $ props ++ [ on change := validate valueEntry ] + + ; return valueEntry + } + where validate :: ValueEntry x () -> IO () + validate valueEntry = + do { mVal <- get valueEntry tValue + ; set valueEntry [ bgcolor := case mVal of -- TODO: add property for error color? + Nothing -> lightgrey + _ -> white + ] + ; repaint valueEntry + } -- drawing a squiggly doesn't work because font metrics are not available + +valueEntryGetTValue :: ValueEntry x () -> IO (Maybe x) +valueEntryGetTValue valueEntry = + do { Just ((_, parse) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry + ; valueStr <- get valueEntry text + ; return $ parse valueStr + } + +valueEntrySetTValue :: ValueEntry x () -> Maybe x -> IO () +valueEntrySetTValue valueEntry mValue = + do { Just ((present, _) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry + ; case mValue of + Nothing -> return () + Just theValue -> set valueEntry [ text := present theValue ] + } + + +class Observable w where + change :: Event w (IO ()) + +instance Observable (TextCtrl a) where + change = newEvent "change" (controlGetOnText) (controlOnText) + + + +-- ObservableVar + +-- add variable as WxObject +{- +type Observer x = (WxObject (), x -> IO ()) + +data ObservableVar x = ObservableVar (Var [Observer x]) (Var x) + +instance Valued ObservableVar where + value + = newAttr "value" observableVarGetValue observableVarSetValue + +mkObservableVar :: x -> IO (ObservableVar x) +mkObservableVar x = + do { observersV <- variable [ value := [] ] + ; var <- variable [ value := x ] + ; return $ ObservableVar observersV var + } + +observableVarGetValue :: ObservableVar x -> IO x +observableVarGetValue (ObservableVar _ var) = get var value + +observableVarSetValue :: ObservableVar x -> x -> IO () +observableVarSetValue (ObservableVar observersV var) x = + do { myObservers <- get observersV value + ; set var [ value := x ] + ; sequence_ [ obs x | (_, obs) <- myObservers ] + } + +class Observable x w | w -> x where + observers :: Attr w [Observer x] + +instance Observable x (ObservableVar x) where + observers + = newAttr "observers" observableVarGetObservers observableVarSetObservers + +observableVarGetObservers :: ObservableVar x -> IO [Observer x] +observableVarGetObservers (ObservableVar observersV _) = get observersV value + +observableVarSetObservers :: ObservableVar x -> [Observer x] -> IO () +observableVarSetObservers (ObservableVar observersV var) myObservers = -- return () + do { set observersV [ value := myObservers ] + ; x <- get var value + ; sequence_ [ obs x | (_, obs) <- myObservers ] + } + + +-- all WxObjects get the event 'change' + +class Observing w where + change :: ObservableVar x -> Event w (x -> IO ()) + +instance Observing (WxObject a) where + change observableVar + = newEvent "change" (getOnObserve observableVar) (setOnObserve observableVar) + +setOnObserve :: ObservableVar x -> Object a -> (x -> IO ()) -> IO () +setOnObserve (ObservableVar observersV var) obj observer = + do { oldObservers <- get observersV value + ; let otherObservers = filter ((/= objectCast obj) . fst) oldObservers + ; set observersV [ value := (objectCast obj, observer) : otherObservers ] + ; x <- get var value + ; observer x + } + +getOnObserve :: ObservableVar x -> Object a -> IO (x -> IO ()) +getOnObserve (ObservableVar observersV _) obj = + do { myObservers <- get observersV value + ; case lookup (objectCast obj) myObservers of + Just obs -> return obs + Nothing -> do { internalError "XTC" "getOnObserve" "object is not an observer" + ; return $ \_ -> return () + } + } +-} + + +-- Utility functions + +safeIndex :: String -> [a] -> Int -> a +safeIndex msg xs i + | i >= 0 && i < length xs = xs !! i + | otherwise = internalError "XTC" "safeIndex" msg + +internalError :: String -> String -> String -> a +internalError moduleName functionName errorString = + error (moduleName ++ "." ++ functionName ++ ": " ++ errorString) + + +-- Test function + +xtc :: IO () +xtc = start $ + do { -- counterV <- mkObservableVar 1 + ; f <- frame [] + + + ; listV <- mkListView f [ tItems := ["sdfsdf", "fdssd"] + , enabled := True + ] + + ; choiceV <- mkChoiceView f [ tItems := ["sdfsdf", "fdssd"] + , enabled := True + ] + ; comboV <- mkComboView f [ tItems := ["sdfsdf", "fdssd"] + , enabled := True + ] + ; t <- textEntry f [] + ; ve <- mkValueEntry f [ tValue := Just True ] + -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ] + + ; bUp <- button f [ text := "increase", on command := do { s1 <- get comboV tSelection + ; s2 <- get listV text + ; print (s1,s2) + } ] -- set counterV [ value :~ (+1) ] ] + -- ; bDown <- button f [ text := "decrease", on command := set counterV [ value :~ (+ (-1::Int)) ] ] + + -- ; bChangeHandler <- button f [ text := "change handler" + -- , on command := set t [ on (change counterV) := \i -> set t [text := "<<"++show i++">>"] ]] + ; set f [ layout := column 5 [ row 5 [ Graphics.UI.WX.label "Counter value:", widget t ] + -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ] + -- , hfloatCenter $ widget bChangeHandler + , widget listV + , widget choiceV + , widget comboV + , widget ve + ] + ] + + } diff --git a/wiring.blobs b/wiring.blobs new file mode 100644 --- /dev/null +++ b/wiring.blobs @@ -0,0 +1,462 @@ +15.09.0-0.5-0.50.5-0.50.50.5-0.50.5-0.50.00.5-0.50.50.5-0.5-0.5-0.50.50.50.00.0-0.5-0.20.50.2-0.50.00.51.41111111111111145.150555555555556sensorTrue-0.5-0.50.5-0.50.50.5-0.50.54.7625000000000015.115277777777779splitterTrue-0.50.00.5-0.50.50.514.146388888888895.080000000000001consolidatorTrue-0.5-0.5-0.50.50.50.017.6388888888888865.08CPUTrue9.6308333333333353.5277777777777777True0.0-0.5-0.20.50.2-0.50.00.59.5955555555555556.526388888888889True0.0-0.5-0.20.50.2-0.50.00.51234257.1261111111111113.52777777777777775312.0650000000000013.5277777777777777267.126111111111116.52638888888888956311.9591666666666676.526388888888889