packages feed

Blobs (empty) → 0.1

raw patch · 45 files changed

+12416/−0 lines, 45 filesdep +HaXmldep +basedep +containerssetup-changedbinary-added

Dependencies added: HaXml, base, containers, directory, haskell98, polyparse, pretty, wx, wxcore

Files

+ Blobs.cabal view
@@ -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 <alan.zimm@gmail.com>+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
+ Blobs.icns view

binary file changed (absent → 32689 bytes)

+ LICENCE-LGPL view
@@ -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.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!+
+ README.md view
@@ -0,0 +1,4 @@+Blobs+=====++Blobs from http://www.cs.york.ac.uk/fp/darcs/Blobs/
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ blobs.png view

binary file changed (absent → 16413 bytes)

+ dazzle.jpg view

binary file changed (absent → 20898 bytes)

+ index.html view
@@ -0,0 +1,234 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">+<html>+<head>+<title>+  Blobs diagram editor+</title>+</head>+ +<body bgcolor='#ffffff'>++<center>+<h1>Blobs</h1>+<h2>a diagram editor in Haskell</h2>+<center>+  <table><tr><td valign="center">+    <img src="blobs.png" alt="Blobs editor with FPTC">+  </td><td valign="center">+    <img src="dazzle.jpg" alt="Dazzle">+  </td></tr></table>+</center>+<hr>++<table><tr><td width=200 align=center>+<a href="#what">What is Blobs?</a><br>+<a href="#use">How do I use it?</a><br>+</td><td width=200 align=center>+<a href="#download">Downloads</a><br>+<a href="#contribute">How can I contribute?</a><br>+</td></tr></table>+</center>+<hr>+++<center><h3><a name="what">What is Blobs?</a></h3></center>+<p>+<b>Blobs</b> 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!++<p>+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.+<ul>+<li> <a href="http://www.cs.uu.nl/dazzle/">Dazzle</a> for bayesian analysis+     of networks;+<li> FPTC for safety analysis of systems designs;+<li> <a href="http://haskell.di.uminho.pt/jmvilaca/INblobs/">INBlobs</a> for+     editing and interpreting Interaction Nets;+</ul>+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.++<p>+What can Blobs do?+<ul>+  <li> Draw nodes with textual labels, and optional extra (polymorphic)+       information labels.+  <li> Connect nodes together with edges.  An edge has optional extra+       information labels.+  <li> You can create palettes of different node shapes, and load a+       palette into the editor.  (Currently, palette creation is by+       hand, not graphical.)+  <li> Graphs are stored in an XML file format.+  <li> If you have a backend engine, you can send the graph to it for+       analysis, receiving a graph back for viewing as a result.+</ul>+++<hr>+<center><h3><a name="download">Downloads</a></h3></center>++<p>+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.++<p>+To use Blobs in your own project, you must collect a copy of the+<a href="http://darcs.net/"><b>darcs</b></a> repository.+<pre>+    darcs get http://www.cs.york.ac.uk/fp/darcs/Blobs+</pre>+The source tree and version history can be browsed on-line through+<a href="http://www.cs.york.ac.uk/fp/darcs/">darcsweb</a>.++<p><b>Copyright:</b> &copy; 2005 the authors and contributors.++<p>+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 <a+href="COPYRIGHT">COPYRIGHT</a> file.++<p><b>License:</b> This software is distributed under+the terms of the LGPL (see file <a href="LICENCE-LGPL">LICENCE-LGPL</a>+for more details), but there is a special exception clause detailed in+file <a href="COPYRIGHT">COPYRIGHT</a>.++<p>+This software comes with no warranty.  Use at your own risk.++<hr>+<center><h3><a name="use">How do I use it?</a></h3></center>+<p>++<p>+<b>Building instructions</b>+<p>+To build Blobs, you need:+<ul>+<li> <a href="http://haskell.org/ghc/">ghc</a>-6.2.2+     (Note 6.4 may work, untested)+<li> <a href="http://www.wxwidgets.org/">wxWidgets</a>+<li> <a href="http://wxhaskell.sourceforge.net/">wxHaskell</a>-0.9.0+     (or later?)+<li> <a href="http://www.cs.york.ac.uk/fp/HaXml-1.14/">HaXml</a>-1.15+     (Note, this <em>unstable</em> version or later is required.)+</ul>++<p>+On Windows you may also need to install+<a href="http://www.mingw.org/">mingw</a> in order to have the GNU make+utility etc.++<p>+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).++<p>+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.++<p>+<b>Usage instructions</b>+<p>+<ul>+<li> Right click on the canvas, nodes, and edges for context menus.+<li> To create a node, shift click on some blank canvas.+<li> To create an edge, select (click) the source node then shift-click+     the target node.+<li> To delete a node or edge, select it and press backspace.+<li> To rearrange the diagram, click and drag nodes to where you want them.+<li> To make an edge look tidier, add a control-point from its context menu,+     and drag the point to where you want it.+<li> 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.+</ul>+++<hr>+<center><h3><a name="contrib">How can I contribute to Blobs?</a></h3></center>+<p>++<p>+Step one: join the+<a href="http://haskell.org/mailman/listinfo/blobs">Blobs mailing list</a>.++<p>+Step two: <tt>darcs send</tt> your patches to the list.++<p>+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.++<p>+<b>To Do list</b>+<p>+<ul>+<li> <b>More than one analysis method.</b>  Currently, there is a <tt>class+     Analysis</tt> with the methods <tt>analysis</tt> and+     <tt>revert</tt>.  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.+     <br><font color="green">Done, MW, 2005-11-16.  The GraphOps datatype+     (in module Operations) replaces the Analysis class. There is a new+     "Operations" menu.</font>+<li> <b>Multiple selection.</b> 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.)+     <br><font color="green">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.</font>+     <br><font color="green">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.</font>+     <br><font color="green">Complete, MW, 2005-11-18.+     Multiple selection by dragging out a rectangle now displays the+     rectangle as well as the selected items.</font>+<li> <b>Positioning guides.</b> 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.+<li> <b>Visible palette.</b> 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.+<li> <b>Palette editor.</b> 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.+<li> <b>Edge palette.</b> Do we need a palette of different edge shapes+     as well as node shapes?+<li> <b>Ports.</b> 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.++</ul>++<hr>+ +</body>+</html>
+ lib/DData/IntBag.hs view
@@ -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+
+ lib/DData/IntMap.hs view
@@ -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, <http://www.cse.ogi.edu/~andy/pub/finite.htm>++  *  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<ky      -> (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<ky      -> (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])])+-}
+ lib/DData/IntSet.hs view
@@ -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, <http://www.cse.ogi.edu/~andy/pub/finite.htm>++  *  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<y       -> (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<y       -> (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))+-}
+ lib/DData/Map.hs view
@@ -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, <http://www.swiss.ai.mit.edu/~adams/BB>.++     * 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) l && bounded (>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])])+-}
+ lib/DData/MultiSet.hs view
@@ -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))
+ lib/DData/Queue.hs view
@@ -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)))+-}
+ lib/DData/Scc.hs view
@@ -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++-}
+ lib/DData/Seq.hs view
@@ -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)++++++++
+ lib/DData/Set.hs view
@@ -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, <http://www.swiss.ai.mit.edu/~adams/BB>.++     * 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) l && bounded (>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))+-}
+ patch.icons view
@@ -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 @@+         <key>CFBundleExecutable</key>+         <string>Blobs</string>+         <key>CFBundleIconFile</key>+-        <string>wxmac.icns</string>++        <string>Blobs.icns</string>+         <key>CFBundleName</key>+         <string>Blobs</string>+         <key>CFBundlePackageType</key>
+ simple.blobpalette view
@@ -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 [] ))+  ]
+ src/Colors.hs view
@@ -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
+ src/Common.hs view
@@ -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 ]
+ src/CommonIO.hs view
@@ -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 ()+    }
+ src/Constants.hs view
@@ -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++
+ src/ContextMenu.hs view
@@ -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 ()+                         }
+ src/DisplayOptions.hs view
@@ -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)
+ src/Document.hs view
@@ -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 }
+ src/GUIEvents.hs view
@@ -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
+ src/InfoKind.hs view
@@ -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+-}
+ src/Main.hs view
@@ -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 -- :-)
+ src/Math.hs view
@@ -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+--   <http://geometryalgorithms.com/Archive/algorithm_0102/algorithm_0102.htm>+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
+ src/Network.hs view
@@ -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) }
+ src/NetworkControl.hs view
@@ -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)+    }+
+ src/NetworkFile.hs view
@@ -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+
+ src/NetworkUI.hs view
@@ -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
+ src/NetworkView.hs view
@@ -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))+        )+    }
+ src/Operations.hs view
@@ -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+                      }+  )+
+ src/PDDefaults.hs view
@@ -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+
+ src/Palette.hs view
@@ -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 }+
+ src/PersistentDocument.hs view
@@ -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)+    }
+ src/SafetyNet.hs view
@@ -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"+        )+    }
+ src/Shape.hs view
@@ -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 }
+ src/State.hs view
@@ -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 () }
+ src/StateUtil.hs view
@@ -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"+    }
+ src/XTC.hs view
@@ -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. <Control> () or <Control> 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+                                         ]+                                 ]+    +    }
+ wiring.blobs view
@@ -0,0 +1,462 @@+<Network+  ><Width+    >15.0</Width+  ><Height+    >9.0</Height+  ><Info><unit/></Info+  ><Palette+    ><Palette+      ><string+	><![CDATA["circle"]]></string+      ><Circle+	><ShapeStyle+	  ><int value="1"+	  /><RGB+	    ><int value="0"+	    /><int value="0"+	    /><int value="0"/></RGB+	  ><RGB+	    ><int value="128"+	    /><int value="200"+	    /><int value="128"/></RGB></ShapeStyle+	><double value="0.5"/></Circle+      ><maybe-list-int+	><list-int/></maybe-list-int+      ><string+	><![CDATA["square"]]></string+      ><Polygon+	><ShapeStyle+	  ><int value="2"+	  /><RGB+	    ><int value="0"+	    /><int value="0"+	    /><int value="0"/></RGB+	  ><RGB+	    ><int value="200"+	    /><int value="128"+	    /><int value="200"/></RGB></ShapeStyle+	><list-DoublePoint+	  ><X+	    >-0.5</X+	  ><Y+	    >-0.5</Y+	  ><X+	    >0.5</X+	  ><Y+	    >-0.5</Y+	  ><X+	    >0.5</X+	  ><Y+	    >0.5</Y+	  ><X+	    >-0.5</X+	  ><Y+	    >0.5</Y></list-DoublePoint></Polygon+      ><maybe-list-int+	><list-int/></maybe-list-int+      ><string+	><![CDATA["triangle left"]]></string+      ><Polygon+	><ShapeStyle+	  ><int value="1"+	  /><RGB+	    ><int value="0"+	    /><int value="0"+	    /><int value="0"/></RGB+	  ><RGB+	    ><int value="128"+	    /><int value="200"+	    /><int value="200"/></RGB></ShapeStyle+	><list-DoublePoint+	  ><X+	    >-0.5</X+	  ><Y+	    >0.0</Y+	  ><X+	    >0.5</X+	  ><Y+	    >-0.5</Y+	  ><X+	    >0.5</X+	  ><Y+	    >0.5</Y></list-DoublePoint></Polygon+      ><maybe-list-int+	><list-int/></maybe-list-int+      ><string+	><![CDATA["triangle right"]]></string+      ><Polygon+	><ShapeStyle+	  ><int value="1"+	  /><RGB+	    ><int value="0"+	    /><int value="0"+	    /><int value="0"/></RGB+	  ><RGB+	    ><int value="128"+	    /><int value="200"+	    /><int value="200"/></RGB></ShapeStyle+	><list-DoublePoint+	  ><X+	    >-0.5</X+	  ><Y+	    >-0.5</Y+	  ><X+	    >-0.5</X+	  ><Y+	    >0.5</Y+	  ><X+	    >0.5</X+	  ><Y+	    >0.0</Y></list-DoublePoint></Polygon+      ><maybe-list-int+	><list-int/></maybe-list-int+      ><string+	><![CDATA["wire"]]></string+      ><Composite+	><list-Shape+	  ><Lines+	    ><ShapeStyle+	      ><int value="2"+	      /><RGB+		><int value="0"+		/><int value="0"+		/><int value="0"/></RGB+	      ><RGB+		><int value="128"+		/><int value="128"+		/><int value="128"/></RGB></ShapeStyle+	    ><list-DoublePoint+	      ><X+		>0.0</X+	      ><Y+		>-0.5</Y+	      ><X+		>-0.2</X+	      ><Y+		>0.5</Y></list-DoublePoint></Lines+	  ><Lines+	    ><ShapeStyle+	      ><int value="2"+	      /><RGB+		><int value="0"+		/><int value="0"+		/><int value="0"/></RGB+	      ><RGB+		><int value="128"+		/><int value="128"+		/><int value="128"/></RGB></ShapeStyle+	    ><list-DoublePoint+	      ><X+		>0.2</X+	      ><Y+		>-0.5</Y+	      ><X+		>0.0</X+	      ><Y+		>0.5</Y></list-DoublePoint></Lines></list-Shape></Composite+      ><maybe-list-int+	><list-int/></maybe-list-int></Palette></Palette+  ><Nodes+    ><Node id="N1"+      ><X+	>1.4111111111111114</X+      ><Y+	>5.150555555555556</Y+      ><Name+	>sensor</Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Polygon+	  ><ShapeStyle+	    ><int value="2"+	    /><RGB+	      ><int value="0"+	      /><int value="0"+	      /><int value="0"/></RGB+	    ><RGB+	      ><int value="200"+	      /><int value="128"+	      /><int value="200"/></RGB></ShapeStyle+	  ><list-DoublePoint+	    ><X+	      >-0.5</X+	    ><Y+	      >-0.5</Y+	    ><X+	      >0.5</X+	    ><Y+	      >-0.5</Y+	    ><X+	      >0.5</X+	    ><Y+	      >0.5</Y+	    ><X+	      >-0.5</X+	    ><Y+	      >0.5</Y></list-DoublePoint></Polygon></Right-Shape></Shape+      ><Info><list-Int/></Info></Node+    ><Node id="N2"+      ><X+	>4.762500000000001</X+      ><Y+	>5.115277777777779</Y+      ><Name+	>splitter</Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Polygon+	  ><ShapeStyle+	    ><int value="1"+	    /><RGB+	      ><int value="0"+	      /><int value="0"+	      /><int value="0"/></RGB+	    ><RGB+	      ><int value="128"+	      /><int value="200"+	      /><int value="200"/></RGB></ShapeStyle+	  ><list-DoublePoint+	    ><X+	      >-0.5</X+	    ><Y+	      >0.0</Y+	    ><X+	      >0.5</X+	    ><Y+	      >-0.5</Y+	    ><X+	      >0.5</X+	    ><Y+	      >0.5</Y></list-DoublePoint></Polygon></Right-Shape></Shape+      ><Info><list-Int/></Info></Node+    ><Node id="N3"+      ><X+	>14.14638888888889</X+      ><Y+	>5.080000000000001</Y+      ><Name+	>consolidator</Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Polygon+	  ><ShapeStyle+	    ><int value="1"+	    /><RGB+	      ><int value="0"+	      /><int value="0"+	      /><int value="0"/></RGB+	    ><RGB+	      ><int value="128"+	      /><int value="200"+	      /><int value="200"/></RGB></ShapeStyle+	  ><list-DoublePoint+	    ><X+	      >-0.5</X+	    ><Y+	      >-0.5</Y+	    ><X+	      >-0.5</X+	    ><Y+	      >0.5</Y+	    ><X+	      >0.5</X+	    ><Y+	      >0.0</Y></list-DoublePoint></Polygon></Right-Shape></Shape+      ><Info><list-Int/></Info></Node+    ><Node id="N4"+      ><X+	>17.638888888888886</X+      ><Y+	>5.08</Y+      ><Name+	>CPU</Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Circle+	  ><ShapeStyle+	    ><int value="1"+	    /><RGB+	      ><int value="0"+	      /><int value="0"+	      /><int value="0"/></RGB+	    ><RGB+	      ><int value="128"+	      /><int value="200"+	      /><int value="128"/></RGB></ShapeStyle+	  ><double value="0.5"/></Circle></Right-Shape></Shape+      ><Info><list-Int/></Info></Node+    ><Node id="N5"+      ><X+	>9.630833333333335</X+      ><Y+	>3.5277777777777777</Y+      ><Name+	><![CDATA[wiring L]]></Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Composite+	  ><list-Shape+	    ><Lines+	      ><ShapeStyle+		><int value="2"+		/><RGB+		  ><int value="0"+		  /><int value="0"+		  /><int value="0"/></RGB+		><RGB+		  ><int value="128"+		  /><int value="128"+		  /><int value="128"/></RGB></ShapeStyle+	      ><list-DoublePoint+		><X+		  >0.0</X+		><Y+		  >-0.5</Y+		><X+		  >-0.2</X+		><Y+		  >0.5</Y></list-DoublePoint></Lines+	    ><Lines+	      ><ShapeStyle+		><int value="2"+		/><RGB+		  ><int value="0"+		  /><int value="0"+		  /><int value="0"/></RGB+		><RGB+		  ><int value="128"+		  /><int value="128"+		  /><int value="128"/></RGB></ShapeStyle+	      ><list-DoublePoint+		><X+		  >0.2</X+		><Y+		  >-0.5</Y+		><X+		  >0.0</X+		><Y+		  >0.5</Y></list-DoublePoint></Lines></list-Shape></Composite></Right-Shape></Shape+      ><Info><list-Int/></Info></Node+    ><Node id="N6"+      ><X+	>9.595555555555555</X+      ><Y+	>6.526388888888889</Y+      ><Name+	><![CDATA[wiring R]]></Name+      ><LabelAbove+	>True</LabelAbove+      ><Shape+	><Right-Shape+	><Composite+	  ><list-Shape+	    ><Lines+	      ><ShapeStyle+		><int value="2"+		/><RGB+		  ><int value="0"+		  /><int value="0"+		  /><int value="0"/></RGB+		><RGB+		  ><int value="128"+		  /><int value="128"+		  /><int value="128"/></RGB></ShapeStyle+	      ><list-DoublePoint+		><X+		  >0.0</X+		><Y+		  >-0.5</Y+		><X+		  >-0.2</X+		><Y+		  >0.5</Y></list-DoublePoint></Lines+	    ><Lines+	      ><ShapeStyle+		><int value="2"+		/><RGB+		  ><int value="0"+		  /><int value="0"+		  /><int value="0"/></RGB+		><RGB+		  ><int value="128"+		  /><int value="128"+		  /><int value="128"/></RGB></ShapeStyle+	      ><list-DoublePoint+		><X+		  >0.2</X+		><Y+		  >-0.5</Y+		><X+		  >0.0</X+		><Y+		  >0.5</Y></list-DoublePoint></Lines></list-Shape></Composite></Right-Shape></Shape+      ><Info><list-Int/></Info></Node></Nodes+  ><Edges+    ><Edge id="E1"+      ><From+	>1</From+      ><To+	>2</To+      ><Via+      /><Info><list-Int/></Info></Edge+    ><Edge id="E3"+      ><From+	>3</From+      ><To+	>4</To+      ><Via+      /><Info><list-Int/></Info></Edge+    ><Edge id="E4"+      ><From+	>2</From+      ><To+	>5</To+      ><Via+	><X+	  >7.126111111111111</X+	><Y+	  >3.5277777777777777</Y></Via+      ><Info><list-Int/></Info></Edge+    ><Edge id="E5"+      ><From+	>5</From+      ><To+	>3</To+      ><Via+	><X+	  >12.065000000000001</X+	><Y+	  >3.5277777777777777</Y></Via+      ><Info><list-Int/></Info></Edge+    ><Edge id="E6"+      ><From+	>2</From+      ><To+	>6</To+      ><Via+	><X+	  >7.12611111111111</X+	><Y+	  >6.5263888888888895</Y></Via+      ><Info><list-Int/></Info></Edge+    ><Edge id="E7"+      ><From+	>6</From+      ><To+	>3</To+      ><Via+	><X+	  >11.959166666666667</X+	><Y+	  >6.526388888888889</Y></Via+      ><Info><list-Int/></Info></Edge></Edges></Network>