diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,62 @@ +The UUST package is (c) copyright 2005 +to the original authors and other contributors listed here. If you add +or modify code, please add your name here. + +Original authors: + Doaitse Swierstra + Arthur Baars +Contributors: + Alexey Rodriguez + +---- +The UUST package is licensed under the terms of the GNU Lesser General Public +Licence (LGPL), which can be found in the file called LICENCE-LGPL, with +the following special exception: + + As a relaxation of clause 6 of the LGPL, the copyright holders of this + library give permission to use, copy, link, modify, and distribute, + binary-only object-code versions of an executable linked with the + original unmodified Library, without requiring the supply of any + mechanism to modify or replace the Library and relink (clauses 6a, + 6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are + complied with. + +This software 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 +License for more details. + +---- +This software depends on library code by Daan Leijen, which +is distributed under the following license: + + The Modified BSD License + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the names of the copyright holders, nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/LICENSE-LGPL b/LICENSE-LGPL new file mode 100644 --- /dev/null +++ b/LICENSE-LGPL @@ -0,0 +1,507 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes a de-facto standard. To achieve this, non-free programs must +be allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at least + three years, to give the same user the materials specified in + Subsection 6a, above, for a charge no more than the cost of + performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,71 @@ +Please check the right section in this file for instructions depending on how you obtained the source files. + + +Installing uulib from a source distribution +------------------------------------------- + + The source distribution can be unpacked from the + .tar.gz files distributed in the following page: + + http://www.cs.uu.nl/wiki/HUT/Download + + System wide installation (assumming GHC is the + Haskell compiler) can be done like this: + + ghc --make Setup.hs -o setup -package Cabal + ./setup configure + ./setup build + ./setup install + + +Installing uulib to a non-standard location +------------------------------------------- + + This is useful if you don't want (or can't) + modify system wide settings. + + ghc --make Setup.hs -o setup -package Cabal + ./setup configure --prefix=/foo + ./setup build + ./setup install --user + + The last command registers the package only for + the user. + + +Installing uulib from the subversion repository +----------------------------------------------- + + Which can be obtained running the following subversion command: + + svn co https://svn.cs.uu.nl:12443/repos/uust-repo/uulib/trunk/ + + Now install following the instructions below: + + autoconf + ./configure + + NOTE: the above instructions are REQUIRED when you install from the + subversion repository. They are not needed when you download a + source distribution. + + This generates uulib.cabal which is needed for the cabal commands: + + ghc --make Setup.hs -o setup -package Cabal + ./setup configure + ./setup build + ./setup install + + If you want to install to a non-standard location + you don't need to pass a path to configure, just follow + the steps outlined above. + + +Optionally generating Haddock Documentation +------------------------------------------- + + Requires cpphs 0.9 + Output generated in dist/doc/html + + ./setup haddock + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ + +import Distribution.Simple +main = defaultMain diff --git a/src/UU/DData/IntBag.hs b/src/UU/DData/IntBag.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/IntBag.hs @@ -0,0 +1,368 @@ +-------------------------------------------------------------------------------- +{-| Module : IntBag + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of bags of integers on top of the "IntMap" module. + + Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements with a maximum of /W/ + -- the number of bits in an 'Int' (32 or 64). For more information, see + the references in the "IntMap" module. +-} +---------------------------------------------------------------------------------} +module UU.DData.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 UU.DData.IntMap as M + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ -- + +-- | /O(n+m)/. See 'difference'. +(\\) :: IntBag -> IntBag -> IntBag +b1 \\ b2 = difference b1 b2 + +{-------------------------------------------------------------------- + IntBags are a simple wrapper around Maps, 'Map.Map' +--------------------------------------------------------------------} +-- | A bag of integers. +newtype IntBag = IntBag (M.IntMap Int) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the bag empty? +isEmpty :: IntBag -> Bool +isEmpty (IntBag m) + = M.isEmpty m + +-- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@). +distinctSize :: IntBag -> Int +distinctSize (IntBag m) + = M.size m + +-- | /O(n)/. The number of elements in the bag. +size :: IntBag -> Int +size b + = foldOccur (\x n m -> n+m) 0 b + +-- | /O(min(n,W))/. Is the element in the bag? +member :: Int -> IntBag -> Bool +member x m + = (occur x m > 0) + +-- | /O(min(n,W))/. The number of occurrences of an element in the bag. +occur :: Int -> IntBag -> Int +occur x (IntBag m) + = case M.lookup x m of + Nothing -> 0 + Just n -> n + +-- | /O(n+m)/. Is this a subset of the bag? +subset :: IntBag -> IntBag -> Bool +subset (IntBag m1) (IntBag m2) + = M.subsetBy (<=) m1 m2 + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) +properSubset :: IntBag -> IntBag -> Bool +properSubset b1 b2 + = subset b1 b2 && (b1 /= b2) + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty bag. +empty :: IntBag +empty + = IntBag (M.empty) + +-- | /O(1)/. Create a singleton bag. +single :: Int -> IntBag +single x + = IntBag (M.single x 0) + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Insert an element in the bag. +insert :: Int -> IntBag -> IntBag +insert x (IntBag m) + = IntBag (M.insertWith (+) x 1 m) + +-- | /O(min(n,W))/. The expression (@insertMany x count bag@) +-- inserts @count@ instances of @x@ in the bag @bag@. +insertMany :: Int -> Int -> IntBag -> IntBag +insertMany x count (IntBag m) + = IntBag (M.insertWith (+) x count m) + +-- | /O(min(n,W))/. Delete a single element. +delete :: Int -> IntBag -> IntBag +delete x (IntBag m) + = IntBag (M.updateWithKey f x m) + where + f x n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(min(n,W))/. Delete all occurrences of an element. +deleteAll :: Int -> IntBag -> IntBag +deleteAll x (IntBag m) + = IntBag (M.delete x m) + +{-------------------------------------------------------------------- + Combine +--------------------------------------------------------------------} +-- | /O(n+m)/. Union of two bags. The union adds the elements together. +-- +-- > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,1,1,2,2,2,3} +union :: IntBag -> IntBag -> IntBag +union (IntBag t1) (IntBag t2) + = IntBag (M.unionWith (+) t1 t2) + +-- | /O(n+m)/. Intersection of two bags. +-- +-- > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1,2} +intersection :: IntBag -> IntBag -> IntBag +intersection (IntBag t1) (IntBag t2) + = IntBag (M.intersectionWith min t1 t2) + +-- | /O(n+m)/. Difference between two bags. +-- +-- > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) +-- > {1} +difference :: IntBag -> IntBag -> IntBag +difference (IntBag t1) (IntBag t2) + = IntBag (M.differenceWithKey f t1 t2) + where + f x n m | n-m > 0 = Just (n-m) + | otherwise = Nothing + +-- | The union of a list of bags. +unions :: [IntBag] -> IntBag +unions bags + = IntBag (M.unions [m | IntBag m <- bags]) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: (Int -> Bool) -> IntBag -> IntBag +filter p (IntBag m) + = IntBag (M.filterWithKey (\x n -> p x) m) + +-- | /O(n)/. Partition the bag according to some predicate. +partition :: (Int -> Bool) -> IntBag -> (IntBag,IntBag) +partition p (IntBag m) + = (IntBag l,IntBag r) + where + (l,r) = M.partitionWithKey (\x n -> p x) m + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over each element in the bag. +fold :: (Int -> b -> b) -> b -> IntBag -> b +fold f z (IntBag m) + = M.foldWithKey apply z m + where + apply x n z | n > 0 = apply x (n-1) (f x z) + | otherwise = z + +-- | /O(n)/. Fold over all occurrences of an element at once. +-- In a call (@foldOccur f z bag@), the function @f@ takes +-- the element first and than the occur count. +foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b +foldOccur f z (IntBag m) + = M.foldWithKey f z m + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The list of elements. +elems :: IntBag -> [Int] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Create a list with all elements. +toList :: IntBag -> [Int] +toList s + = toAscList s + +-- | /O(n)/. Create an ascending list of all elements. +toAscList :: IntBag -> [Int] +toAscList (IntBag m) + = [y | (x,n) <- M.toAscList m, y <- replicate n x] + + +-- | /O(n*min(n,W))/. Create a bag from a list of elements. +fromList :: [Int] -> IntBag +fromList xs + = IntBag (M.fromListWith (+) [(x,1) | x <- xs]) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list. +fromAscList :: [Int] -> IntBag +fromAscList xs + = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs]) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements. +fromDistinctAscList :: [Int] -> IntBag +fromDistinctAscList xs + = IntBag (M.fromDistinctAscList [(x,1) | x <- xs]) + +-- | /O(n)/. Create a list of element\/occurrence pairs. +toOccurList :: IntBag -> [(Int,Int)] +toOccurList b + = toAscOccurList b + +-- | /O(n)/. Create an ascending list of element\/occurrence pairs. +toAscOccurList :: IntBag -> [(Int,Int)] +toAscOccurList (IntBag m) + = M.toAscList m + +-- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs. +fromOccurList :: [(Int,Int)] -> IntBag +fromOccurList xs + = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +-- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs. +fromAscOccurList :: [(Int,Int)] -> IntBag +fromAscOccurList xs + = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +{-------------------------------------------------------------------- + Maps +--------------------------------------------------------------------} +-- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences. +toMap :: IntBag -> M.IntMap Int +toMap (IntBag m) + = m + +-- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. +fromMap :: M.IntMap Int -> IntBag +fromMap m + = IntBag (M.filter (>0) m) + +-- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. +-- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once. +fromOccurMap :: M.IntMap Int -> IntBag +fromOccurMap m + = IntBag m + +{-------------------------------------------------------------------- + Eq, Ord +--------------------------------------------------------------------} +instance Eq (IntBag) where + (IntBag m1) == (IntBag m2) = (m1==m2) + (IntBag m1) /= (IntBag m2) = (m1/=m2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show (IntBag) where + showsPrec d b = showSet (toAscList b) + +showSet :: Show a => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree +-- is shown as a compressed and /hanging/. +showTree :: IntBag -> String +showTree bag + = showTreeWith True False bag + +-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows +-- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version +-- is shown. +showTreeWith :: Bool -> Bool -> IntBag -> String +showTreeWith hang wide (IntBag m) + = M.showTreeWith hang wide m + diff --git a/src/UU/DData/IntMap.hs b/src/UU/DData/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/IntMap.hs @@ -0,0 +1,1240 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : IntMap + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of maps from integer keys to values. + + 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. + If you want to use "IntMap" unqualified, these functions should be hidden. + + > import Prelude hiding (map,lookup,filter) + > import IntMap + + Another solution is to use qualified names. + + > import qualified IntMap + > + > ... IntMap.single "Paris" "France" + + Or, if you prefer a terse coding style: + + > import qualified IntMap as M + > + > ... M.single "Paris" "France" + + 2) The implementation is based on /big-endian patricia trees/. This data structure + performs especially well on binary operations like 'union' and 'intersection'. However, + my benchmarks show that it is also (much) faster on insertions and deletions when + compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap"). + + * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", + Workshop on ML, September 1998, pages 77--86, + + * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information + Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534. + + 3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements + with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-} +--------------------------------------------------------------------------------- +module UU.DData.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 + +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 + +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 + +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 + +infixl 9 \\ -- + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} + +-- | /O(min(n,W))/. See 'find'. +(!) :: IntMap a -> Key -> a +(!) m k = find k m + +-- | /O(n+m)/. See 'difference'. +(\\) :: IntMap a -> IntMap a -> IntMap a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} +-- | A map of integers to values @a@. +data IntMap a = Nil + | Tip !Key a + | Bin !Prefix !Mask !(IntMap a) !(IntMap a) + +type Prefix = Int +type Mask = Int +type Key = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the map empty? +isEmpty :: IntMap a -> Bool +isEmpty Nil = True +isEmpty other = False + +-- | /O(n)/. Number of elements in the map. +size :: IntMap a -> Int +size t + = case t of + Bin p m l r -> size l + size r + Tip k x -> 1 + Nil -> 0 + +-- | /O(min(n,W))/. Is the key a member of the map? +member :: Key -> IntMap a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just x -> True + +-- | /O(min(n,W))/. Lookup the value of a key in the map. +lookup :: Key -> IntMap a -> Maybe a +lookup k t + = case t of + Bin p m l r + | nomatch k p m -> Nothing + | zero k m -> lookup k l + | otherwise -> lookup k r + Tip kx x + | (k==kx) -> Just x + | otherwise -> Nothing + Nil -> Nothing + +-- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found. +find :: Key -> IntMap a -> a +find k m + = case lookup k m of + Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map") + Just x -> x + +-- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when +-- the key is not an element of the map. +findWithDefault :: a -> Key -> IntMap a -> a +findWithDefault def k m + = case lookup k m of + Nothing -> def + Just x -> x + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty map. +empty :: IntMap a +empty + = Nil + +-- | /O(1)/. A map of one element. +single :: Key -> a -> IntMap a +single k x + = Tip k x + +{-------------------------------------------------------------------- + Insert + 'insert' is the inlined version of 'insertWith (\k x y -> x)' +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key +-- is already an element of the set, it's value is replaced by the new value, +-- ie. 'insert' is left-biased. +insert :: Key -> a -> IntMap a -> IntMap a +insert k x t + = case t of + Bin p m l r + | nomatch k p m -> join k (Tip k x) p t + | zero k m -> Bin p m (insert k x l) r + | otherwise -> Bin p m l (insert k x r) + Tip ky y + | k==ky -> Tip k x + | otherwise -> join k (Tip k x) ky t + Nil -> Tip k x + +-- right-biased insertion, used by 'union' +-- | /O(min(n,W))/. Insert with a combining function. +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith f k x t + = insertWithKey (\k x y -> f x y) k x t + +-- | /O(min(n,W))/. Insert with a combining function. +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey f k x t + = case t of + Bin p m l r + | nomatch k p m -> join k (Tip k x) p t + | zero k m -> Bin p m (insertWithKey f k x l) r + | otherwise -> Bin p m l (insertWithKey f k x r) + Tip ky y + | k==ky -> Tip k (f k x y) + | otherwise -> join k (Tip k x) ky t + Nil -> Tip k x + + +-- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where +-- the first element is equal to (@lookup k map@) and the second element +-- equal to (@insertWithKey f k x map@). +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertLookupWithKey f k x t + = case t of + Bin p m l r + | nomatch k p m -> (Nothing,join k (Tip k x) p t) + | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r) + | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r') + Tip ky y + | k==ky -> (Just y,Tip k (f k x y)) + | otherwise -> (Nothing,join k (Tip k x) ky t) + Nil -> (Nothing,Tip k x) + + +{-------------------------------------------------------------------- + Deletion + [delete] is the inlined version of [deleteWith (\k x -> Nothing)] +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: Key -> IntMap a -> IntMap a +delete k t + = case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> bin p m (delete k l) r + | otherwise -> bin p m l (delete k r) + Tip ky y + | k==ky -> Nil + | otherwise -> t + Nil -> Nil + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjust :: (a -> a) -> Key -> IntMap a -> IntMap a +adjust f k m + = adjustWithKey (\k x -> f x) k m + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a +adjustWithKey f k m + = updateWithKey (\k x -> Just (f k x)) k m + +-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k m + = updateWithKey (\k x -> f x) k m + +-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a +updateWithKey f k t + = case t of + Bin p m l r + | nomatch k p m -> t + | zero k m -> bin p m (updateWithKey f k l) r + | otherwise -> bin p m l (updateWithKey f k r) + Tip ky y + | k==ky -> case (f k y) of + Just y' -> Tip ky y' + Nothing -> Nil + | otherwise -> t + Nil -> Nil + +-- | /O(min(n,W))/. Lookup and update. +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) +updateLookupWithKey f k t + = case t of + Bin p m l r + | nomatch k p m -> (Nothing,t) + | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r) + | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r') + Tip ky y + | k==ky -> case (f k y) of + Just y' -> (Just y,Tip ky y') + Nothing -> (Just y,Nil) + | otherwise -> (Nothing,t) + Nil -> (Nothing,Nil) + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of maps. +unions :: [IntMap a] -> IntMap a +unions xs + = foldlStrict union empty xs + + +-- | /O(n+m)/. The (left-biased) union of two sets. +union :: IntMap a -> IntMap a -> IntMap a +union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 + | otherwise = Bin p1 m1 l1 (union r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 + | otherwise = Bin p2 m2 l2 (union t1 r2) + +union (Tip k x) t = insert k x t +union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias +union Nil t = t +union t Nil = t + +-- | /O(n+m)/. The union with a combining function. +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWith f m1 m2 + = unionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. The union with a combining function. +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1 + | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2 + | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2) + +unionWithKey f (Tip k x) t = insertWithKey f k x t +unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias +unionWithKey f Nil t = t +unionWithKey f t Nil = t + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference between two maps (based on keys). +difference :: IntMap a -> IntMap a -> IntMap a +difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (difference l1 t2) r1 + | otherwise = bin p1 m1 l1 (difference r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = difference t1 l2 + | otherwise = difference t1 r2 + +difference t1@(Tip k x) t2 + | member k t2 = Nil + | otherwise = t1 + +difference Nil t = Nil +difference t (Tip k x) = delete k t +difference t Nil = t + +-- | /O(n+m)/. Difference with a combining function. +differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a +differenceWith f m1 m2 + = differenceWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns @Nothing@, the element is discarded (proper set difference). If +-- it returns (@Just y@), the element is updated with a new value @y@. +differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a +differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1 + | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = differenceWithKey f t1 l2 + | otherwise = differenceWithKey f t1 r2 + +differenceWithKey f t1@(Tip k x) t2 + = case lookup k t2 of + Just y -> case f k x y of + Just y' -> Tip k y' + Nothing -> Nil + Nothing -> t1 + +differenceWithKey f Nil t = Nil +differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t +differenceWithKey f t Nil = t + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). +intersection :: IntMap a -> IntMap a -> IntMap a +intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersection l1 t2 + | otherwise = intersection r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersection t1 l2 + | otherwise = intersection t1 r2 + +intersection t1@(Tip k x) t2 + | member k t2 = t1 + | otherwise = Nil +intersection t (Tip k x) + = case lookup k t of + Just y -> Tip k y + Nothing -> Nil +intersection Nil t = Nil +intersection t Nil = Nil + +-- | /O(n+m)/. The intersection with a combining function. +intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +intersectionWith f m1 m2 + = intersectionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. The intersection with a combining function. +intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersectionWithKey f l1 t2 + | otherwise = intersectionWithKey f r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersectionWithKey f t1 l2 + | otherwise = intersectionWithKey f t1 r2 + +intersectionWithKey f t1@(Tip k x) t2 + = case lookup k t2 of + Just y -> Tip k (f k x y) + Nothing -> Nil +intersectionWithKey f t1 (Tip k y) + = case lookup k t1 of + Just x -> Tip k (f k x y) + Nothing -> Nil +intersectionWithKey f Nil t = Nil +intersectionWithKey f t Nil = Nil + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@). +properSubset :: Eq a => IntMap a -> IntMap a -> Bool +properSubset m1 m2 + = properSubsetBy (==) m1 m2 + +{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). + The expression (@properSubsetBy f m1 m2@) returns @True@ when + @m1@ and @m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) + > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool +properSubsetBy pred t1 t2 + = case subsetCmp pred t1 t2 of + LT -> True + ge -> False + +subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = subsetCmpLt + | p1 == p2 = subsetCmpEq + | otherwise = GT -- disjoint + where + subsetCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = subsetCmp pred t1 l2 + | otherwise = subsetCmp pred t1 r2 + subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + other -> LT + +subsetCmp pred (Bin p m l r) t = GT +subsetCmp pred (Tip kx x) (Tip ky y) + | (kx == ky) && pred x y = EQ + | otherwise = GT -- disjoint +subsetCmp pred (Tip k x) t + = case lookup k t of + Just y | pred x y -> LT + other -> GT -- disjoint +subsetCmp pred Nil Nil = EQ +subsetCmp pred Nil t = LT + +-- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@). +subset :: Eq a => IntMap a -> IntMap a -> Bool +subset m1 m2 + = subsetBy (==) m1 m2 + +{- | /O(n+m)/. + The expression (@subsetBy f m1 m2@) returns @True@ if + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) + > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) +-} + +subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool +subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2 + else subsetBy pred t1 r2) + | otherwise = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2 +subsetBy pred (Bin p m l r) t = False +subsetBy pred (Tip k x) t = case lookup k t of + Just y -> pred x y + Nothing -> False +subsetBy pred Nil t = True + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> IntMap a -> IntMap b +map f m + = mapWithKey (\k x -> f x) m + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey f t + = case t of + Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) + Tip k x -> Tip k (f k x) + Nil -> Nil + +-- | /O(n)/. The function @mapAccum@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccum f a m + = mapAccumWithKey (\a k x -> f a x) a m + +-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | /O(n)/. The function @mapAccumL@ threads an accumulating +-- argument through the map in pre-order. +mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumL f a t + = case t of + Bin p m l r -> let (a1,l') = mapAccumL f a l + (a2,r') = mapAccumL f a1 r + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + + +-- | /O(n)/. The function @mapAccumR@ threads an accumulating +-- argument throught the map in post-order. +mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) +mapAccumR f a t + = case t of + Bin p m l r -> let (a1,r') = mapAccumR f a r + (a2,l') = mapAccumR f a1 l + in (a2,Bin p m l' r') + Tip k x -> let (a',x') = f a k x in (a',Tip k x') + Nil -> (a,Nil) + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter all values that satisfy some predicate. +filter :: (a -> Bool) -> IntMap a -> IntMap a +filter p m + = filterWithKey (\k x -> p x) m + +-- | /O(n)/. Filter all keys\/values that satisfy some predicate. +filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a +filterWithKey pred t + = case t of + Bin p m l r + -> bin p m (filterWithKey pred l) (filterWithKey pred r) + Tip k x + | pred k x -> t + | otherwise -> Nil + Nil -> Nil + +-- | /O(n)/. partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a) +partition p m + = partitionWithKey (\k x -> p x) m + +-- | /O(n)/. partition the map according to some predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a) +partitionWithKey pred t + = case t of + Bin p m l r + -> let (l1,l2) = partitionWithKey pred l + (r1,r2) = partitionWithKey pred r + in (bin p m l1 r1, bin p m l2 r2) + Tip k x + | pred k x -> (t,Nil) + | otherwise -> (Nil,t) + Nil -> (Nil,Nil) + + +-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ +-- where all keys in @map1@ are lower than @k@ and all keys in +-- @map2@ larger than @k@. +split :: Key -> IntMap a -> (IntMap a,IntMap a) +split k t + = case t of + Bin p m l r + | zero k m -> let (lt,gt) = split k l in (lt,union gt r) + | otherwise -> let (lt,gt) = split k r in (union l lt,gt) + Tip ky y + | k>ky -> (t,Nil) + | k (Nil,t) + | otherwise -> (Nil,Nil) + Nil -> (Nil,Nil) + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- key was found in the original map. +splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a) +splitLookup k t + = case t of + Bin p m l r + | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r) + | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt) + Tip ky y + | k>ky -> (Nothing,t,Nil) + | k (Nothing,Nil,t) + | otherwise -> (Just y,Nil,Nil) + Nil -> (Nothing,Nil,Nil) + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements of a map in an unspecified order. +-- +-- > sum map = fold (+) 0 map +-- > elems map = fold (:) [] map +fold :: (a -> b -> b) -> b -> IntMap a -> b +fold f z t + = foldWithKey (\k x y -> f x y) z t + +-- | /O(n)/. Fold over the elements of a map in an unspecified order. +-- +-- > keys map = foldWithKey (\k x ks -> k:ks) [] map +foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey f z t + = foldR f z t + +foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldR f z t + = case t of + Bin p m l r -> foldR f (foldR f z r) l + Tip k x -> f k x z + Nil -> z + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. Return all elements of the map. +elems :: IntMap a -> [a] +elems m + = foldWithKey (\k x xs -> x:xs) [] m + +-- | /O(n)/. Return all keys of the map. +keys :: IntMap a -> [Key] +keys m + = foldWithKey (\k x ks -> k:ks) [] m + +-- | /O(n)/. Return all key\/value pairs in the map. +assocs :: IntMap a -> [(Key,a)] +assocs m + = toList m + + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the map to a list of key\/value pairs. +toList :: IntMap a -> [(Key,a)] +toList t + = foldWithKey (\k x xs -> (k,x):xs) [] t + +-- | /O(n)/. Convert the map to a list of key\/value pairs where the +-- keys are in ascending order. +toAscList :: IntMap a -> [(Key,a)] +toAscList t + = -- NOTE: the following algorithm only works for big-endian trees + let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +fromList :: [(Key,a)] -> IntMap a +fromList xs + = foldlStrict ins empty xs + where + ins t (k,x) = insert k x t + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWith f xs + = fromListWithKey (\k x y -> f x y) xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromListWithKey f xs + = foldlStrict ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +fromAscList :: [(Key,a)] -> IntMap a +fromAscList xs + = fromList xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a +fromAscListWith f xs + = fromListWith f xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromAscListWithKey f xs + = fromListWithKey f xs + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +fromDistinctAscList :: [(Key,a)] -> IntMap a +fromDistinctAscList xs + = fromList xs + + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq a => Eq (IntMap a) where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Eq a => IntMap a -> IntMap a -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y) + = (kx == ky) && (x==y) +equal Nil Nil = True +equal t1 t2 = False + +nequal :: Eq a => IntMap a -> IntMap a -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y) + = (kx /= ky) || (x/=y) +nequal Nil Nil = False +nequal t1 t2 = True + +instance Show a => Show (IntMap a) where + showsPrec d t = showMap (toList t) + + +showMap :: (Show a) => [(Key,a)] -> ShowS +showMap [] + = showString "{}" +showMap (x:xs) + = showChar '{' . showElem x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . showElem x . showTail xs + + showElem (k,x) = shows k . showString ":=" . shows x + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the map. The tree is shown +-- in a compressed, hanging format. +showTree :: Show a => IntMap a -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the map. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. +-} +showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS +showsTree wide lbars rbars t + = case t of + Bin p m l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip k x + -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS +showsTreeHang wide bars t + = case t of + Bin p m l r + -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip k x + -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin p m + = "*" -- ++ show (p,m) + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a +bin p m l Nil = l +bin p m Nil r = r +bin p m l r = Bin p m l r + + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} +zero :: Key -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch,match :: Key -> Prefix -> Mask -> Bool +nomatch i p m + = (mask i m) /= p + +match i p m + = (mask i m) == p + +mask :: Key -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) + + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. (complement (m-1) `xor` m)) + +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{---------------------------------------------------------------------- + Finding the highest bit (mask) in a word [x] can be done efficiently in + three ways: + * convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + * use processor specific assembler instruction (asm). + + The most portable way would be [bit], but is it efficient enough? + I have measured the cycle counts of the different methods on an AMD + Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + + highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + + highestBit: method cycles + -------------- + frexp 195 + float 33 + bit 11 + asm 11 + + Wow, the bit twiddling is on today's RISC like machines even faster + than a single CISC instruction (BSR)! +----------------------------------------------------------------------} + +{---------------------------------------------------------------------- + [highestBitMask] returns a word where only the highest bit is set. + It is found by first setting all bits in lower positions than the + highest bit and than taking an exclusive or with the original value. + Allthough the function may look expensive, GHC compiles this into + excellent C code that subsequently compiled into highly efficient + machine code. The algorithm is derived from Jorg Arndt's FXT library. +----------------------------------------------------------------------} +highestBitMask :: Nat -> Nat +highestBitMask x + = case (x .|. shiftRL x 1) of + x -> case (x .|. shiftRL x 2) of + x -> case (x .|. shiftRL x 4) of + x -> case (x .|. shiftRL x 8) of + x -> case (x .|. shiftRL x 16) of + x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms + x -> (x `xor` (shiftRL x 1)) + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> IntMap Int +testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs] +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (IntMap a) where + arbitrary = do{ ks <- arbitrary + ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks + ; return (fromList xs) + } + + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Key -> Int -> Bool +prop_Single k x + = (insert k x empty == single k x) + +prop_InsertDelete :: Key -> Int -> IntMap Int -> Property +prop_InsertDelete k x t + = not (member k t) ==> delete k (insert k x t) == t + +prop_UpdateDelete :: Key -> IntMap Int -> Bool +prop_UpdateDelete k t + = update (const Nothing) k t == delete k t + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool +prop_UnionInsert k x t + = union (single k x) t == insert k x t + +prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: IntMap Int -> IntMap Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == unionWith (\x y -> y) t2 t1) + + +prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool +prop_Diff xs ys + = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) + +prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool +prop_Int xs ys + = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [(x,()) | x <- [0..n::Int]] + in fromAscList xs == fromList xs + +prop_List :: [Key] -> Bool +prop_List xs + = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])]) +-} diff --git a/src/UU/DData/IntSet.hs b/src/UU/DData/IntSet.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/IntSet.hs @@ -0,0 +1,852 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : IntSet + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of integer sets. + + 1) The 'filter' function clashes with the "Prelude". + If you want to use "IntSet" unqualified, this function should be hidden. + + > import Prelude hiding (filter) + > import IntSet + + Another solution is to use qualified names. + + > import qualified IntSet + > + > ... IntSet.fromList [1..5] + + Or, if you prefer a terse coding style: + + > import qualified IntSet as S + > + > ... S.fromList [1..5] + + 2) The implementation is based on /big-endian patricia trees/. This data structure + performs especially well on binary operations like 'union' and 'intersection'. However, + my benchmarks show that it is also (much) faster on insertions and deletions when + compared to a generic size-balanced set implementation (see "Set"). + + * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", + Workshop on ML, September 1998, pages 77--86, + + * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information + Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534. + + 3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the + operation can become linear in the number of elements + with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). +-} +---------------------------------------------------------------------------------} +module UU.DData.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 + + +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 + +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 + +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 + +infixl 9 \\ -- + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +-- | /O(n+m)/. See 'difference'. +(\\) :: IntSet -> IntSet -> IntSet +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Types +--------------------------------------------------------------------} +-- | A set of integers. +data IntSet = Nil + | Tip !Int + | Bin !Prefix !Mask !IntSet !IntSet + +type Prefix = Int +type Mask = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the set empty? +isEmpty :: IntSet -> Bool +isEmpty Nil = True +isEmpty other = False + +-- | /O(n)/. Cardinality of the set. +size :: IntSet -> Int +size t + = case t of + Bin p m l r -> size l + size r + Tip y -> 1 + Nil -> 0 + +-- | /O(min(n,W))/. Is the value a member of the set? +member :: Int -> IntSet -> Bool +member x t + = case t of + Bin p m l r + | nomatch x p m -> False + | zero x m -> member x l + | otherwise -> member x r + Tip y -> (x==y) + Nil -> False + +-- 'lookup' is used by 'intersection' for left-biasing +lookup :: Int -> IntSet -> Maybe Int +lookup x t + = case t of + Bin p m l r + | nomatch x p m -> Nothing + | zero x m -> lookup x l + | otherwise -> lookup x r + Tip y + | (x==y) -> Just y + | otherwise -> Nothing + Nil -> Nothing + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: IntSet +empty + = Nil + +-- | /O(1)/. A set of one element. +single :: Int -> IntSet +single x + = Tip x + +{-------------------------------------------------------------------- + Insert +--------------------------------------------------------------------} +-- | /O(min(n,W))/. Add a value to the set. When the value is already +-- an element of the set, it is replaced by the new one, ie. 'insert' +-- is left-biased. +insert :: Int -> IntSet -> IntSet +insert x t + = case t of + Bin p m l r + | nomatch x p m -> join x (Tip x) p t + | zero x m -> Bin p m (insert x l) r + | otherwise -> Bin p m l (insert x r) + Tip y + | x==y -> Tip x + | otherwise -> join x (Tip x) y t + Nil -> Tip x + +-- right-biased insertion, used by 'union' +insertR :: Int -> IntSet -> IntSet +insertR x t + = case t of + Bin p m l r + | nomatch x p m -> join x (Tip x) p t + | zero x m -> Bin p m (insert x l) r + | otherwise -> Bin p m l (insert x r) + Tip y + | x==y -> t + | otherwise -> join x (Tip x) y t + Nil -> Tip x + +-- | /O(min(n,W))/. Delete a value in the set. Returns the +-- original set when the value was not present. +delete :: Int -> IntSet -> IntSet +delete x t + = case t of + Bin p m l r + | nomatch x p m -> t + | zero x m -> bin p m (delete x l) r + | otherwise -> bin p m l (delete x r) + Tip y + | x==y -> Nil + | otherwise -> t + Nil -> Nil + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +-- | The union of a list of sets. +unions :: [IntSet] -> IntSet +unions xs + = foldlStrict union empty xs + + +-- | /O(n+m)/. The union of two sets. +union :: IntSet -> IntSet -> IntSet +union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = union1 + | shorter m2 m1 = union2 + | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2) + | otherwise = join p1 t1 p2 t2 + where + union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2 + | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 + | otherwise = Bin p1 m1 l1 (union r1 t2) + + union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2 + | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 + | otherwise = Bin p2 m2 l2 (union t1 r2) + +union (Tip x) t = insert x t +union t (Tip x) = insertR x t -- right bias +union Nil t = t +union t Nil = t + + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference between two sets. +difference :: IntSet -> IntSet -> IntSet +difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = difference1 + | shorter m2 m1 = difference2 + | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2) + | otherwise = t1 + where + difference1 | nomatch p2 p1 m1 = t1 + | zero p2 m1 = bin p1 m1 (difference l1 t2) r1 + | otherwise = bin p1 m1 l1 (difference r1 t2) + + difference2 | nomatch p1 p2 m2 = t1 + | zero p1 m2 = difference t1 l2 + | otherwise = difference t1 r2 + +difference t1@(Tip x) t2 + | member x t2 = Nil + | otherwise = t1 + +difference Nil t = Nil +difference t (Tip x) = delete x t +difference t Nil = t + + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. The intersection of two sets. +intersection :: IntSet -> IntSet -> IntSet +intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = intersection1 + | shorter m2 m1 = intersection2 + | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2) + | otherwise = Nil + where + intersection1 | nomatch p2 p1 m1 = Nil + | zero p2 m1 = intersection l1 t2 + | otherwise = intersection r1 t2 + + intersection2 | nomatch p1 p2 m2 = Nil + | zero p1 m2 = intersection t1 l2 + | otherwise = intersection t1 r2 + +intersection t1@(Tip x) t2 + | member x t2 = t1 + | otherwise = Nil +intersection t (Tip x) + = case lookup x t of + Just y -> Tip y + Nothing -> Nil +intersection Nil t = Nil +intersection t Nil = Nil + + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +properSubset :: IntSet -> IntSet -> Bool +properSubset t1 t2 + = case subsetCmp t1 t2 of + LT -> True + ge -> False + +subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = GT + | shorter m2 m1 = subsetCmpLt + | p1 == p2 = subsetCmpEq + | otherwise = GT -- disjoint + where + subsetCmpLt | nomatch p1 p2 m2 = GT + | zero p1 m2 = subsetCmp t1 l2 + | otherwise = subsetCmp t1 r2 + subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of + (GT,_ ) -> GT + (_ ,GT) -> GT + (EQ,EQ) -> EQ + other -> LT + +subsetCmp (Bin p m l r) t = GT +subsetCmp (Tip x) (Tip y) + | x==y = EQ + | otherwise = GT -- disjoint +subsetCmp (Tip x) t + | member x t = LT + | otherwise = GT -- disjoint +subsetCmp Nil Nil = EQ +subsetCmp Nil t = LT + +-- | /O(n+m)/. Is this a subset? +subset :: IntSet -> IntSet -> Bool +subset t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) + | shorter m1 m2 = False + | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subset t1 l2 + else subset t1 r2) + | otherwise = (p1==p2) && subset l1 l2 && subset r1 r2 +subset (Bin p m l r) t = False +subset (Tip x) t = member x t +subset Nil t = True + + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: (Int -> Bool) -> IntSet -> IntSet +filter pred t + = case t of + Bin p m l r + -> bin p m (filter pred l) (filter pred r) + Tip x + | pred x -> t + | otherwise -> Nil + Nil -> Nil + +-- | /O(n)/. partition the set according to some predicate. +partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet) +partition pred t + = case t of + Bin p m l r + -> let (l1,l2) = partition pred l + (r1,r2) = partition pred r + in (bin p m l1 r1, bin p m l2 r2) + Tip x + | pred x -> (t,Nil) + | otherwise -> (Nil,t) + Nil -> (Nil,Nil) + + +-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@ +-- where all elements in @set1@ are lower than @x@ and all elements in +-- @set2@ larger than @x@. +split :: Int -> IntSet -> (IntSet,IntSet) +split x t + = case t of + Bin p m l r + | zero x m -> let (lt,gt) = split x l in (lt,union gt r) + | otherwise -> let (lt,gt) = split x r in (union l lt,gt) + Tip y + | x>y -> (t,Nil) + | x (Nil,t) + | otherwise -> (Nil,Nil) + Nil -> (Nil,Nil) + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet) +splitMember x t + = case t of + Bin p m l r + | zero x m -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r) + | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt) + Tip y + | x>y -> (False,t,Nil) + | x (False,Nil,t) + | otherwise -> (True,Nil,Nil) + Nil -> (False,Nil,Nil) + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements of a set in an unspecified order. +-- +-- > sum set = fold (+) 0 set +-- > elems set = fold (:) [] set +fold :: (Int -> b -> b) -> b -> IntSet -> b +fold f z t + = foldR f z t + +foldR :: (Int -> b -> b) -> b -> IntSet -> b +foldR f z t + = case t of + Bin p m l r -> foldR f (foldR f z r) l + Tip x -> f x z + Nil -> z + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a set. +elems :: IntSet -> [Int] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the set to a list of elements. +toList :: IntSet -> [Int] +toList t + = fold (:) [] t + +-- | /O(n)/. Convert the set to an ascending list of elements. +toAscList :: IntSet -> [Int] +toAscList t + = -- NOTE: the following algorithm only works for big-endian trees + let (pos,neg) = span (>=0) (foldR (:) [] t) in neg ++ pos + +-- | /O(n*min(n,W))/. Create a set from a list of integers. +fromList :: [Int] -> IntSet +fromList xs + = foldlStrict ins empty xs + where + ins t x = insert x t + +-- | /O(n*min(n,W))/. Build a set from an ascending list of elements. +fromAscList :: [Int] -> IntSet +fromAscList xs + = fromList xs + +-- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements. +fromDistinctAscList :: [Int] -> IntSet +fromDistinctAscList xs + = fromList xs + + +{-------------------------------------------------------------------- + Eq +--------------------------------------------------------------------} +instance Eq IntSet where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: IntSet -> IntSet -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip x) (Tip y) + = (x==y) +equal Nil Nil = True +equal t1 t2 = False + +nequal :: IntSet -> IntSet -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip x) (Tip y) + = (x/=y) +nequal Nil Nil = False +nequal t1 t2 = True + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show IntSet where + showsPrec d s = showSet (toList s) + +showSet :: [Int] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the set. The tree is shown +-- in a compressed, hanging format. +showTree :: IntSet -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the set. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. +-} +showTreeWith :: Bool -> Bool -> IntSet -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS +showsTree wide lbars rbars t + = case t of + Bin p m l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showBin p m) . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + Tip x + -> showsBars lbars . showString " " . shows x . showString "\n" + Nil -> showsBars lbars . showString "|\n" + +showsTreeHang :: Bool -> [String] -> IntSet -> ShowS +showsTreeHang wide bars t + = case t of + Bin p m l r + -> showsBars bars . showString (showBin p m) . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + Tip x + -> showsBars bars . showString " " . shows x . showString "\n" + Nil -> showsBars bars . showString "|\n" + +showBin p m + = "*" -- ++ show (p,m) + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Helpers +--------------------------------------------------------------------} +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +{-------------------------------------------------------------------- + @bin@ assures that we never have empty trees within a tree. +--------------------------------------------------------------------} +bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet +bin p m l Nil = l +bin p m Nil r = r +bin p m l r = Bin p m l r + + +{-------------------------------------------------------------------- + Endian independent bit twiddling +--------------------------------------------------------------------} +zero :: Int -> Mask -> Bool +zero i m + = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch,match :: Int -> Prefix -> Mask -> Bool +nomatch i p m + = (mask i m) /= p + +match i p m + = (mask i m) == p + +mask :: Int -> Mask -> Prefix +mask i m + = maskW (natFromInt i) (natFromInt m) + + +{-------------------------------------------------------------------- + Big endian operations +--------------------------------------------------------------------} +maskW :: Nat -> Nat -> Prefix +maskW i m + = intFromNat (i .&. (complement (m-1) `xor` m)) + +shorter :: Mask -> Mask -> Bool +shorter m1 m2 + = (natFromInt m1) > (natFromInt m2) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{---------------------------------------------------------------------- + Finding the highest bit (mask) in a word [x] can be done efficiently in + three ways: + * convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + * use processor specific assembler instruction (asm). + + The most portable way would be [bit], but is it efficient enough? + I have measured the cycle counts of the different methods on an AMD + Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + + highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + + highestBit: method cycles + -------------- + frexp 195 + float 33 + bit 11 + asm 11 + + Wow, the bit twiddling is on today's RISC like machines even faster + than a single CISC instruction (BSR)! +----------------------------------------------------------------------} + +{---------------------------------------------------------------------- + [highestBitMask] returns a word where only the highest bit is set. + It is found by first setting all bits in lower positions than the + highest bit and than taking an exclusive or with the original value. + Allthough the function may look expensive, GHC compiles this into + excellent C code that subsequently compiled into highly efficient + machine code. The algorithm is derived from Jorg Arndt's FXT library. +----------------------------------------------------------------------} +highestBitMask :: Nat -> Nat +highestBitMask x + = case (x .|. shiftRL x 1) of + x -> case (x .|. shiftRL x 2) of + x -> case (x .|. shiftRL x 4) of + x -> case (x .|. shiftRL x 8) of + x -> case (x .|. shiftRL x 16) of + x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms + x -> (x `xor` (shiftRL x 1)) + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> IntSet +testTree xs = fromList xs +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance Arbitrary IntSet where + arbitrary = do{ xs <- arbitrary + ; return (fromList xs) + } + + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Bool +prop_Single x + = (insert x empty == single x) + +prop_InsertDelete :: Int -> IntSet -> Property +prop_InsertDelete k t + = not (member k t) ==> delete k (insert k t) == t + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionInsert :: Int -> IntSet -> Bool +prop_UnionInsert x t + = union t (single x) == insert x t + +prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: IntSet -> IntSet -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == union t2 t1) + +prop_Diff :: [Int] -> [Int] -> Bool +prop_Diff xs ys + = toAscList (difference (fromList xs) (fromList ys)) + == List.sort ((List.\\) (nub xs) (nub ys)) + +prop_Int :: [Int] -> [Int] -> Bool +prop_Int xs ys + = toAscList (intersection (fromList xs) (fromList ys)) + == List.sort (nub ((List.intersect) (xs) (ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [0..n::Int] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == toAscList (fromList xs)) +-} + diff --git a/src/UU/DData/Map.hs b/src/UU/DData/Map.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/Map.hs @@ -0,0 +1,1544 @@ +-------------------------------------------------------------------------------- +{-| Module : Map + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An efficient implementation of maps from keys to values (dictionaries). + + 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. + If you want to use "Map" unqualified, these functions should be hidden. + + > import Prelude hiding (lookup,map,filter) + > import Map + + Another solution is to use qualified names. This is also the only way how + a "Map", "Set", and "MultiSet" can be used within one module. + + > import qualified Map + > + > ... Map.single "Paris" "France" + + Or, if you prefer a terse coding style: + + > import qualified Map as M + > + > ... M.single "Berlin" "Germany" + + 2) The implementation of "Map" is based on /size balanced/ binary trees (or + trees of /bounded balance/) as described by: + + * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional + Programming 3(4):553-562, October 1993, . + + * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\", + SIAM journal of computing 2(1), March 1973. + + 3) Another implementation of finite maps based on size balanced trees + exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library + is that it is highly tuned and thorougly tested. However, it is also fairly old, + uses @#ifdef@'s all over the place and only supports the basic finite map operations. + The "Map" module overcomes some of these issues: + + * It tries to export a more complete and consistent set of operations, like + 'partition', 'adjust', 'mapAccum', 'elemAt' etc. + + * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' + (a /hedge/ algorithm is not applicable to 'intersection'). + + * It converts ordered lists in linear time ('fromAscList'). + + * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'. + + * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic. +-} +---------------------------------------------------------------------------------- +module UU.DData.Map ( + -- * Map type + Map -- instance Eq,Show + + -- * Operators + , (!), (\\) + + -- * Query + , isEmpty + , size + , member + , lookup + , find + , findWithDefault + + -- * Construction + , empty + , single + + -- ** Insertion + , insert + , insertWith, insertWithKey, insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + + -- ** Fold + , fold + , foldWithKey + + -- * Conversion + , elems + , keys + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , split + , splitLookup + + -- * Subset + , subset, subsetBy + , properSubset, properSubsetBy + + -- * Indexed + , lookupIndex + , findIndex + , elemAt + , updateAt + , deleteAt + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + + -- * Debugging + , showTree + , showTreeWith + , valid + ) where + +import Prelude hiding (lookup,map,filter) + + +{- +-- for quick check +import qualified Prelude +import qualified List +import Debug.QuickCheck +import List(nub,sort) +-} + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 !,\\ -- + +-- | /O(log n)/. See 'find'. +(!) :: Ord k => Map k a -> k -> a +(!) m k = find k m + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord k => Map k a -> Map k a -> Map k a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Size balanced trees. +--------------------------------------------------------------------} +-- | A Map from keys @k@ and values @a@. +data Map k a = Tip + | Bin !Size !k a !(Map k a) !(Map k a) + +type Size = Int + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is the map empty? +isEmpty :: Map k a -> Bool +isEmpty t + = case t of + Tip -> True + Bin sz k x l r -> False + +-- | /O(1)/. The number of elements in the map. +size :: Map k a -> Int +size t + = case t of + Tip -> 0 + Bin sz k x l r -> sz + + +-- | /O(log n)/. Lookup the value of key in the map. +lookup :: Ord k => k -> Map k a -> Maybe a +lookup k t + = case t of + Tip -> Nothing + Bin sz kx x l r + -> case compare k kx of + LT -> lookup k l + GT -> lookup k r + EQ -> Just x + +-- | /O(log n)/. Is the key a member of the map? +member :: Ord k => k -> Map k a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just x -> True + +-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found. +find :: Ord k => k -> Map k a -> a +find k m + = case lookup k m of + Nothing -> error "Map.find: element not in the map" + Just x -> x + +-- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when +-- the key is not in the map. +findWithDefault :: Ord k => a -> k -> Map k a -> a +findWithDefault def k m + = case lookup k m of + Nothing -> def + Just x -> x + + + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty map. +empty :: Map k a +empty + = Tip + +-- | /O(1)/. Create a map with a single element. +single :: k -> a -> Map k a +single k x + = Bin 1 k x Tip Tip + +{-------------------------------------------------------------------- + Insertion + [insert] is the inlined version of [insertWith (\k x y -> x)] +--------------------------------------------------------------------} +-- | /O(log n)/. Insert a new key and value in the map. +insert :: Ord k => k -> a -> Map k a -> Map k a +insert kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> case compare kx ky of + LT -> balance ky y (insert kx x l) r + GT -> balance ky y l (insert kx x r) + EQ -> Bin sz kx x l r + +-- | /O(log n)/. Insert with a combining function. +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith f k x m + = insertWithKey (\k x y -> f x y) k x m + +-- | /O(log n)/. Insert with a combining function. +insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWithKey f kx x t + = case t of + Tip -> single kx x + Bin sy ky y l r + -> case compare kx ky of + LT -> balance ky y (insertWithKey f kx x l) r + GT -> balance ky y l (insertWithKey f kx x r) + EQ -> Bin sy ky (f ky x y) l r + +-- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where +-- the first element is equal to (@lookup k map@) and the second element +-- equal to (@insertWithKey f k x map@). +insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a) +insertLookupWithKey f kx x t + = case t of + Tip -> (Nothing, single kx x) + Bin sy ky y l r + -> case compare kx ky of + LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r) + GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r') + EQ -> (Just y, Bin sy ky (f ky x y) l r) + +{-------------------------------------------------------------------- + Deletion + [delete] is the inlined version of [deleteWith (\k x -> Nothing)] +--------------------------------------------------------------------} +-- | /O(log n)/. Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: Ord k => k -> Map k a -> Map k a +delete k t + = case t of + Tip -> Tip + Bin sx kx x l r + -> case compare k kx of + LT -> balance kx x (delete k l) r + GT -> balance kx x l (delete k r) + EQ -> glue l r + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a +adjust f k m + = adjustWithKey (\k x -> f x) k m + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a +adjustWithKey f k m + = updateWithKey (\k x -> Just (f k x)) k m + +-- | /O(log n)/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a +update f k m + = updateWithKey (\k x -> f x) k m + +-- | /O(log n)/. The expression (@update f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is +-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@. +updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a +updateWithKey f k t + = case t of + Tip -> Tip + Bin sx kx x l r + -> case compare k kx of + LT -> balance kx x (updateWithKey f k l) r + GT -> balance kx x l (updateWithKey f k r) + EQ -> case f kx x of + Just x' -> Bin sx kx x' l r + Nothing -> glue l r + +-- | /O(log n)/. Lookup and update. +updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) +updateLookupWithKey f k t + = case t of + Tip -> (Nothing,Tip) + Bin sx kx x l r + -> case compare k kx of + LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r) + GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') + EQ -> case f kx x of + Just x' -> (Just x',Bin sx kx x' l r) + Nothing -> (Just x,glue l r) + +{-------------------------------------------------------------------- + Indexing +--------------------------------------------------------------------} +-- | /O(log n)/. Return the /index/ of a key. The index is a number from +-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when +-- the key is not a 'member' of the map. +findIndex :: Ord k => k -> Map k a -> Int +findIndex k t + = case lookupIndex k t of + Nothing -> error "Map.findIndex: element is not in the map" + Just idx -> idx + +-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from +-- /0/ up to, but not including, the 'size' of the map. +lookupIndex :: Ord k => k -> Map k a -> Maybe Int +lookupIndex k t + = lookup 0 t + where + lookup idx Tip = Nothing + lookup idx (Bin _ kx x l r) + = case compare k kx of + LT -> lookup idx l + GT -> lookup (idx + size l + 1) r + EQ -> Just (idx + size l) + +-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an +-- invalid index is used. +elemAt :: Int -> Map k a -> (k,a) +elemAt i Tip = error "Map.elemAt: index out of range" +elemAt i (Bin _ kx x l r) + = case compare i sizeL of + LT -> elemAt i l + GT -> elemAt (i-sizeL-1) r + EQ -> (kx,x) + where + sizeL = size l + +-- | /O(log n)/. Update the element at /index/. Calls 'error' when an +-- invalid index is used. +updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a +updateAt f i Tip = error "Map.updateAt: index out of range" +updateAt f i (Bin sx kx x l r) + = case compare i sizeL of + LT -> updateAt f i l + GT -> updateAt f (i-sizeL-1) r + EQ -> case f kx x of + Just x' -> Bin sx kx x' l r + Nothing -> glue l r + where + sizeL = size l + +-- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@). +deleteAt :: Int -> Map k a -> Map k a +deleteAt i map + = updateAt (\k x -> Nothing) i map + + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal key of the map. +findMin :: Map k a -> (k,a) +findMin (Bin _ kx x Tip r) = (kx,x) +findMin (Bin _ kx x l r) = findMin l +findMin Tip = error "Map.findMin: empty tree has no minimal element" + +-- | /O(log n)/. The maximal key of the map. +findMax :: Map k a -> (k,a) +findMax (Bin _ kx x l Tip) = (kx,x) +findMax (Bin _ kx x l r) = findMax r +findMax Tip = error "Map.findMax: empty tree has no maximal element" + +-- | /O(log n)/. Delete the minimal key +deleteMin :: Map k a -> Map k a +deleteMin (Bin _ kx x Tip r) = r +deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r +deleteMin Tip = Tip + +-- | /O(log n)/. Delete the maximal key +deleteMax :: Map k a -> Map k a +deleteMax (Bin _ kx x l Tip) = l +deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r) +deleteMax Tip = Tip + +-- | /O(log n)/. Update the minimal key +updateMin :: (a -> Maybe a) -> Map k a -> Map k a +updateMin f m + = updateMinWithKey (\k x -> f x) m + +-- | /O(log n)/. Update the maximal key +updateMax :: (a -> Maybe a) -> Map k a -> Map k a +updateMax f m + = updateMaxWithKey (\k x -> f x) m + + +-- | /O(log n)/. Update the minimal key +updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a +updateMinWithKey f t + = case t of + Bin sx kx x Tip r -> case f kx x of + Nothing -> r + Just x' -> Bin sx kx x' Tip r + Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r + Tip -> Tip + +-- | /O(log n)/. Update the maximal key +updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a +updateMaxWithKey f t + = case t of + Bin sx kx x l Tip -> case f kx x of + Nothing -> l + Just x' -> Bin sx kx x' l Tip + Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r) + Tip -> Tip + + +{-------------------------------------------------------------------- + Union. +--------------------------------------------------------------------} +-- | The union of a list of maps: (@unions == foldl union empty@). +unions :: Ord k => [Map k a] -> Map k a +unions ts + = foldlStrict union empty ts + +-- | /O(n+m)/. +-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@). +-- The implementation uses the efficient /hedge-union/ algorithm. +union :: Ord k => Map k a -> Map k a -> Map k a +union Tip t2 = t2 +union t1 Tip = t1 +union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) + | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2 + | otherwise = hedgeUnionR (const LT) (const GT) t2 t1 + +-- left-biased hedge union +hedgeUnionL cmplo cmphi t1 Tip + = t1 +hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2 + = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) + (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2)) + where + cmpkx k = compare kx k + +-- right-biased hedge union +hedgeUnionR cmplo cmphi t1 Tip + = t1 +hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2 + = join kx newx (hedgeUnionR cmplo cmpkx l lt) + (hedgeUnionR cmpkx cmphi r gt) + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t2 + (found,gt) = trimLookupLo kx cmphi t2 + newx = case found of + Nothing -> x + Just y -> y + +{-------------------------------------------------------------------- + Union with a combining function +--------------------------------------------------------------------} +-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. +unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWith f m1 m2 + = unionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. +-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm. +unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWithKey f Tip t2 = t2 +unionWithKey f t1 Tip = t1 +unionWithKey f t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) + | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2 + | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1 + where + flipf k x y = f k y x + +hedgeUnionWithKey f cmplo cmphi t1 Tip + = t1 +hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r) + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2 + = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) + (hedgeUnionWithKey f cmpkx cmphi r gt) + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t2 + (found,gt) = trimLookupLo kx cmphi t2 + newx = case found of + Nothing -> x + Just y -> f kx x y + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(n+m)/. Difference of two maps. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +difference :: Ord k => Map k a -> Map k a -> Map k a +difference Tip t2 = Tip +difference t1 Tip = t1 +difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2 + +hedgeDiff cmplo cmphi Tip t + = Tip +hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeDiff cmplo cmphi t (Bin _ kx x l r) + = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) + (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r) + where + cmpkx k = compare kx k + +-- | /O(n+m)/. Difference with a combining function. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +differenceWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a +differenceWith f m1 m2 + = differenceWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns @Nothing@, the element is discarded (proper set difference). If +-- it returns (@Just y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/. +differenceWithKey :: Ord k => (k -> a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a +differenceWithKey f Tip t2 = Tip +differenceWithKey f t1 Tip = t1 +differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2 + +hedgeDiffWithKey f cmplo cmphi Tip t + = Tip +hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip + = join kx x (filterGt cmplo l) (filterLt cmphi r) +hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) + = case found of + Nothing -> merge tl tr + Just y -> case f kx y x of + Nothing -> merge tl tr + Just z -> join kx z tl tr + where + cmpkx k = compare kx k + lt = trim cmplo cmpkx t + (found,gt) = trimLookupLo kx cmphi t + tl = hedgeDiffWithKey f cmplo cmpkx lt l + tr = hedgeDiffWithKey f cmpkx cmphi gt r + + + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(n+m)/. Intersection of two maps. The values in the first +-- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@). +intersection :: Ord k => Map k a -> Map k a -> Map k a +intersection m1 m2 + = intersectionWithKey (\k x y -> x) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +intersectionWith f m1 m2 + = intersectionWithKey (\k x y -> f x y) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a +intersectionWithKey f Tip t = Tip +intersectionWithKey f t Tip = Tip +intersectionWithKey f t1 t2 -- intersection is more efficient on (bigset `intersection` smallset) + | size t1 >= size t2 = intersectWithKey f t1 t2 + | otherwise = intersectWithKey flipf t2 t1 + where + flipf k x y = f k y x + +intersectWithKey f Tip t = Tip +intersectWithKey f t Tip = Tip +intersectWithKey f t (Bin _ kx x l r) + = case found of + Nothing -> merge tl tr + Just y -> join kx (f kx y x) tl tr + where + (found,lt,gt) = splitLookup kx t + tl = intersectWithKey f lt l + tr = intersectWithKey f gt r + + + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(n+m)/. +-- This function is defined as (@subset = subsetBy (==)@). +subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool +subset m1 m2 + = subsetBy (==) m1 m2 + +{- | /O(n+m)/. + The expression (@subsetBy f t1 t2@) returns @True@ if + all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) + + But the following are all @False@: + + > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) + > subsetBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) +-} +subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool +subsetBy f t1 t2 + = (size t1 <= size t2) && (subset' f t1 t2) + +subset' f Tip t = True +subset' f t Tip = False +subset' f (Bin _ kx x l r) t + = case found of + Nothing -> False + Just y -> f x y && subset' f l lt && subset' f r gt + where + (found,lt,gt) = splitLookup kx t + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +-- Defined as (@properSubset = properSubsetBy (==)@). +properSubset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool +properSubset m1 m2 + = properSubsetBy (==) m1 m2 + +{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). + The expression (@properSubsetBy f m1 m2@) returns @True@ when + @m1@ and @m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns @True@ when + applied to their respective values. For example, the following + expressions are all @True@. + + > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + + But the following are all @False@: + + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) + > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) + > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +properSubsetBy :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool +properSubsetBy f t1 t2 + = (size t1 < size t2) && (subset' f t1 t2) + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> Map k a -> Map k a +filter p m + = filterWithKey (\k x -> p x) m + +-- | /O(n)/. Filter all keys\values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a +filterWithKey p Tip = Tip +filterWithKey p (Bin _ kx x l r) + | p kx x = join kx x (filterWithKey p l) (filterWithKey p r) + | otherwise = merge (filterWithKey p l) (filterWithKey p r) + + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a) +partition p m + = partitionWithKey (\k x -> p x) m + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a) +partitionWithKey p Tip = (Tip,Tip) +partitionWithKey p (Bin _ kx x l r) + | p kx x = (join kx x l1 r1,merge l2 r2) + | otherwise = (merge l1 r1,join kx x l2 r2) + where + (l1,l2) = partitionWithKey p l + (r1,r2) = partitionWithKey p r + + +{-------------------------------------------------------------------- + Mapping +--------------------------------------------------------------------} +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> Map k a -> Map k b +map f m + = mapWithKey (\k x -> f x) m + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey f Tip = Tip +mapWithKey f (Bin sx kx x l r) + = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r) + +-- | /O(n)/. The function @mapAccum@ threads an accumulating +-- argument through the map in an unspecified order. +mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccum f a m + = mapAccumWithKey (\a k x -> f a x) a m + +-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating +-- argument through the map in unspecified order. (= ascending pre-order) +mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumWithKey f a t + = mapAccumL f a t + +-- | /O(n)/. The function @mapAccumL@ threads an accumulating +-- argument throught the map in (ascending) pre-order. +mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumL f a t + = case t of + Tip -> (a,Tip) + Bin sx kx x l r + -> let (a1,l') = mapAccumL f a l + (a2,x') = f a1 kx x + (a3,r') = mapAccumL f a2 r + in (a3,Bin sx kx x' l' r') + +-- | /O(n)/. The function @mapAccumR@ threads an accumulating +-- argument throught the map in (descending) post-order. +mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) +mapAccumR f a t + = case t of + Tip -> (a,Tip) + Bin sx kx x l r + -> let (a1,r') = mapAccumR f a r + (a2,x') = f a1 kx x + (a3,l') = mapAccumR f a2 l + in (a3,Bin sx kx x' l' r') + +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} +-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order). +fold :: (a -> b -> b) -> b -> Map k a -> b +fold f z m + = foldWithKey (\k x z -> f x z) z m + +-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order). +foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b +foldWithKey f z t + = foldR f z t + +-- | /O(n)/. In-order fold. +foldI :: (k -> a -> b -> b -> b) -> b -> Map k a -> b +foldI f z Tip = z +foldI f z (Bin _ kx x l r) = f kx x (foldI f z l) (foldI f z r) + +-- | /O(n)/. Post-order fold. +foldR :: (k -> a -> b -> b) -> b -> Map k a -> b +foldR f z Tip = z +foldR f z (Bin _ kx x l r) = foldR f (f kx x (foldR f z r)) l + +-- | /O(n)/. Pre-order fold. +foldL :: (b -> k -> a -> b) -> b -> Map k a -> b +foldL f z Tip = z +foldL f z (Bin _ kx x l r) = foldL f (f (foldL f z l) kx x) r + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. Return all elements of the map. +elems :: Map k a -> [a] +elems m + = [x | (k,x) <- assocs m] + +-- | /O(n)/. Return all keys of the map. +keys :: Map k a -> [k] +keys m + = [k | (k,x) <- assocs m] + +-- | /O(n)/. Return all key\/value pairs in the map. +assocs :: Map k a -> [(k,a)] +assocs m + = toList m + +{-------------------------------------------------------------------- + Lists + use [foldlStrict] to reduce demand on the control-stack +--------------------------------------------------------------------} +-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +fromList :: Ord k => [(k,a)] -> Map k a +fromList xs + = foldlStrict ins empty xs + where + ins t (k,x) = insert k x t + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith f xs + = fromListWithKey (\k x y -> f x y) xs + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. +fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromListWithKey f xs + = foldlStrict ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n)/. Convert to a list of key\/value pairs. +toList :: Map k a -> [(k,a)] +toList t = toAscList t + +-- | /O(n)/. Convert to an ascending list. +toAscList :: Map k a -> [(k,a)] +toAscList t = foldR (\k x xs -> (k,x):xs) [] t + +-- | /O(n)/. +toDescList :: Map k a -> [(k,a)] +toDescList t = foldL (\xs k x -> (k,x):xs) [] t + + +{-------------------------------------------------------------------- + Building trees from ascending/descending lists can be done in linear time. + + Note that if [xs] is ascending that: + fromAscList xs == fromList xs + fromAscListWith f xs == fromListWith f xs +--------------------------------------------------------------------} +-- | /O(n)/. Build a map from an ascending list in linear time. +fromAscList :: Eq k => [(k,a)] -> Map k a +fromAscList xs + = fromAscListWithKey (\k x y -> x) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWith f xs + = fromAscListWithKey (\k x y -> f x y) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys +fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWithKey f xs + = fromDistinctAscList (combineEq f xs) + where + -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] + combineEq f xs + = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> combineEq' x xx + + combineEq' z [] = [z] + combineEq' z@(kz,zz) (x@(kx,xx):xs) + | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs + | otherwise = z:combineEq' x xs + + +-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [(k,a)] -> Map k a +fromDistinctAscList xs + = build const (length xs) xs + where + -- 1) use continutations so that we use heap space instead of stack space. + -- 2) special case for n==5 to build bushier trees. + build c 0 xs = c Tip xs + build c 5 xs = case xs of + ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) + -> c (bin k4 x4 (bin k2 x2 (single k1 x1) (single k3 x3)) (single k5 x5)) xx + build c n xs = seq nr $ build (buildR nr c) nl xs + where + nl = n `div` 2 + nr = n - nl - 1 + + buildR n c l ((k,x):ys) = build (buildB l k x c) n ys + buildB l k x c r zs = c (bin k x l r) zs + + + +{-------------------------------------------------------------------- + Utility functions that return sub-ranges of the original + tree. Some functions take a comparison function as argument to + allow comparisons against infinite values. A function [cmplo k] + should be read as [compare lo k]. + + [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT] + and [cmphi k == GT] for the key [k] of the root. + [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT] + [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT] + + [split k t] Returns two trees [l] and [r] where all keys + in [l] are <[k] and all keys in [r] are >[k]. + [splitLookup k t] Just like [split] but also returns whether [k] + was found in the tree. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + [trim lo hi t] trims away all subtrees that surely contain no + values between the range [lo] to [hi]. The returned tree is either + empty or the key of the root is between @lo@ and @hi@. +--------------------------------------------------------------------} +trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a +trim cmplo cmphi Tip = Tip +trim cmplo cmphi t@(Bin sx kx x l r) + = case cmplo kx of + LT -> case cmphi kx of + GT -> t + le -> trim cmplo cmphi l + ge -> trim cmplo cmphi r + +trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a) +trimLookupLo lo cmphi Tip = (Nothing,Tip) +trimLookupLo lo cmphi t@(Bin sx kx x l r) + = case compare lo kx of + LT -> case cmphi kx of + GT -> (lookup lo t, t) + le -> trimLookupLo lo cmphi l + GT -> trimLookupLo lo cmphi r + EQ -> (Just x,trim (compare lo) cmphi r) + + +{-------------------------------------------------------------------- + [filterGt k t] filter all keys >[k] from tree [t] + [filterLt k t] filter all keys <[k] from tree [t] +--------------------------------------------------------------------} +filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a +filterGt cmp Tip = Tip +filterGt cmp (Bin sx kx x l r) + = case cmp kx of + LT -> join kx x (filterGt cmp l) r + GT -> filterGt cmp r + EQ -> r + +filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a +filterLt cmp Tip = Tip +filterLt cmp (Bin sx kx x l r) + = case cmp kx of + LT -> filterLt cmp l + GT -> join kx x l (filterLt cmp r) + EQ -> l + +{-------------------------------------------------------------------- + Split +--------------------------------------------------------------------} +-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where +-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. +split :: Ord k => k -> Map k a -> (Map k a,Map k a) +split k Tip = (Tip,Tip) +split k (Bin sx kx x l r) + = case compare k kx of + LT -> let (lt,gt) = split k l in (lt,join kx x gt r) + GT -> let (lt,gt) = split k r in (join kx x l lt,gt) + EQ -> (l,r) + +-- | /O(log n)/. The expression (@splitLookup k map@) splits a map just +-- like 'split' but also returns @lookup k map@. +splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a) +splitLookup k Tip = (Nothing,Tip,Tip) +splitLookup k (Bin sx kx x l r) + = case compare k kx of + LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r) + GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt) + EQ -> (Just x,l,r) + +{-------------------------------------------------------------------- + Utility functions that maintain the balance properties of the tree. + All constructors assume that all values in [l] < [k] and all values + in [r] > [k], and that [l] and [r] are valid trees. + + In order of sophistication: + [Bin sz k x l r] The type constructor. + [bin k x l r] Maintains the correct size, assumes that both [l] + and [r] are balanced with respect to each other. + [balance k x l r] Restores the balance and size. + Assumes that the original tree was balanced and + that [l] or [r] has changed by at most one element. + [join k x l r] Restores balance and size. + + Furthermore, we can construct a new tree from two trees. Both operations + assume that all values in [l] < all values in [r] and that [l] and [r] + are valid: + [glue l r] Glues [l] and [r] together. Assumes that [l] and + [r] are already balanced with respect to each other. + [merge l r] Merges two trees and restores balance. + + Note: in contrast to Adam's paper, we use (<=) comparisons instead + of (<) comparisons in [join], [merge] and [balance]. + Quickcheck (on [difference]) showed that this was necessary in order + to maintain the invariants. It is quite unsatisfactory that I haven't + been able to find out why this is actually the case! Fortunately, it + doesn't hurt to be a bit more conservative. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + Join +--------------------------------------------------------------------} +join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a +join kx x Tip r = insertMin kx x r +join kx x l Tip = insertMax kx x l +join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz) + | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz + | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r) + | otherwise = bin kx x l r + + +-- insertMin and insertMax don't perform potentially expensive comparisons. +insertMax,insertMin :: k -> a -> Map k a -> Map k a +insertMax kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> balance ky y l (insertMax kx x r) + +insertMin kx x t + = case t of + Tip -> single kx x + Bin sz ky y l r + -> balance ky y (insertMin kx x l) r + +{-------------------------------------------------------------------- + [merge l r]: merges two trees. +--------------------------------------------------------------------} +merge :: Map k a -> Map k a -> Map k a +merge Tip r = r +merge l Tip = l +merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry) + | delta*sizeL <= sizeR = balance ky y (merge l ly) ry + | delta*sizeR <= sizeL = balance kx x lx (merge rx r) + | otherwise = glue l r + +{-------------------------------------------------------------------- + [glue l r]: glues two trees together. + Assumes that [l] and [r] are already balanced with respect to each other. +--------------------------------------------------------------------} +glue :: Map k a -> Map k a -> Map k a +glue Tip r = r +glue l Tip = l +glue l r + | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r + | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r' + + +-- | /O(log n)/. Delete and find the minimal element. +deleteFindMin :: Map k a -> ((k,a),Map k a) +deleteFindMin t + = case t of + Bin _ k x Tip r -> ((k,x),r) + Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r) + Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip) + +-- | /O(log n)/. Delete and find the maximal element. +deleteFindMax :: Map k a -> ((k,a),Map k a) +deleteFindMax t + = case t of + Bin _ k x l Tip -> ((k,x),l) + Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r') + Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip) + + +{-------------------------------------------------------------------- + [balance l x r] balances two trees with value x. + The sizes of the trees should balance after decreasing the + size of one of them. (a rotation). + + [delta] is the maximal relative difference between the sizes of + two trees, it corresponds with the [w] in Adams' paper. + [ratio] is the ratio between an outer and inner sibling of the + heavier subtree in an unbalanced setting. It determines + whether a double or single rotation should be performed + to restore balance. It is correspondes with the inverse + of $\alpha$ in Adam's article. + + Note that: + - [delta] should be larger than 4.646 with a [ratio] of 2. + - [delta] should be larger than 3.745 with a [ratio] of 1.534. + + - A lower [delta] leads to a more 'perfectly' balanced tree. + - A higher [delta] performs less rebalancing. + + - Balancing is automaic for random data and a balancing + scheme is only necessary to avoid pathological worst cases. + Almost any choice will do, and in practice, a rather large + [delta] may perform better than smaller one. + + Note: in contrast to Adam's paper, we use a ratio of (at least) [2] + to decide whether a single or double rotation is needed. Allthough + he actually proves that this ratio is needed to maintain the + invariants, his implementation uses an invalid ratio of [1]. +--------------------------------------------------------------------} +delta,ratio :: Int +delta = 5 +ratio = 2 + +balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r + | sizeL + sizeR <= 1 = Bin sizeX k x l r + | sizeR >= delta*sizeL = rotateL k x l r + | sizeL >= delta*sizeR = rotateR k x l r + | otherwise = Bin sizeX k x l r + where + sizeL = size l + sizeR = size r + sizeX = sizeL + sizeR + 1 + +-- rotate +rotateL k x l r@(Bin _ _ _ ly ry) + | size ly < ratio*size ry = singleL k x l r + | otherwise = doubleL k x l r + +rotateR k x l@(Bin _ _ _ ly ry) r + | size ry < ratio*size ly = singleR k x l r + | otherwise = doubleR k x l r + +-- basic rotations +singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3 +singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3) + +doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4) +doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4) + + +{-------------------------------------------------------------------- + The bin constructor maintains the size of the tree +--------------------------------------------------------------------} +bin :: k -> a -> Map k a -> Map k a -> Map k a +bin k x l r + = Bin (size l + size r + 1) k x l r + + +{-------------------------------------------------------------------- + Eq converts the tree to a list. In a lazy setting, this + actually seems one of the faster methods to compare two trees + and it is certainly the simplest :-) +--------------------------------------------------------------------} +instance (Eq k,Eq a) => Eq (Map k a) where + t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) + +{-------------------------------------------------------------------- + Functor +--------------------------------------------------------------------} +instance Functor (Map k) where + fmap f m = map f m + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance (Show k, Show a) => Show (Map k a) where + showsPrec d m = showMap (toAscList m) + +showMap :: (Show k,Show a) => [(k,a)] -> ShowS +showMap [] + = showString "{}" +showMap (x:xs) + = showChar '{' . showElem x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . showElem x . showTail xs + + showElem (k,x) = shows k . showString ":=" . shows x + + +-- | /O(n)/. Show the tree that implements the map. The tree is shown +-- in a compressed, hanging format. +showTree :: (Show k,Show a) => Map k a -> String +showTree m + = showTreeWith showElem True False m + where + showElem k x = show k ++ ":=" ++ show x + + +{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows + the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. + +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]] +> (4,()) +> +--(2,()) +> | +--(1,()) +> | +--(3,()) +> +--(5,()) +> +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]] +> (4,()) +> | +> +--(2,()) +> | | +> | +--(1,()) +> | | +> | +--(3,()) +> | +> +--(5,()) +> +> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]] +> +--(5,()) +> | +> (4,()) +> | +> | +--(3,()) +> | | +> +--(2,()) +> | +> +--(1,()) + +-} +showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String +showTreeWith showelem hang wide t + | hang = (showsTreeHang showelem wide [] t) "" + | otherwise = (showsTree showelem wide [] [] t) "" + +showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS +showsTree showelem wide lbars rbars t + = case t of + Tip -> showsBars lbars . showString "|\n" + Bin sz kx x Tip Tip + -> showsBars lbars . showString (showelem kx x) . showString "\n" + Bin sz kx x l r + -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . showString (showelem kx x) . showString "\n" . + showWide wide lbars . + showsTree showelem wide (withEmpty lbars) (withBar lbars) l + +showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS +showsTreeHang showelem wide bars t + = case t of + Tip -> showsBars bars . showString "|\n" + Bin sz kx x Tip Tip + -> showsBars bars . showString (showelem kx x) . showString "\n" + Bin sz kx x l r + -> showsBars bars . showString (showelem kx x) . showString "\n" . + showWide wide bars . + showsTreeHang showelem wide (withBar bars) l . + showWide wide bars . + showsTreeHang showelem wide (withEmpty bars) r + + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + + +{-------------------------------------------------------------------- + Assertions +--------------------------------------------------------------------} +-- | /O(n)/. Test if the internal map structure is valid. +valid :: Ord k => Map k a -> Bool +valid t + = balanced t && ordered t && validsize t + +ordered t + = bounded (const True) (const True) t + where + bounded lo hi t + = case t of + Tip -> True + Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (kx) hi r + +-- | Exported only for "Debug.QuickCheck" +balanced :: Map k a -> Bool +balanced t + = case t of + Tip -> True + Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && + balanced l && balanced r + + +validsize t + = (realsize t == Just (size t)) + where + realsize t + = case t of + Tip -> Just 0 + Bin sz kx x l r -> case (realsize l,realsize r) of + (Just n,Just m) | n+m+1 == sz -> Just sz + other -> Nothing + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree xs = fromList [(x,"*") | x <- xs] +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where + arbitrary = sized (arbtree 0 maxkey) + where maxkey = 10000 + +arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a) +arbtree lo hi n + | n <= 0 = return Tip + | lo >= hi = return Tip + | otherwise = do{ x <- arbitrary + ; i <- choose (lo,hi) + ; m <- choose (1,30) + ; let (ml,mr) | m==(1::Int)= (1,2) + | m==2 = (2,1) + | m==3 = (1,1) + | otherwise = (2,2) + ; l <- arbtree lo (i-1) (n `div` ml) + ; r <- arbtree (i+1) hi (n `div` mr) + ; return (bin (toEnum i) x l r) + } + + +{-------------------------------------------------------------------- + Valid tree's +--------------------------------------------------------------------} +forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property +forValid f + = forAll arbitrary $ \t -> +-- classify (balanced t) "balanced" $ + classify (size t == 0) "empty" $ + classify (size t > 0 && size t <= 10) "small" $ + classify (size t > 10 && size t <= 64) "medium" $ + classify (size t > 64) "large" $ + balanced t ==> f t + +forValidIntTree :: Testable a => (Map Int Int -> a) -> Property +forValidIntTree f + = forValid f + +forValidUnitTree :: Testable a => (Map Int () -> a) -> Property +forValidUnitTree f + = forValid f + + +prop_Valid + = forValidUnitTree $ \t -> valid t + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Int -> Bool +prop_Single k x + = (insert k x empty == single k x) + +prop_InsertValid :: Int -> Property +prop_InsertValid k + = forValidUnitTree $ \t -> valid (insert k () t) + +prop_InsertDelete :: Int -> Map Int () -> Property +prop_InsertDelete k t + = (lookup k t == Nothing) ==> delete k (insert k () t) == t + +prop_DeleteValid :: Int -> Property +prop_DeleteValid k + = forValidUnitTree $ \t -> + valid (delete k (insert k () t)) + +{-------------------------------------------------------------------- + Balance +--------------------------------------------------------------------} +prop_Join :: Int -> Property +prop_Join k + = forValidUnitTree $ \t -> + let (l,r) = split k t + in valid (join k () l r) + +prop_Merge :: Int -> Property +prop_Merge k + = forValidUnitTree $ \t -> + let (l,r) = split k t + in valid (merge l r) + + +{-------------------------------------------------------------------- + Union +--------------------------------------------------------------------} +prop_UnionValid :: Property +prop_UnionValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (union t1 t2) + +prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool +prop_UnionInsert k x t + = union (single k x) t == insert k x t + +prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: Map Int Int -> Map Int Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == unionWith (\x y -> y) t2 t1) + +prop_UnionWithValid + = forValidIntTree $ \t1 -> + forValidIntTree $ \t2 -> + valid (unionWithKey (\k x y -> x+y) t1 t2) + +prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_UnionWith xs ys + = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) + == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) + +prop_DiffValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (difference t1 t2) + +prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_Diff xs ys + = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) + +prop_IntValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (intersection t1 t2) + +prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_Int xs ys + = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) + == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [(x,()) | x <- [0..n::Int]] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) +-} diff --git a/src/UU/DData/MultiSet.hs b/src/UU/DData/MultiSet.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/MultiSet.hs @@ -0,0 +1,430 @@ +-------------------------------------------------------------------------------- +{-| 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 UU.DData.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 UU.DData.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 1) + +{-------------------------------------------------------------------- + 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 +-- We still expect not to get count < 0 +insertMany x 0 multiset = multiset +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 > 1 = 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 + -- Original, wrong + -- = MultiSet (M.unions [m | MultiSet m <- multisets]) + -- Map has no unionsWith + -- = MultiSet (M.unionsWith (+) [m | MultiSet m <- multisets]) + -- Correct, but requires Data.List.foldl' + -- = MultiSet (foldl' (M.unionWith (+)) M.empty [m | MultiSet m <- multisets]) + -- Correct, but not strict like the original (M.unions uses foldStrict) + = foldr union empty multisets + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a +filter p (MultiSet m) + = MultiSet (M.filterWithKey (\x n -> p x) m) + +-- | /O(n)/. Partition the multi set according to some predicate. +partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a) +partition p (MultiSet m) + = (MultiSet l,MultiSet r) + where + (l,r) = M.partitionWithKey (\x n -> p x) m + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over each element in the multi set. +fold :: (a -> b -> b) -> b -> MultiSet a -> b +fold f z (MultiSet m) + = M.foldWithKey apply z m + where + apply x n z | n > 0 = apply x (n-1) (f x z) + | otherwise = z + +-- | /O(n)/. Fold over all occurrences of an element at once. +foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b +foldOccur f z (MultiSet m) + = M.foldWithKey f z m + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | /O(log n)/. The minimal element of a multi set. +findMin :: MultiSet a -> a +findMin (MultiSet m) + = fst (M.findMin m) + +-- | /O(log n)/. The maximal element of a multi set. +findMax :: MultiSet a -> a +findMax (MultiSet m) + = fst (M.findMax m) + +-- | /O(log n)/. Delete the minimal element. +deleteMin :: MultiSet a -> MultiSet a +deleteMin (MultiSet m) + = MultiSet (M.updateMin f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete the maximal element. +deleteMax :: MultiSet a -> MultiSet a +deleteMax (MultiSet m) + = MultiSet (M.updateMax f m) + where + f n | n > 0 = Just (n-1) + | otherwise = Nothing + +-- | /O(log n)/. Delete all occurrences of the minimal element. +deleteMinAll :: MultiSet a -> MultiSet a +deleteMinAll (MultiSet m) + = MultiSet (M.deleteMin m) + +-- | /O(log n)/. Delete all occurrences of the maximal element. +deleteMaxAll :: MultiSet a -> MultiSet a +deleteMaxAll (MultiSet m) + = MultiSet (M.deleteMax m) + + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The list of elements. +elems :: MultiSet a -> [a] +elems s + = toList s + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Create a list with all elements. +toList :: MultiSet a -> [a] +toList s + = toAscList s + +-- | /O(n)/. Create an ascending list of all elements. +toAscList :: MultiSet a -> [a] +toAscList (MultiSet m) + = [y | (x,n) <- M.toAscList m, y <- replicate n x] + + +-- | /O(n*log n)/. Create a multi set from a list of elements. +fromList :: Ord a => [a] -> MultiSet a +fromList xs + = MultiSet (M.fromListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list in linear time. +fromAscList :: Eq a => [a] -> MultiSet a +fromAscList xs + = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs]) + +-- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time. +fromDistinctAscList :: [a] -> MultiSet a +fromDistinctAscList xs + = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs]) + +-- | /O(n)/. Create a list of element\/occurrence pairs. +toOccurList :: MultiSet a -> [(a,Int)] +toOccurList b + = toAscOccurList b + +-- | /O(n)/. Create an ascending list of element\/occurrence pairs. +toAscOccurList :: MultiSet a -> [(a,Int)] +toAscOccurList (MultiSet m) + = M.toAscList m + +-- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs. +fromOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromOccurList xs + = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +-- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs. +fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a +fromAscOccurList xs + = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) + +{-------------------------------------------------------------------- + Maps +--------------------------------------------------------------------} +-- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences. +toMap :: MultiSet a -> M.Map a Int +toMap (MultiSet m) + = m + +-- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +fromMap :: Ord a => M.Map a Int -> MultiSet a +fromMap m + = MultiSet (M.filter (>0) m) + +-- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set. +-- Assumes that the 'Map.Map' contains only elements that occur at least once. +fromOccurMap :: M.Map a Int -> MultiSet a +fromOccurMap m + = MultiSet m + +{-------------------------------------------------------------------- + Eq, Ord +--------------------------------------------------------------------} +instance Eq a => Eq (MultiSet a) where + (MultiSet m1) == (MultiSet m2) = (m1==m2) + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show a => Show (MultiSet a) where + showsPrec d b = showSet (toAscList b) + +showSet :: Show a => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x:xs) = showChar ',' . shows x . showTail xs + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree +-- is shown as a compressed and /hanging/. +showTree :: (Show a) => MultiSet a -> String +showTree mset + = showTreeWith True False mset + +-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows +-- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ +-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version +-- is shown. +showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String +showTreeWith hang wide (MultiSet m) + = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m + + +-- | /O(n)/. Is this a valid multi set? +valid :: Ord a => MultiSet a -> Bool +valid (MultiSet m) + = M.valid m && (M.isEmpty (M.filter (<=0) m)) diff --git a/src/UU/DData/Queue.hs b/src/UU/DData/Queue.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/Queue.hs @@ -0,0 +1,281 @@ +-------------------------------------------------------------------------------- +{-| 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 UU.DData.Queue ( + -- * Queue type + Queue -- instance Eq,Show + + -- * Operators + , (<>) + + -- * Query + , isEmpty + , length + , head + , tail + , front + + -- * Construction + , empty + , single + , insert + , append + + -- * Filter + , filter + , partition + + -- * Fold + , foldL + , foldR + + -- * Conversion + , elems + + -- ** List + , toList + , fromList + ) where + +import qualified Prelude as P (length,filter) +import Prelude hiding (length,head,tail,filter) +import qualified List + +-- just for testing +-- import QuickCheck + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixr 5 <> + +-- | /O(n)/. Append two queues, see 'append'. +(<>) :: Queue a -> Queue a -> Queue a +s <> t + = append s t + +{-------------------------------------------------------------------- + Queue. + Invariants for @(Queue xs ys zs)@: + * @length ys <= length xs@ + * @length zs == length xs - length ys@ +--------------------------------------------------------------------} +-- A queue of elements @a@. +data Queue a = Queue [a] [a] [a] + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} + +-- | /O(1)/. Is the queue empty? +isEmpty :: Queue a -> Bool +isEmpty (Queue xs ys zs) + = null xs + +-- | /O(n)/. The number of elements in the queue. +length :: Queue a -> Int +length (Queue xs ys zs) + = P.length xs + P.length ys + +-- | /O(1)/. The element in front of the queue. Raises an error +-- when the queue is empty. +head :: Queue a -> a +head (Queue xs ys zs) + = case xs of + (x:xx) -> x + [] -> error "Queue.head: empty queue" + +-- | /O(1)/. The tail of the queue. +-- Raises an error when the queue is empty. +tail :: Queue a -> Queue a +tail (Queue xs ys zs) + = case xs of + (x:xx) -> queue xx ys zs + [] -> error "Queue.tail: empty queue" + +-- | /O(1)/. The head and tail of the queue. +front :: Queue a -> Maybe (a,Queue a) +front (Queue xs ys zs) + = case xs of + (x:xx) -> Just (x,queue xx ys zs) + [] -> Nothing + + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty queue. +empty :: Queue a +empty + = Queue [] [] [] + +-- | /O(1)/. A queue of one element. +single :: a -> Queue a +single x + = Queue [x] [] [x] + +-- | /O(1)/. Insert an element at the back of a queue. +insert :: a -> Queue a -> Queue a +insert x (Queue xs ys zs) + = queue xs (x:ys) zs + + +-- | /O(n)/. Append two queues. +append :: Queue a -> Queue a -> Queue a +append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2) + = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2) + +{-------------------------------------------------------------------- + Filter +--------------------------------------------------------------------} +-- | /O(n)/. Filter elements according to some predicate. +filter :: (a -> Bool) -> Queue a -> Queue a +filter pred (Queue xs ys zs) + = balance xs' ys' + where + xs' = P.filter pred xs + ys' = P.filter pred ys + +-- | /O(n)/. Partition the elements according to some predicate. +partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a) +partition pred (Queue xs ys zs) + = (balance xs1 ys1, balance xs2 ys2) + where + (xs1,xs2) = List.partition pred xs + (ys1,ys2) = List.partition pred ys + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements from left to right (ie. head to tail). +foldL :: (b -> a -> b) -> b -> Queue a -> b +foldL f z (Queue xs ys zs) + = foldr (flip f) (foldl f z xs) ys + +-- | /O(n)/. Fold over the elements from right to left (ie. tail to head). +foldR :: (a -> b -> b) -> b -> Queue a -> b +foldR f z (Queue xs ys zs) + = foldr f (foldl (flip f) z ys) xs + + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a queue. +elems :: Queue a -> [a] +elems q + = toList q + +-- | /O(n)/. Convert to a list. +toList :: Queue a -> [a] +toList (Queue xs ys zs) + = xs ++ reverse ys + +-- | /O(n)/. Convert from a list. +fromList :: [a] -> Queue a +fromList xs + = Queue xs [] xs + + +{-------------------------------------------------------------------- + instance Eq, Show +--------------------------------------------------------------------} +instance Eq a => Eq (Queue a) where + q1 == q2 = toList q1 == toList q2 + +instance Show a => Show (Queue a) where + showsPrec d q = showsPrec d (toList q) + + +{-------------------------------------------------------------------- + Smart constructor: + Note that @(queue xs ys zs)@ is always called with + @(length zs == length xs - length ys + 1)@. and thus + @rotate@ is always called when @(length xs == length ys+1)@. +--------------------------------------------------------------------} +balance :: [a] -> [a] -> Queue a +balance xs ys + = Queue qs [] qs + where + qs = xs ++ reverse ys + +queue :: [a] -> [a] -> [a] -> Queue a +queue xs ys (z:zs) = Queue xs ys zs +queue xs ys [] = Queue qs [] qs + where + qs = rotate xs ys [] + +-- @(rotate xs ys []) == xs ++ reverse ys)@ +rotate :: [a] -> [a] -> [a] -> [a] +rotate [] [y] zs = y:zs +rotate (x:xs) (y:ys) zs = x:rotate xs ys (y:zs) +rotate xs ys zs = error "Queue.rotate: unbalanced queue" + + +valid :: Queue a -> Bool +valid (Queue xs ys zs) + = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs) + +{- +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 10000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced queues +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Queue a) where + arbitrary = do{ qs <- arbitrary + ; let (ys,xs) = splitAt (P.length qs `div` 2) qs + ; return (Queue xs ys (xs ++ reverse ys)) + } + + +prop_Valid :: Queue Int -> Bool +prop_Valid q + = valid q + +prop_InsertLast :: [Int] -> Property +prop_InsertLast xs + = not (null xs) ==> head (foldr insert empty xs) == last xs + +prop_InsertValid :: [Int] -> Bool +prop_InsertValid xs + = valid (foldr insert empty xs) + +prop_Queue :: [Int] -> Bool +prop_Queue xs + = toList (foldl (flip insert) empty xs) == foldr (:) [] xs + +prop_List :: [Int] -> Bool +prop_List xs + = toList (fromList xs) == xs + +prop_TailValid :: [Int] -> Bool +prop_TailValid xs + = valid (tail (foldr insert empty (1:xs))) +-} + diff --git a/src/UU/DData/Scc.hs b/src/UU/DData/Scc.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/Scc.hs @@ -0,0 +1,309 @@ +-------------------------------------------------------------------------------- +{-| 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 UU.DData.Scc ( scc ) where + +import qualified UU.DData.Map as Map +import qualified UU.DData.Set as Set + +{- +-- just for testing +import Debug.QuickCheck +import List(nub,sort) +-} + +{-------------------------------------------------------------------- + Graph +--------------------------------------------------------------------} +-- | A @Graph v@ is a directed graph with nodes @v@. +newtype Graph v = Graph (Map.Map v [v]) + +-- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from +-- node @x@ to node @y@. +type Edge v = (v,v) +type Node v = (v,[v]) + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +nodes :: Graph v -> [Node v] +nodes (Graph g) + = Map.toList g + +graph :: Ord v => [Node v] -> Graph v +graph es + = Graph (Map.fromListWith (++) es) + +{-------------------------------------------------------------------- + Graph functions +--------------------------------------------------------------------} +edges :: Graph v -> [Edge v] +edges g + = [(v,w) | (v,vs) <- nodes g, w <- vs] + +vertices :: Graph v -> [v] +vertices g + = [v | (v,vs) <- nodes g] + +successors :: Ord v => v -> Graph v -> [v] +successors v (Graph g) + = Map.findWithDefault [] v g + +transpose :: Ord v => Graph v -> Graph v +transpose g@(Graph m) + = Graph (foldr add empty (edges g)) + where + empty = Map.map (const []) m + add (v,w) m = Map.adjust (v:) w m + + +{-------------------------------------------------------------------- + Depth first search and forests +--------------------------------------------------------------------} +data Tree v = Node v (Forest v) +type Forest v = [Tree v] + +dff :: Ord v => Graph v -> Forest v +dff g + = dfs g (vertices g) + +dfs :: Ord v => Graph v -> [v] -> Forest v +dfs g vs + = prune (map (tree g) vs) + +tree :: Ord v => Graph v -> v -> Tree v +tree g v + = Node v (map (tree g) (successors v g)) + +prune :: Ord v => Forest v -> Forest v +prune fs + = snd (chop Set.empty fs) + where + chop ms [] = (ms,[]) + chop ms (Node v vs:fs) + | visited = chop ms fs + | otherwise = let ms0 = Set.insert v ms + (ms1,vs') = chop ms0 vs + (ms2,fs') = chop ms1 fs + in (ms2,Node v vs':fs') + where + visited = Set.member v ms + +{-------------------------------------------------------------------- + Orderings +--------------------------------------------------------------------} +preorder :: Ord v => Graph v -> [v] +preorder g + = preorderF (dff g) + +preorderF fs + = concatMap preorderT fs + +preorderT (Node v fs) + = v:preorderF fs + +postorder :: Ord v => Graph v -> [v] +postorder g + = postorderF (dff g) + +postorderT t + = postorderF [t] + +postorderF ts + = postorderF' ts [] + where + -- efficient concatenation by passing the tail around. + postorderF' [] tl = tl + postorderF' (t:ts) tl = postorderT' t (postorderF' ts tl) + postorderT' (Node v fs) tl = postorderF' fs (v:tl) + + +{-------------------------------------------------------------------- + Strongly connected components +--------------------------------------------------------------------} + +{- | + Compute the strongly connected components of a graph. The algorithm + is tailored toward the needs of compiler writers that need to compute + recursive binding groups (for example, the original order is preserved + as much as possible). + + The expression (@scc xs@) computes the strongly connectected components + of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node + label and @ws@ a list of nodes where @v@ points to, ie. there is an + arrow\/dependency from @v@ to each node in @ws@. Here is an example + of @scc@: + +> Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])] +> [[3],[1,2],[0],[4]] + + In an expression @(scc xs)@, the graph @xs@ should contain an entry for + every node in the graph, ie: + +> all (`elem` nodes) targets +> where nodes = map fst xs +> targets = concat (map snd xs) + + Furthermore, the returned components consist exactly of the original nodes: + +> sort (concat (scc xs)) == sort (map fst xs) + + The connected components are sorted by dependency, ie. there are + no arrows\/dependencies from left-to-right. Furthermore, the original order + is preserved as much as possible. +-} +scc :: Ord v => [(v,[v])] -> [[v]] +scc nodes + = sccG (graph nodes) + +sccG :: Ord v => Graph v -> [[v]] +sccG g + = map preorderT (sccF g) + +sccF :: Ord v => Graph v -> Forest v +sccF g + = reverse (dfs (transpose g) (topsort g)) + +topsort g + = reverse (postorder g) + +{-------------------------------------------------------------------- + Reachable and path +--------------------------------------------------------------------} +reachable v g + = preorderF (dfs g [v]) + +path v w g + = elem w (reachable v g) + + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance Show v => Show (Graph v) where + showsPrec d (Graph m) = shows m + +instance Show v => Show (Tree v) where + showsPrec d (Node v []) = shows v + showsPrec d (Node v fs) = shows v . showList fs + + +{-------------------------------------------------------------------- + Quick Test +--------------------------------------------------------------------} +tgraph0 :: Graph Int +tgraph0 = graph + [(0,[1]) + ,(1,[2,1,3]) + ,(2,[1]) + ,(3,[]) + ] + +tgraph1 = graph + [ ('a',"jg") + , ('b',"ia") + , ('c',"he") + , ('d',"") + , ('e',"jhd") + , ('f',"i") + , ('g',"fb") + , ('h',"") + ] + +{- +{-------------------------------------------------------------------- + Quickcheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary Graph's +--------------------------------------------------------------------} +instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where + arbitrary = sized arbgraph + + +arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v) +arbgraph n + = do nodes <- arbitrary + g <- mapM (targets nodes) nodes + return (graph g) + where + targets nodes v + = do sz <- choose (0,length nodes-1) + ts <- mapM (target nodes) [1..sz] + return (v,ts) + + target nodes _ + = do idx <- choose (0,length nodes-1) + return (nodes!!idx) + +{-------------------------------------------------------------------- + Properties +--------------------------------------------------------------------} +prop_ValidGraph :: Graph Int -> Bool +prop_ValidGraph g + = all (`elem` srcs) targets + where + srcs = map fst (nodes g) + targets = concatMap snd (nodes g) + +-- all scc nodes are in the original graph and the other way around +prop_SccComplete :: Graph Int -> Bool +prop_SccComplete g + = sort (concat (sccG g)) == sort (vertices g) + +-- all scc nodes have only backward dependencies +prop_SccForward :: Graph Int -> Bool +prop_SccForward g + = all noforwards (zip prevs ss) + where + ss = sccG g + prevs = scanl1 (++) ss + + noforwards (prev,xs) + = all (noforward prev) xs + + noforward prev x + = all (`elem` prev) (successors x g) + +-- all strongly connected components refer to each other +prop_SccConnected :: Graph Int -> Bool +prop_SccConnected g + = all connected (sccG g) + where + connected xs + = all (paths xs) xs + + paths xs x + = all (\y -> path x y g) xs + +-} + diff --git a/src/UU/DData/Seq.hs b/src/UU/DData/Seq.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/Seq.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- +{-| Module : Seq + Copyright : (c) Daan Leijen 2002 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + An implementation of John Hughes's efficient catenable sequence type. A lazy sequence + @Seq a@ can be concatenated in /O(1)/ time. After + construction, the sequence in converted in /O(n)/ time into a list. +-} +---------------------------------------------------------------------------------} +module UU.DData.Seq( -- * Type + Seq + -- * Operators + , (<>) + + -- * Construction + , empty + , single + , cons + , append + + -- * Conversion + , toList + , fromList + ) where + + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixr 5 <> + +-- | /O(1)/. Append two sequences, see 'append'. +(<>) :: Seq a -> Seq a -> Seq a +s <> t + = append s t + +{-------------------------------------------------------------------- + Type +--------------------------------------------------------------------} +-- | Sequences of values @a@. +newtype Seq a = Seq ([a] -> [a]) + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. Create an empty sequence. +empty :: Seq a +empty + = Seq (\ts -> ts) + +-- | /O(1)/. Create a sequence of one element. +single :: a -> Seq a +single x + = Seq (\ts -> x:ts) + +-- | /O(1)/. Put a value in front of a sequence. +cons :: a -> Seq a -> Seq a +cons x (Seq f) + = Seq (\ts -> x:f ts) + +-- | /O(1)/. Append two sequences. +append :: Seq a -> Seq a -> Seq a +append (Seq f) (Seq g) + = Seq (\ts -> f (g ts)) + + +{-------------------------------------------------------------------- + Conversion +--------------------------------------------------------------------} +-- | /O(n)/. Convert a sequence to a list. +toList :: Seq a -> [a] +toList (Seq f) + = f [] + +-- | /O(n)/. Create a sequence from a list. +fromList :: [a] -> Seq a +fromList xs + = Seq (\ts -> xs++ts) + + + + + + + + diff --git a/src/UU/DData/Set.hs b/src/UU/DData/Set.hs new file mode 100644 --- /dev/null +++ b/src/UU/DData/Set.hs @@ -0,0 +1,1032 @@ +-------------------------------------------------------------------------------- +{-| 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.single "Paris" + + Or, if you prefer a terse coding style: + + > import qualified Set as S + > + > ... S.single "Berlin" + + 2) The implementation of "Set" is based on /size balanced/ binary trees (or + trees of /bounded balance/) as described by: + + * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional + Programming 3(4):553-562, October 1993, . + + * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\", + SIAM journal of computing 2(1), March 1973. + + 3) Note that the implementation /left-biased/ -- the elements of a first argument + are always perferred to the second, for example in 'union' or 'insert'. + Off course, left-biasing can only be observed when equality an equivalence relation + instead of structural equality. + + 4) Another implementation of sets based on size balanced trees + exists as "Data.Set" in the Ghc libraries. The good part about this library + is that it is highly tuned and thorougly tested. However, it is also fairly old, + it is implemented indirectly on top of "Data.FiniteMap" and only supports + the basic set operations. + The "Set" module overcomes some of these issues: + + * It tries to export a more complete and consistent set of operations, like + 'partition', 'subset' etc. + + * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' + (a /hedge/ algorithm is not applicable to 'intersection'). + + * It converts ordered lists in linear time ('fromAscList'). + + * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'. + + * It is implemented directly, instead of using a seperate finite map implementation. +-} +--------------------------------------------------------------------------------- +module UU.DData.Set ( + -- * Set type + Set -- 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 + + -- * 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) + +{- +-- 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 + +-- | /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. +single :: a -> Set a +single 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 -> single 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 + +{-------------------------------------------------------------------- + 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 (single x1) (single x3)) (single 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) + +{-------------------------------------------------------------------- + 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 -> single x + Bin sz y l r + -> balance y l (insertMax x r) + +insertMin x t + = case t of + Tip -> single x + Bin sz y l r + -> balance y (insertMin x l) r + +{-------------------------------------------------------------------- + [merge l r]: merges two trees. +--------------------------------------------------------------------} +merge :: Set a -> Set a -> Set a +merge Tip r = r +merge l Tip = l +merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry) + | delta*sizeL <= sizeR = balance y (merge l ly) ry + | delta*sizeR <= sizeL = balance x lx (merge rx r) + | otherwise = glue l r + +{-------------------------------------------------------------------- + [glue l r]: glues two trees together. + Assumes that [l] and [r] are already balanced with respect to each other. +--------------------------------------------------------------------} +glue :: Set a -> Set a -> Set a +glue Tip r = r +glue l Tip = l +glue l r + | size l > size r = let (m,l') = deleteFindMax l in balance m l' r + | otherwise = let (m,r') = deleteFindMin r in balance m l r' + + +-- | /O(log n)/. Delete and find the minimal element. +deleteFindMin :: Set a -> (a,Set a) +deleteFindMin t + = case t of + Bin _ x Tip r -> (x,r) + Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r) + Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) + +-- | /O(log n)/. Delete and find the maximal element. +deleteFindMax :: Set a -> (a,Set a) +deleteFindMax t + = case t of + Bin _ x l Tip -> (x,l) + Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r') + Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip) + + +{-------------------------------------------------------------------- + [balance x l r] balances two trees with value x. + The sizes of the trees should balance after decreasing the + size of one of them. (a rotation). + + [delta] is the maximal relative difference between the sizes of + two trees, it corresponds with the [w] in Adams' paper, + or equivalently, [1/delta] corresponds with the $\alpha$ + in Nievergelt's paper. Adams shows that [delta] should + be larger than 3.745 in order to garantee that the + rotations can always restore balance. + + [ratio] is the ratio between an outer and inner sibling of the + heavier subtree in an unbalanced setting. It determines + whether a double or single rotation should be performed + to restore balance. It is correspondes with the inverse + of $\alpha$ in Adam's article. + + Note that: + - [delta] should be larger than 4.646 with a [ratio] of 2. + - [delta] should be larger than 3.745 with a [ratio] of 1.534. + + - A lower [delta] leads to a more 'perfectly' balanced tree. + - A higher [delta] performs less rebalancing. + + - Balancing is automatic for random data and a balancing + scheme is only necessary to avoid pathological worst cases. + Almost any choice will do in practice + + - Allthough it seems that a rather large [delta] may perform better + than smaller one, measurements have shown that the smallest [delta] + of 4 is actually the fastest on a wide range of operations. It + especially improves performance on worst-case scenarios like + a sequence of ordered insertions. + + Note: in contrast to Adams' paper, we use a ratio of (at least) 2 + to decide whether a single or double rotation is needed. Allthough + he actually proves that this ratio is needed to maintain the + invariants, his implementation uses a (invalid) ratio of 1. + He is aware of the problem though since he has put a comment in his + original source code that he doesn't care about generating a + slightly inbalanced tree since it doesn't seem to matter in practice. + However (since we use quickcheck :-) we will stick to strictly balanced + trees. +--------------------------------------------------------------------} +delta,ratio :: Int +delta = 4 +ratio = 2 + +balance :: a -> Set a -> Set a -> Set a +balance x l r + | sizeL + sizeR <= 1 = Bin sizeX x l r + | sizeR >= delta*sizeL = rotateL x l r + | sizeL >= delta*sizeR = rotateR x l r + | otherwise = Bin sizeX x l r + where + sizeL = size l + sizeR = size r + sizeX = sizeL + sizeR + 1 + +-- rotate +rotateL x l r@(Bin _ _ ly ry) + | size ly < ratio*size ry = singleL x l r + | otherwise = doubleL x l r + +rotateR x l@(Bin _ _ ly ry) r + | size ry < ratio*size ly = singleR x l r + | otherwise = doubleR x l r + +-- basic rotations +singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3 +singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3) + +doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4) +doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4) + + +{-------------------------------------------------------------------- + The bin constructor maintains the size of the tree +--------------------------------------------------------------------} +bin :: a -> Set a -> Set a -> Set a +bin x l r + = Bin (size l + size r + 1) x l r + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) + + +{-------------------------------------------------------------------- + Debugging +--------------------------------------------------------------------} +-- | /O(n)/. Show the tree that implements the set. The tree is shown +-- in a compressed, hanging format. +showTree :: Show a => Set a -> String +showTree s + = showTreeWith True False s + + +{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows + the tree that implements the set. If @hang@ is + @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If + @wide@ is true, an extra wide version is shown. + +> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5] +> 4 +> +--2 +> | +--1 +> | +--3 +> +--5 +> +> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5] +> 4 +> | +> +--2 +> | | +> | +--1 +> | | +> | +--3 +> | +> +--5 +> +> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5] +> +--5 +> | +> 4 +> | +> | +--3 +> | | +> +--2 +> | +> +--1 + +-} +showTreeWith :: Show a => Bool -> Bool -> Set a -> String +showTreeWith hang wide t + | hang = (showsTreeHang wide [] t) "" + | otherwise = (showsTree wide [] [] t) "" + +showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS +showsTree wide lbars rbars t + = case t of + Tip -> showsBars lbars . showString "|\n" + Bin sz x Tip Tip + -> showsBars lbars . shows x . showString "\n" + Bin sz x l r + -> showsTree wide (withBar rbars) (withEmpty rbars) r . + showWide wide rbars . + showsBars lbars . shows x . showString "\n" . + showWide wide lbars . + showsTree wide (withEmpty lbars) (withBar lbars) l + +showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS +showsTreeHang wide bars t + = case t of + Tip -> showsBars bars . showString "|\n" + Bin sz x Tip Tip + -> showsBars bars . shows x . showString "\n" + Bin sz x l r + -> showsBars bars . shows x . showString "\n" . + showWide wide bars . + showsTreeHang wide (withBar bars) l . + showWide wide bars . + showsTreeHang wide (withEmpty bars) r + + +showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id + +showsBars :: [String] -> ShowS +showsBars bars + = case bars of + [] -> id + _ -> showString (concat (reverse (tail bars))) . showString node + +node = "+--" +withBar bars = "| ":bars +withEmpty bars = " ":bars + +{-------------------------------------------------------------------- + Assertions +--------------------------------------------------------------------} +-- | /O(n)/. Test if the internal set structure is valid. +valid :: Ord a => Set a -> Bool +valid t + = balanced t && ordered t && validsize t + +ordered t + = bounded (const True) (const True) t + where + bounded lo hi t + = case t of + Tip -> True + Bin sz x l r -> (lo x) && (hi x) && bounded lo (x) hi r + +balanced :: Set a -> Bool +balanced t + = case t of + Tip -> True + Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) && + balanced l && balanced r + + +validsize t + = (realsize t == Just (size t)) + where + realsize t + = case t of + Tip -> Just 0 + Bin sz x l r -> case (realsize l,realsize r) of + (Just n,Just m) | n+m+1 == sz -> Just sz + other -> Nothing + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +testTree :: [Int] -> Set Int +testTree xs = fromList xs +test1 = testTree [1..20] +test2 = testTree [30,29..10] +test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3] + +{-------------------------------------------------------------------- + QuickCheck +--------------------------------------------------------------------} +qcheck prop + = check config prop + where + config = Config + { configMaxTest = 500 + , configMaxFail = 5000 + , configSize = \n -> (div n 2 + 3) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + + +{-------------------------------------------------------------------- + Arbitrary, reasonably balanced trees +--------------------------------------------------------------------} +instance (Enum a) => Arbitrary (Set a) where + arbitrary = sized (arbtree 0 maxkey) + where maxkey = 10000 + +arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a) +arbtree lo hi n + | n <= 0 = return Tip + | lo >= hi = return Tip + | otherwise = do{ i <- choose (lo,hi) + ; m <- choose (1,30) + ; let (ml,mr) | m==(1::Int)= (1,2) + | m==2 = (2,1) + | m==3 = (1,1) + | otherwise = (2,2) + ; l <- arbtree lo (i-1) (n `div` ml) + ; r <- arbtree (i+1) hi (n `div` mr) + ; return (bin (toEnum i) l r) + } + + +{-------------------------------------------------------------------- + Valid tree's +--------------------------------------------------------------------} +forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property +forValid f + = forAll arbitrary $ \t -> +-- classify (balanced t) "balanced" $ + classify (size t == 0) "empty" $ + classify (size t > 0 && size t <= 10) "small" $ + classify (size t > 10 && size t <= 64) "medium" $ + classify (size t > 64) "large" $ + balanced t ==> f t + +forValidIntTree :: Testable a => (Set Int -> a) -> Property +forValidIntTree f + = forValid f + +forValidUnitTree :: Testable a => (Set Int -> a) -> Property +forValidUnitTree f + = forValid f + + +prop_Valid + = forValidUnitTree $ \t -> valid t + +{-------------------------------------------------------------------- + Single, Insert, Delete +--------------------------------------------------------------------} +prop_Single :: Int -> Bool +prop_Single x + = (insert x empty == single 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 (single x) == insert x t + +prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool +prop_UnionAssoc t1 t2 t3 + = union t1 (union t2 t3) == union (union t1 t2) t3 + +prop_UnionComm :: Set Int -> Set Int -> Bool +prop_UnionComm t1 t2 + = (union t1 t2 == union t2 t1) + + +prop_DiffValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (difference t1 t2) + +prop_Diff :: [Int] -> [Int] -> Bool +prop_Diff xs ys + = toAscList (difference (fromList xs) (fromList ys)) + == List.sort ((List.\\) (nub xs) (nub ys)) + +prop_IntValid + = forValidUnitTree $ \t1 -> + forValidUnitTree $ \t2 -> + valid (intersection t1 t2) + +prop_Int :: [Int] -> [Int] -> Bool +prop_Int xs ys + = toAscList (intersection (fromList xs) (fromList ys)) + == List.sort (nub ((List.intersect) (xs) (ys))) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +prop_Ordered + = forAll (choose (5,100)) $ \n -> + let xs = [0..n::Int] + in fromAscList xs == fromList xs + +prop_List :: [Int] -> Bool +prop_List xs + = (sort (nub xs) == toList (fromList xs)) +-} diff --git a/src/UU/PPrint.hs b/src/UU/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/UU/PPrint.hs @@ -0,0 +1,414 @@ +-------------------------------------------------------------------------------- +{-| Module : PPrint + Copyright : (c) Daan Leijen 2000, + Version : $version: $ + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Pretty print library based on Philip Wadlers "prettier printer" + "A prettier printer" + Draft paper, April 1997, revised March 1998. + + + Haskell98 compatible +-} +--------------------------------------------------------------------------------- +module UU.PPrint + ( Doc + , Pretty, pretty + + , show, putDoc, hPutDoc + + , (<>) + , (<+>) + , (), () + , (<$>), (<$$>) + + , sep, fillSep, hsep, vsep + , cat, fillCat, hcat, vcat + , punctuate + + , align, hang, indent + , fill, fillBreak + + , list, tupled, semiBraces, encloseSep + , angles, langle, rangle + , parens, lparen, rparen + , braces, lbrace, rbrace + , brackets, lbracket, rbracket + , dquotes, dquote, squotes, squote + + , comma, space, dot, backslash + , semi, colon, equals + + , string, bool, int, integer, float, double, rational + + , softline, softbreak + , empty, char, text, line, linebreak, nest, group + , column, nesting, width + + , SimpleDoc(..) + , renderPretty, renderCompact + , displayS, displayIO + ) where + +import IO (Handle,hPutStr,hPutChar,stdout) + +infixr 5 ,,<$>,<$$> +infixr 6 <>,<+> + + +----------------------------------------------------------- +-- list, tupled and semiBraces pretty print a list of +-- documents either horizontally or vertically aligned. +----------------------------------------------------------- +list = encloseSep lbracket rbracket comma +tupled = encloseSep lparen rparen comma +semiBraces = encloseSep lbrace rbrace semi + +encloseSep left right sep ds + = case ds of + [] -> left <> right + [d] -> left <> d <> right + _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) + + +----------------------------------------------------------- +-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] +----------------------------------------------------------- +punctuate p [] = [] +punctuate p [d] = [d] +punctuate p (d:ds) = (d <> p) : punctuate p ds + + +----------------------------------------------------------- +-- high-level combinators +----------------------------------------------------------- +sep = group . vsep +fillSep = fold () +hsep = fold (<+>) +vsep = fold (<$>) + +cat = group . vcat +fillCat = fold () +hcat = fold (<>) +vcat = fold (<$$>) + +fold f [] = empty +fold f ds = foldr1 f ds + +x <> y = x `beside` y +x <+> y = x <> space <> y +x y = x <> softline <> y +x y = x <> softbreak <> y +x <$> y = x <> line <> y +x <$$> y = x <> linebreak <> y + +softline = group line +softbreak = group linebreak + +squotes = enclose squote squote +dquotes = enclose dquote dquote +braces = enclose lbrace rbrace +parens = enclose lparen rparen +angles = enclose langle rangle +brackets = enclose lbracket rbracket +enclose l r x = l <> x <> r + +lparen = char '(' +rparen = char ')' +langle = char '<' +rangle = char '>' +lbrace = char '{' +rbrace = char '}' +lbracket = char '[' +rbracket = char ']' + +squote = char '\'' +dquote = char '"' +semi = char ';' +colon = char ':' +comma = char ',' +space = char ' ' +dot = char '.' +backslash = char '\\' +equals = char '=' + + +----------------------------------------------------------- +-- Combinators for prelude types +----------------------------------------------------------- + +-- string is like "text" but replaces '\n' by "line" +string "" = empty +string ('\n':s) = line <> string s +string s = case (span (/='\n') s) of + (xs,ys) -> text xs <> string ys + +bool :: Bool -> Doc +bool b = text (show b) + +int :: Int -> Doc +int i = text (show i) + +integer :: Integer -> Doc +integer i = text (show i) + +float :: Float -> Doc +float f = text (show f) + +double :: Double -> Doc +double d = text (show d) + +rational :: Rational -> Doc +rational r = text (show r) + + +----------------------------------------------------------- +-- overloading "pretty" +----------------------------------------------------------- +class Pretty a where + pretty :: a -> Doc + prettyList :: [a] -> Doc + prettyList = list . map pretty + +instance Pretty a => Pretty [a] where + pretty = prettyList + +instance Pretty Doc where + pretty = id + +instance Pretty () where + pretty () = text "()" + +instance Pretty Bool where + pretty b = bool b + +instance Pretty Char where + pretty c = char c + prettyList s = string s + +instance Pretty Int where + pretty i = int i + +instance Pretty Integer where + pretty i = integer i + +instance Pretty Float where + pretty f = float f + +instance Pretty Double where + pretty d = double d + + +--instance Pretty Rational where +-- pretty r = rational r + +instance (Pretty a,Pretty b) => Pretty (a,b) where + pretty (x,y) = tupled [pretty x, pretty y] + +instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where + pretty (x,y,z)= tupled [pretty x, pretty y, pretty z] + +instance Pretty a => Pretty (Maybe a) where + pretty Nothing = empty + pretty (Just x) = pretty x + + + +----------------------------------------------------------- +-- semi primitive: fill and fillBreak +----------------------------------------------------------- +fillBreak f x = width x (\w -> + if (w > f) then nest f linebreak + else text (spaces (f - w))) + +fill f d = width d (\w -> + if (w >= f) then empty + else text (spaces (f - w))) + +width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) + + +----------------------------------------------------------- +-- semi primitive: Alignment and indentation +----------------------------------------------------------- +indent i d = hang i (text (spaces i) <> d) + +hang i d = align (nest i d) + +align d = column (\k -> + nesting (\i -> nest (k - i) d)) --nesting might be negative :-) + + + +----------------------------------------------------------- +-- Primitives +----------------------------------------------------------- +data Doc = Empty + | Char Char -- invariant: char is not '\n' + | Text !Int String -- invariant: text doesn't contain '\n' + | Line !Bool -- True <=> when undone by group, do not insert a space + | Cat Doc Doc + | Nest !Int Doc + | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc + | Column (Int -> Doc) + | Nesting (Int -> Doc) + +data SimpleDoc = SEmpty + | SChar Char SimpleDoc + | SText !Int String SimpleDoc + | SLine !Int SimpleDoc + + +empty = Empty + +char '\n' = line +char c = Char c + +text "" = Empty +text s = Text (length s) s + +line = Line False +linebreak = Line True + +beside x y = Cat x y +nest i x = Nest i x +column f = Column f +nesting f = Nesting f +group x = Union (flatten x) x + +flatten :: Doc -> Doc +flatten (Cat x y) = Cat (flatten x) (flatten y) +flatten (Nest i x) = Nest i (flatten x) +flatten (Line break) = if break then Empty else Text 1 " " +flatten (Union x y) = flatten x +flatten (Column f) = Column (flatten . f) +flatten (Nesting f) = Nesting (flatten . f) +flatten other = other --Empty,Char,Text + + + +----------------------------------------------------------- +-- Renderers +----------------------------------------------------------- + +----------------------------------------------------------- +-- renderPretty: the default pretty printing algorithm +----------------------------------------------------------- + +-- list of indentation/document pairs; saves an indirection over [(Int,Doc)] +data Docs = Nil + | Cons !Int Doc Docs + +renderPretty :: Float -> Int -> Doc -> SimpleDoc +renderPretty rfrac w x + = best 0 0 (Cons 0 x Nil) + where + -- r :: the ribbon width in characters + r = max 0 (min w (round (fromIntegral w * rfrac))) + + -- best :: n = indentation of current line + -- k = current column + -- (ie. (k >= n) && (k - n == count of inserted characters) + best n k Nil = SEmpty + best n k (Cons i d ds) + = case d of + Empty -> best n k ds + Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds)) + Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds)) + Line _ -> SLine i (best i i ds) + Cat x y -> best n k (Cons i x (Cons i y ds)) + Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds)) + Union x y -> nicest n k (best n k (Cons i x ds)) + (best n k (Cons i y ds)) + + Column f -> best n k (Cons i (f k) ds) + Nesting f -> best n k (Cons i (f i) ds) + + --nicest :: r = ribbon width, w = page width, + -- n = indentation of current line, k = current column + -- x and y, the (simple) documents to chose from. + -- precondition: first lines of x are longer than the first lines of y. + nicest n k x y | fits width x = x + | otherwise = y + where + width = min (w - k) (r - k + n) + + +fits w x | w < 0 = False +fits w SEmpty = True +fits w (SChar c x) = fits (w - 1) x +fits w (SText l s x) = fits (w - l) x +fits w (SLine i x) = True + + +----------------------------------------------------------- +-- renderCompact: renders documents without indentation +-- fast and fewer characters output, good for machines +----------------------------------------------------------- +renderCompact :: Doc -> SimpleDoc +renderCompact x + = scan 0 [x] + where + scan k [] = SEmpty + scan k (d:ds) = case d of + Empty -> scan k ds + Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) + Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) + Line _ -> SLine 0 (scan 0 ds) + Cat x y -> scan k (x:y:ds) + Nest j x -> scan k (x:ds) + Union x y -> scan k (y:ds) + Column f -> scan k (f k:ds) + Nesting f -> scan k (f 0:ds) + + + +----------------------------------------------------------- +-- Displayers: displayS and displayIO +----------------------------------------------------------- +displayS :: SimpleDoc -> ShowS +displayS SEmpty = id +displayS (SChar c x) = showChar c . displayS x +displayS (SText l s x) = showString s . displayS x +displayS (SLine i x) = showString ('\n':indentation i) . displayS x + +displayIO :: Handle -> SimpleDoc -> IO () +displayIO handle simpleDoc + = display simpleDoc + where + display SEmpty = return () + display (SChar c x) = do{ hPutChar handle c; display x} + display (SText l s x) = do{ hPutStr handle s; display x} + display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x} + + +----------------------------------------------------------- +-- default pretty printers: show, putDoc and hPutDoc +----------------------------------------------------------- +instance Show Doc where + showsPrec d doc = displayS (renderPretty 0.4 80 doc) + +putDoc :: Doc -> IO () +putDoc doc = hPutDoc stdout doc + +hPutDoc :: Handle -> Doc -> IO () +hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc) + + + +----------------------------------------------------------- +-- insert spaces +-- "indentation" used to insert tabs but tabs seem to cause +-- more trouble than they solve :-) +----------------------------------------------------------- +spaces n | n <= 0 = "" + | otherwise = replicate n ' ' + +indentation n = spaces n + +--indentation n | n >= 8 = '\t' : indentation (n-8) +-- | otherwise = spaces n diff --git a/src/UU/Parsing.hs b/src/UU/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing.hs @@ -0,0 +1,20 @@ +module UU.Parsing( module UU.Parsing.Derived + , module UU.Parsing.Interface + , parseIO + ) where + +import UU.Parsing.Derived +import UU.Parsing.Interface + +parseIO :: (Eq s, Show s, Symbol s) => Parser s a -> [s] -> IO a +parseIO = parseIOMessage showMessage + where showMessage (Msg expecting position action) + = let pos = case position of + Nothing -> "at end of file" + Just s -> case action of + Insert _ -> "before " ++ show s + Delete t -> "at " ++ show t + in "\n?? Error : " ++ pos ++ + "\n?? Expecting : " ++ show expecting ++ + "\n?? Repaired by: " ++ show action ++ "\n" + diff --git a/src/UU/Parsing/CharParser.hs b/src/UU/Parsing/CharParser.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/CharParser.hs @@ -0,0 +1,53 @@ +module UU.Parsing.CharParser where + +import UU.Parsing.Interface +import UU.Scanner.Position + + +type CharParser = AnaParser Input Pair Char Pos + +instance Symbol Char where + symBefore = pred + symAfter = succ + deleteCost _ = 5 + +data Input = Input String !Pos + +instance InputState Input Char Pos where + splitStateE (Input inp pos) = + case inp of + ('\CR': xs) -> case xs of + ('\LF' : _ ) -> Left' '\CR' (Input xs pos) + _ -> Left' '\CR' (Input xs (newl pos)) + ('\LF': xs) -> Left' '\LF' (Input xs (newl pos)) +-- ('\n' : xs) -> Left' '\n' (Input xs (newl pos)) -- \n already captured above + ('\t' : xs) -> Left' '\t' (Input xs (tab pos)) + (x : xs) -> Left' x (Input xs (advc 1 pos)) + [] -> Right' (Input [] pos) + + splitState (Input inp pos) = + case inp of + ('\CR': xs) -> case xs of + ('\LF' : _ ) -> ('\CR', Input xs pos) + _ -> ('\CR', Input xs (newl pos)) + ('\LF': xs) -> ( '\LF', Input xs (newl pos)) +-- ('\n' : xs) -> ( '\n' , Input xs (newl pos)) -- \n already captured above + ('\t' : xs) -> ( '\t' , Input xs (tab pos)) + (x : xs) -> ( x , Input xs (advc 1 pos)) + + getPosition (Input inp pos) = pos + +parseString :: CharParser a + -> [Char] + -> Steps (Pair a (Pair Input ())) Char Pos +parseString p txt = parse p ((Input txt (initPos ""))) + +parseStringIO :: (Message Char Pos -> String) + -> CharParser a + -> [Char] + -> IO a +parseStringIO showM p txt = parseIOMessage showM p (Input txt (initPos "")) + +parseFile :: (Message Char Pos -> String) -> CharParser a -> [Char] -> IO a +parseFile showM p filename = do txt <- readFile filename + parseIOMessage showM p (Input txt (initPos filename)) diff --git a/src/UU/Parsing/Derived.hs b/src/UU/Parsing/Derived.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Derived.hs @@ -0,0 +1,213 @@ +module UU.Parsing.Derived where + +import UU.Parsing.Interface + +infixl 2 +infixl 4 <**>, , <+> +infixl 2 `opt` +infixl 5 <..> + + +-- ======================================================================================= +-- ===== CHECKING ======================================================================== +-- ======================================================================================= +-- | Checks if the parser accepts epsilon. +acceptsepsilon :: (IsParser p s) => p v -> Bool +acceptsepsilon p = case getzerop p of {Nothing -> False; _ -> True} + +mnz :: (IsParser p s) => p v -> t -> String -> t +mnz p v comb + = if( acceptsepsilon p) + then usererror ("The combinator <" ++ comb ++ "> from is called with a parser that accepts the empty string.\n" + ++ + "The library cannot handle the resulting left recursive formulation (which is ambiguous too).\n" + -- ++ + -- (case getfirsts p of + -- ESeq [] -> "There are no other alternatives for this parser" + -- d -> "The other alternatives of this parser may start with:\n"++ show d + ) --) + else v +-- ======================================================================================= +-- ===== START OF PRELUDE DEFINITIONS ========== ========================================= +-- ======================================================================================= + +-- | Parses the specified range, see also 'pRange'. +-- +-- Example: +-- +-- > pDig = 'a' <..> 'z' +(<..>) :: (IsParser p s) => s -> s -> p s +a <..> b = pRange a (Range a b) + +pExcept :: (IsParser p s, Symbol s, Ord s, Eq (SymbolR s)) => (s, s, s) -> [s] -> p s +pExcept (l,r,err) elems = let ranges = filter (/= EmptyR) (Range l r `except` elems) + in if null ranges then pFail + else foldr (<|>) pFail (map (pRange err) ranges) + + + +-- | Optionally recognize parser 'p'. +-- +-- If 'p' can be recognized, the return value of 'p' is used. Otherwise, +-- the value 'v' is used. Note that opt is greedy, if you do not want +-- this use @... <|> pSucceed v@ instead. Furthermore, 'p' should not +-- recognise the empty string. +opt :: (IsParser p s) => p a -> a -> p a +p `opt` v = mnz p (p <|> pLow v) "opt" + + + +-- ======================================================================================= +-- ===== Special sequential compositions ========================================= +-- ======================================================================================= +asList :: (IsParser p s) => Expecting s -> p v -> p v +asList exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)*"]) + +asList1 :: (IsParser p s) => Expecting s -> p v -> p v +asList1 exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)+"]) + +asOpt :: (IsParser p s) => Expecting s -> p v -> p v +asOpt exp = setfirsts (ESeq [EStr "( ", exp, EStr " ...)?"]) + +-- | Parses the sequence of 'pa' and 'pb', and combines them as a tuple. +(<+>) :: (IsParser p s) => p a -> p b -> p (a, b) +pa <+> pb = (,) <$> pa <*> pb + +-- | Suppose we have a parser a with two alternatives that both start +-- with recognizing a non-terminal p, then we will typically rewrite: +-- +-- > a = f <$> p <*> q +-- > <|> g <$> p <*> r +-- +-- into: +-- +-- > a = p <**> (f <$$> q <|> g <$$> r) +(<**>) :: (IsParser p s) => p a -> p (a -> b) -> p b +p <**> q = (\ x f -> f x) <$> p <*> q + +(<$$>) :: (IsParser p s) => (a -> b -> c) -> p b -> p (a -> c) +f <$$> p = pSucceed (flip f) <*> p + +() :: (IsParser p s) => p a -> p (a -> a) -> p a +p q = p <**> (q `opt` id) + +() :: (IsParser p s) => p v -> String -> p v +p str = setfirsts (EStr str) p + +-- | This can be used to parse 'x' surrounded by 'l' and 'r'. +-- +-- Example: +-- +-- > pParens = pPacked pOParen pCParen +pPacked :: (IsParser p s) => p a -> p b1 -> p b -> p b +pPacked l r x = l *> x <* r + +-- ======================================================================================= +-- ===== Iterating ps =============================================================== +-- ======================================================================================= +pFoldr_ng :: (IsParser p s) => (a -> a1 -> a1, a1) -> p a -> p a1 +pFoldr_ng alg@(op,e) p = mnz p (asList (getfirsts p) pfm) "pFoldr_ng" + where pfm = (op <$> p <*> pfm) <|> pSucceed e +pFoldr_gr :: (IsParser p s) => (a -> b -> b, b) -> p a -> p b +pFoldr_gr alg@(op,e) p = mnz p (asList (getfirsts p) pfm) "pFoldr_gr" + where pfm = (op <$> p <*> pfm) `opt` e +pFoldr :: (IsParser p s) =>(a -> b -> b, b) -> p a -> p b +pFoldr alg p = pFoldr_gr alg p + +pFoldr1_gr :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b +pFoldr1_gr alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr alg p) +pFoldr1_ng :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b +pFoldr1_ng alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng alg p) +pFoldr1 :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b +pFoldr1 alg p = pFoldr1_gr alg p + +pFoldrSep_gr :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b +pFoldrSep_gr alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg sepp) `opt` e )) "pFoldrSep_gr (both args)" + where sepp = sep *> p +pFoldrSep_ng :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b +pFoldrSep_ng alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg sepp) <|> pSucceed e)) "pFoldrSep_ng (both args)" + where sepp = sep *> p +pFoldrSep :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b +pFoldrSep alg sep p = pFoldrSep_gr alg sep p + +pFoldr1Sep_gr :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b +pFoldr1Sep_gr alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_gr (both arguments)" else pfm + where pfm = op <$> p <*> pFoldr_gr alg (sep *> p) +pFoldr1Sep_ng :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b +pFoldr1Sep_ng alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_ng (both arguments)" else pfm + where pfm = op <$> p <*> pFoldr_ng alg (sep *> p) +pFoldr1Sep :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b +pFoldr1Sep alg sep p = pFoldr1Sep_gr alg sep p + +list_alg :: (a -> [a] -> [a], [a1]) +list_alg = ((:), []) + +pList_gr :: (IsParser p s) => p a -> p [a] +pList_gr p = pFoldr_gr list_alg p +pList_ng :: (IsParser p s) => p a -> p [a] +pList_ng p = pFoldr_ng list_alg p +pList :: (IsParser p s) => p a -> p [a] +pList p = pList_gr p + +pList1_gr :: (IsParser p s) => p a -> p [a] +pList1_gr p = pFoldr1_gr list_alg p +pList1_ng :: (IsParser p s) => p a -> p [a] +pList1_ng p = pFoldr1_ng list_alg p +pList1 :: (IsParser p s) => p a -> p [a] +pList1 p = pList1_gr p + +pListSep_gr :: (IsParser p s) => p a1 -> p a -> p [a] +pListSep_gr s p = pFoldrSep_gr list_alg s p +pListSep_ng :: (IsParser p s) => p a1 -> p a -> p [a] +pListSep_ng s p = pFoldrSep_ng list_alg s p +pListSep :: (IsParser p s) => p a -> p a1 -> p [a1] +pListSep s p = pListSep_gr s p + +pList1Sep_gr :: (IsParser p s) => p a1 -> p a -> p [a] +pList1Sep_gr s p = pFoldr1Sep_gr list_alg s p +pList1Sep_ng :: (IsParser p s) => p a1 -> p a -> p [a] +pList1Sep_ng s p = pFoldr1Sep_ng list_alg s p +pList1Sep :: (IsParser p s) =>p a -> p a1 -> p [a1] +pList1Sep s p = pList1Sep_gr s p + +pChainr_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c +pChainr_gr op x = if acceptsepsilon op then mnz x r "pChainr_gr (both arguments)" else r + where r = x (flip <$> op <*> r) +pChainr_ng :: (IsParser p s) => p (a -> a -> a) -> p a -> p a +pChainr_ng op x = if acceptsepsilon op then mnz x r "pChainr_ng (both arguments)" else r + where r = x <**> ((flip <$> op <*> r) <|> pSucceed id) +pChainr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c +pChainr op x = pChainr_gr op x + +pChainl_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c +pChainl_gr op x = if acceptsepsilon op then mnz x r "pChainl_gr (both arguments)" else r + where + r = (f <$> x <*> pList_gr (flip <$> op <*> x) ) + f x [] = x + f x (func:rest) = f (func x) rest + +pChainl_ng :: (IsParser p s) => p (c -> c -> c) -> p c -> p c +pChainl_ng op x = if acceptsepsilon op then mnz x r "pChainl_ng (both arguments)" else r + where + r = (f <$> x <*> pList_ng (flip <$> op <*> x) ) + f x [] = x + f x (func:rest) = f (func x) rest +pChainl :: (IsParser p s) => p (c -> c -> c) -> p c -> p c +pChainl op x = pChainl_gr op x + +-- | Parses using any of the parsers in the list 'l'. +-- +-- Warning: 'l' may not be an empty list. +pAny :: (IsParser p s) =>(a -> p a1) -> [a] -> p a1 +pAny f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l) + +-- | Parses any of the symbols in 'l'. +pAnySym :: (IsParser p s) =>[s] -> p s +pAnySym l = pAny pSym l -- used to be called pAnySym + +pToks :: (IsParser p s) => [s] -> p [s] +pToks [] = pSucceed [] +pToks (a:as) = (:) <$> pSym a <*> pToks as + +pLocate :: (IsParser p s) => [[s]] -> p [s] +pLocate list = pAny pToks list diff --git a/src/UU/Parsing/Interface.hs b/src/UU/Parsing/Interface.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Interface.hs @@ -0,0 +1,199 @@ +{-# OPTIONS -fglasgow-exts #-} +module UU.Parsing.Interface + ( AnaParser, pWrap, pMap + , module UU.Parsing.MachineInterface + , module UU.Parsing.Interface + ) where + +import UU.Parsing.Machine +import UU.Parsing.MachineInterface +--import IOExts +import System.IO.Unsafe +import System.IO +-- ================================================================================== +-- ===== PRIORITIES ====================================================================== +-- ======================================================================================= +infixl 3 <|> +infixl 4 <*>, <$> +infixl 4 <$, <*, *> + + +-- ======================================================================================= +-- ===== ANAPARSER INSTANCES ============================================================= +-- ======================================================================================= +type Parser s = AnaParser [s] Pair s (Maybe s) +-- ======================================================================================= +-- ===== PARSER CLASSES ================================================================== +-- ======================================================================================= + +-- | The 'IsParser' class contains the base combinators with which +-- to write parsers. A minimal complete instance definition consists of +-- definitions for '(<*>)', '(<|>)', 'pSucceed', 'pLow', 'pFail', +-- 'pCostRange', 'pCostSym', 'getfirsts', 'setfirsts', and 'getzerop'. +class IsParser p s | p -> s where + -- | Sequential composition. Often used in combination with <$>. + -- The function returned by parsing the left-hand side is applied + -- to the value returned by parsing the right-hand side. + -- Note: Implementations of this combinator should lazily match on + -- and evaluate the right-hand side parser. The derived combinators + -- for list parsing will explode if they do not. + (<*>) :: p (a->b) -> p a -> p b + -- | Value ignoring versions of sequential composition. These ignore + -- either the value returned by the parser on the right-hand side or + -- the left-hand side, depending on the visual direction of the + -- combinator. + (<* ) :: p a -> p b -> p a + ( *>) :: p a -> p b -> p b + -- | Applies the function f to the result of p after parsing p. + (<$>) :: (a->b) -> p a -> p b + (<$ ) :: b -> p a -> p b + -- | Two variants of the parser for empty strings. 'pSucceed' parses the + -- empty string, and fully counts as an alternative parse. It returns the + -- value passed to it. + pSucceed :: a -> p a + -- | 'pLow' parses the empty string, but alternatives to pLow are always + -- preferred over 'pLow' parsing the empty string. + pLow :: a -> p a + f <$> p = pSucceed f <*> p + f <$ q = pSucceed f <* q + p <* q = pSucceed const <*> p <*> q + p *> q = pSucceed (flip const) <*> p <*> q + -- | Alternative combinator. Succeeds if either of the two arguments + -- succeed, and returns the result of the best success parse. + (<|>) :: p a -> p a -> p a + -- | This parser always fails, and never returns any value at all. + pFail :: p a + -- | Parses a range of symbols with an associated cost and the symbol to + -- insert if no symbol in the range is present. Returns the actual symbol + -- parsed. + pCostRange :: Int{-#L-} -> s -> SymbolR s -> p s + -- | Parses a symbol with an associated cost and the symbol to insert if + -- the symbol to parse isn't present. Returns either the symbol parsed or + -- the symbol inserted. + pCostSym :: Int{-#L-} -> s -> s -> p s + -- | Parses a symbol. Returns the symbol parsed. + pSym :: s -> p s + pRange :: s -> SymbolR s -> p s + -- | Get the firsts set from the parser, i.e. the symbols it expects. + getfirsts :: p v -> Expecting s + -- | Set the firsts set in the parser. + setfirsts :: Expecting s -> p v -> p v + pSym a = pCostSym 5{-#L-} a a + pRange = pCostRange 5{-#L-} + -- | 'getzerop' returns @Nothing@ if the parser can not parse the empty + -- string, and returns @Just p@ with @p@ a parser that parses the empty + -- string and returns the appropriate value. + getzerop :: p v -> Maybe (p v) + -- | 'getonep' returns @Nothing@ if the parser can only parse the empty + -- string, and returns @Just p@ with @p@ a parser that does not parse any + -- empty string. + getonep :: p v -> Maybe (p v) + + +-- | The fast 'AnaParser' instance of the 'IsParser' class. Note that this +-- requires a functioning 'Ord' for the symbol type s, as tokens are +-- often compared using the 'compare' function in 'Ord' rather than always +-- using '==' rom 'Eq'. The two do need to be consistent though, that is +-- for any two @x1@, @x2@ such that @x1 == x2@ you must have +-- @compare x1 x2 == EQ@. +instance (Ord s, Symbol s, InputState state s p, OutputState result) => IsParser (AnaParser state result s p) s where + (<*>) p q = anaSeq libDollar libSeq ($) p q + (<* ) p q = anaSeq libDollarL libSeqL const p q + ( *>) p q = anaSeq libDollarR libSeqR (flip const) p q + pSucceed = anaSucceed + pLow = anaLow + (<|>) = anaOr + pFail = anaFail + pCostRange = anaCostRange + pCostSym i ins sym = anaCostRange i ins (mk_range sym sym) + getfirsts = anaGetFirsts + setfirsts = anaSetFirsts + getzerop p = case zerop p of + Nothing -> Nothing + Just (b,e) -> Just p { pars = libSucceed `either` id $ e + , leng = Zero + , onep = noOneParser + } + getonep p = let tab = table (onep p) + in if null tab then Nothing else Just (mkParser (leng p) Nothing (onep p)) + +instance InputState [s] s (Maybe s) where + splitStateE [] = Right' [] + splitStateE (s:ss) = Left' s ss + splitState (s:ss) = ({-#L-} s, ss{-L#-}) + getPosition [] = Nothing + getPosition (s:ss) = Just s + + +instance OutputState Pair where + acceptR = Pair + nextR acc = \ f ~(Pair a r) -> acc (f a) r + +pCost :: (OutputState out, InputState inp sym pos, Symbol sym, Ord sym) + => Int -> AnaParser inp out sym pos () +pCost x = pMap f f' (pSucceed ()) + where f acc inp steps = (inp, Cost x (val (uncurry acc) steps)) + f' inp steps = (inp, Cost x steps) + +getInputState :: (InputState a c d, Symbol c, Ord c, OutputState b)=>AnaParser a b c d a +getInputState = pMap f g (pSucceed id) + where f acc inp steps = (inp, val (acc inp . snd) steps) + g = (,) + +handleEof input = case splitStateE input + of Left' s ss -> StRepair (deleteCost s) + (Msg (EStr "end of file") (getPosition input) + (Delete s) + ) + (handleEof ss) + Right' ss -> NoMoreSteps (Pair ss ()) + +parse :: (Symbol s, InputState inp s pos) + => AnaParser inp Pair s pos a + -> inp + -> Steps (Pair a (Pair inp ())) s pos +parse = parsebasic handleEof + + +parseIOMessage :: ( Symbol s, InputState inp s p) + => (Message s p -> String) + -> AnaParser inp Pair s p a + -> inp + -> IO a +parseIOMessage showMessage p inp + = do (Pair v final) <- evalStepsIO showMessage (parse p inp) + final `seq` return v -- in order to force the trailing error messages to be printed + +parseIOMessageN :: ( Symbol s, InputState inp s p) + => (Message s p -> String) + -> Int + -> AnaParser inp Pair s p a + -> inp + -> IO a +parseIOMessageN showMessage n p inp + = do (Pair v final) <- evalStepsIO' showMessage n (parse p inp) + final `seq` return v -- in order to force the trailing error messages to be printed + +data Pair a r = Pair a r + +evalStepsIO :: (Message s p -> String) + -> Steps b s p + -> IO b +evalStepsIO showMessage = evalStepsIO' showMessage (-1) + +evalStepsIO' :: (Message s p -> String) + -> Int + -> Steps b s p + -> IO b +evalStepsIO' showMessage n (steps :: Steps b s p) = eval n steps + where eval :: Int -> Steps a s p -> IO a + eval 0 steps = return (evalSteps steps) + eval n steps = case steps of + OkVal v rest -> do arg <- unsafeInterleaveIO (eval n rest) + return (v arg) + Ok rest -> eval n rest + Cost _ rest -> eval n rest + StRepair _ msg rest -> do hPutStr stderr (showMessage msg) + eval (n-1) rest + Best _ rest _ -> eval n rest + NoMoreSteps v -> return v diff --git a/src/UU/Parsing/Machine.hs b/src/UU/Parsing/Machine.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Machine.hs @@ -0,0 +1,481 @@ +module UU.Parsing.Machine where +import UU.Util.BinaryTrees +import UU.Parsing.MachineInterface + +pDynE v = anaDynE v +pDynL v = anaDynL v + +-- ========================================================================================== +-- ===== BASIC PARSER TYPE ================================================================= +-- ======================================================================================= + +newtype RealParser state s p a = P(forall r' r'' . (a -> r'' -> r') -> + (state -> Steps r'' s p) -> state -> Steps r' s p) + +newtype RealRecogn state s p = R(forall r . (state -> Steps r s p) -> state -> Steps r s p) + +newtype RealAccept state result s p a = A(forall r . (state -> Steps r s p) -> state -> Steps (result a r) s p) + +newtype ParsRec state result s p a = PR ( RealParser state s p a + , RealRecogn state s p + , RealAccept state result s p a + ) + +mkPR (P p, R r) = PR (P p, R r, A (p acceptR)) + +{-# INLINE unP #-} +{-# INLINE unR #-} +unP (P p) = p +unR (R p) = p + +parseRecbasic :: (inp -> Steps (out c d) sym pos) + -> ParsRec inp out sym pos a + -> inp + -> Steps (out a (out c d)) sym pos +parseRecbasic eof (PR ( P rp, rr, A ra)) inp = (ra eof inp) + +parsebasic :: (inp -> Steps (out c d) sym pos) + -> AnaParser inp out sym pos a + -> inp + -> Steps (out a (out c d)) sym pos +parsebasic eof (pp) inp + = parseRecbasic eof (pars pp) inp + +-- ======================================================================================= +-- ===== CORE PARSERS ==================================================================== +-- ======================================================================================= +libAccept :: (OutputState a, InputState b s p) => ParsRec b a s p s +libAccept = mkPR (P (\ acc k state -> + case splitState state of + ({-#L-} s, ss {-L#-}) -> OkVal (acc s) (k ss)) + ,R (\ k state -> + case splitState state of + ({-#L-} s, ss {-L#-}) -> Ok (k ss)) + ) +libInsert c sym firsts =mkPR( P (\acc k state -> let msg = Msg firsts + (getPosition state) + (Insert sym) + in StRepair c msg (val (acc sym) (k (insertSymbol sym (reportError msg state))))) + , R (\ k state -> let msg = Msg firsts + (getPosition state) + (Insert sym) + in StRepair c msg (k (insertSymbol sym (reportError msg state)))) + ) +{-# INLINE libSeq #-} +{-# INLINE libSeqL #-} +{-# INLINE libSeqR #-} +{-# INLINE libDollar #-} +{-# INLINE libDollarL #-} +{-# INLINE libDollarR #-} +{-# INLINE libSucceed #-} + +libSucceed v =mkPR( P (\ acc -> let accv = val (acc v) in {-# SCC "machine" #-} \ k state -> accv (k state)) + , R id + ) +libSeq (PR (P pp, R pr, _)) ~(PR (P qp, R qr, A qa)) =mkPR ( P (\ acc -> let p = pp (nextR acc) in {-# SCC "machine" #-} \k state -> p (qa k) state) + , R ( pr.qr) + ) +libDollar f (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> {-# SCC "machine" #-} qp (acc.f)) + , R qr + ) +libDollarL f (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> let accf = val (acc f) in {-# SCC "machine" #-} \ k state -> qr (\ inp -> accf ( k inp)) state) + , R qr + ) +libDollarR f (PR (P qp, R qr, _ )) = mkPR (P qp, R qr) + +libSeqL (PR (P pp, R pr, _ )) ~(PR (P qp, R qr , _ )) = mkPR ( P (\acc -> let p = pp acc in {-# SCC "machine" #-}\k state -> p (qr k) state) + , R (pr.qr) + ) +libSeqR (PR (P pp, R pr, _ )) ~(PR (P qp, R qr, _ )) = mkPR ( P (\acc -> let q = qp acc in {-# SCC "machine" #-}\k state -> pr (q k) state) + , R (pr.qr) + ) +libOr (PR (P pp, R pr,_ )) (PR (P qp, R qr, _ )) = mkPR ( P (\ acc -> let p = pp acc + q = qp acc + in {-# SCC "machine" #-} \ k state -> p k state `libBest` q k state) + , R (\ k state -> pr k state `libBest` qr k state) + ) +libFail :: OutputState a => ParsRec b a c p d +libFail = mkPR ( P (\ _ _ _ -> (usererror "calling an always failing parser" )) + , R (\ _ _ -> (usererror "calling an always failing recogniser")) + ) + + + +starting :: Steps a s p -> Expecting s +starting (StRepair _ m _ ) = getStart m +starting (Best l _ _ ) = starting l +starting _ = systemerror "UU.Parsing.Machine" "starting" + +{-# INLINE hasSuccess #-} +hasSuccess :: Steps a s p -> Bool +hasSuccess (StRepair _ _ _ ) = False +hasSuccess (Best _ _ _ ) = False +hasSuccess _ = True + +getStart (Msg st _ _) = st + +addToMessage (Msg exp pos act) more = Msg (more `eor` exp) pos act + + +addexpecting more (StRepair cost msg rest) = StRepair cost (addToMessage msg more) rest +addexpecting more (Best l sel r) = Best (addexpecting more l) + (addexpecting more sel) + (addexpecting more r) +addexpecting more (OkVal v rest ) = systemerror "UU_Parsing" ("addexpecting: OkVal") +addexpecting more (Ok _ ) = systemerror "UU_Parsing" ("addexpecting: Ok") +addexpecting more (Cost _ _ ) = systemerror "UU_Parsing" ("addexpecting: Cost") +addexpecting more _ = systemerror "UU_Parsing" ("addexpecting: other") + + +eor :: Ord a => Expecting a -> Expecting a -> Expecting a +eor p q = EOr (merge (tolist p) (tolist q)) + where merge x@(l:ll) y@(r:rr) = case compare l r of + LT -> l:( ll `merge` y) + GT -> r:( x `merge` rr) + EQ -> l:( ll `merge` rr) + merge l [] = l + merge [] r = r + tolist (EOr l) = l + tolist x = [x] + +-- ======================================================================================= +-- ===== SELECTING THE BEST RESULT ====================================================== +-- ======================================================================================= +-- INV: the first argument should be the shorter insertion +libBest :: Ord s => Steps b s p -> Steps b s p -> Steps b s p +libBest ls rs = libBest' ls rs id id + +libBest' :: Ord s => Steps b s p -> Steps c s p -> (b -> d) -> (c -> d) -> Steps d s p +libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w)) +libBest' (OkVal v ls) (Ok rs) lf rf = Ok (libBest' ls rs (lf.v) rf ) +libBest' (Ok ls) (OkVal w rs) lf rf = Ok (libBest' ls rs lf (rf.w)) +libBest' (Ok ls) (Ok rs) lf rf = Ok (libBest' ls rs lf rf ) +libBest' (OkVal v ls) _ lf rf = OkVal (lf.v) ls +libBest' _ (OkVal w rs) lf rf = OkVal (rf.w) rs +libBest' (Ok ls) _ lf rf = OkVal lf ls +libBest' _ (Ok rs) lf rf = OkVal rf rs +libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf + | i =={-#L-} j = Cost i (libBest' ls rs lf rf) + | i <{-#L-} j = Cost i (val lf ls) + | i >{-#L-} j = Cost j (val rf rs) +libBest' l@(NoMoreSteps v) _ lf rf = NoMoreSteps (lf v) +libBest' _ r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w) +libBest' l@(Cost i ls) _ lf rf = Cost i (val lf ls) +libBest' _ r@(Cost j rs) lf rf = Cost j (val rf rs) +libBest' l r lf rf = libCorrect l r lf rf + +lib_correct :: Ord s => (b -> c -> Steps d s p) -> (b -> c -> Steps d s p) -> b -> c -> Steps d s p +lib_correct p q = \k inp -> libCorrect (p k inp) ( q k inp) id id + +libCorrect :: Ord s => Steps a s p -> Steps c s p -> (a -> d) -> (c -> d) -> Steps d s p +libCorrect ls rs lf rf + = let (ToBeat _ choice) = traverse + (traverse (ToBeat 999{-#L-} (val lf newleft)) + (val lf, newleft, 0{-#L-}) 4{-#L-}) + (val rf, newright, 0{-#L-}) 4{-#L-} + newleft = addexpecting (starting rs) ls + newright = addexpecting (starting ls) rs + in Best (val lf newleft) + choice + (val rf newright) + +data ToBeat a = ToBeat Int{-#L-} a + +traverse :: ToBeat (Steps a s p) -> (Steps v s p -> Steps a s p, Steps v s p, Int{-L#-}) -> Int{-L#-} -> ToBeat (Steps a s p) +traverse b@(ToBeat bv br) (f, s, v) 0{-#L-} = {- trace ("comparing " ++ show bv ++ " with " ++ show v ++ "\n") $ -} + if bv <={-#L-} v + then b + else ToBeat v (f s) +traverse b@(ToBeat bv br) (f, Ok l, v) n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.Ok , l, v - n + 4) (n -{-#L-} 1{-#L-}) +traverse b@(ToBeat bv br) (f, OkVal w l, v) n = {- trace ("adding" ++ show n ++ "\n") $-} traverse b (f.OkVal w, l, v - n + 4) (n -{-#L-} 1{-#L-}) +traverse b@(ToBeat bv br) (f, Cost i l, v) n = if i +{-#L-} v >={-#L-} bv + then b + else traverse b (f.Cost i, l, i +{-#L-} v) n +traverse b@(ToBeat bv br) (f, Best l _ r, v) n = traverse (traverse b (f, l, v) n) (f, r, v) n +traverse b@(ToBeat bv br) (f, StRepair i msgs r, v) n = if i +{-#L-} v >={-#L-} bv then b + else traverse b (f.StRepair i msgs, r, i +{-#L-} v) (n -{-#L-} 1{-#L-}) +traverse b@(ToBeat bv br) (f, t@(NoMoreSteps _), v) n = if bv <={-#L-} v then b else ToBeat v (f t) +-- ======================================================================================= +-- ===== DESCRIPTORS ===================================================================== +-- ======================================================================================= +data AnaParser state result s p a + = AnaParser { pars :: ParsRec state result s p a + , leng :: Nat + , zerop :: Maybe (Bool, Either a (ParsRec state result s p a)) + , onep :: OneDescr state result s p a + } -- deriving Show +data OneDescr state result s p a + = OneDescr { firsts :: Expecting s + , table :: [(SymbolR s, TableEntry state result s p a)] + } -- deriving Show + +data TableEntry state result s p a = TableEntry (ParsRec state result s p a) (Expecting s -> ParsRec state result s p a) +-- ======================================================================================= +-- ===== ANALYSING COMBINATORS =========================================================== +-- ======================================================================================= +anaFail :: OutputState a => AnaParser b a c p d +anaFail = AnaParser { pars = libFail + , leng = Infinite + , zerop = Nothing + , onep = noOneParser + } +noOneParser = OneDescr (EOr []) [] + +pEmpty p zp = AnaParser { pars = p + , leng = Zero + , zerop = Just zp + , onep = noOneParser + } + +anaSucceed v = pEmpty (libSucceed v) (False, Left v) +anaLow v = pEmpty (libSucceed v) (True, Left v) +anaDynE p = pEmpty p (False, Right p) +anaDynL p = pEmpty p (True , Right p) +--anaDynN fi len range p = mkParser Nothing (OneDescr len fi [(range, p)]) + +anaOr ld@(AnaParser _ ll zl ol) rd@(AnaParser _ lr zr or) + = mkParser newlength newZeroDescr newOneDescr + where (newlength, maybeswap) = ll `nat_min` lr + newZeroDescr = case zl of {Nothing -> zr + ;_ -> case zr of {Nothing -> zl + ;_ -> usererror ("Two empty alternatives") + } } + newOneDescr = maybeswap orOneOneDescr ol or False + +{-# INLINE anaSeq #-} + +anaSeq libdollar libseq comb (AnaParser pl ll zl ol) ~rd@(AnaParser pr lr zr or) + = case zl of + Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr libdollar libseq comb + newOneDescr = let newOneOne = mapOnePars ( `libseq` pr) ol + newZeroOne = case zp of + Left f -> mapOnePars (f `libdollar` ) or + Right p -> mapOnePars (p `libseq` ) or + in orOneOneDescr newZeroOne newOneOne b -- left one is shortest + in mkParser lr newZeroDescr newOneDescr + _ -> AnaParser (pl `libseq` pr) (ll `nat_add` lr) Nothing (mapOnePars (`libseq` pr) ol) + +seqZeroZero Nothing _ _ _ _ = Nothing +seqZeroZero _ Nothing _ _ _ = Nothing +seqZeroZero (Just (llow, left)) (Just (rlow, right)) libdollar libseq comb + = Just ( llow || rlow + , case left of + Left lv -> case right of + Left rv -> Left (comb lv rv) + Right rp -> Right (lv `libdollar` rp) + Right lp -> case right of + Left rv -> Right (lp `libseq` libSucceed rv) + Right rp -> Right (lp `libseq` rp) + ) + +orOneOneDescr ~(OneDescr fl tl) ~(OneDescr fr tr) b + = let keystr = map fst tr + lefttab = if b then [r | r@(k,_) <- tl, not (k `elem` keystr)] else tl + in OneDescr (fl `eor` fr) (lefttab ++ tr) + +anaCostRange _ _ EmptyR = anaFail +anaCostRange ins_cost ins_sym range + = mkParser (Succ Zero) Nothing ( OneDescr (ESym range) [(range, TableEntry libAccept + (libInsert ins_cost ins_sym) + )]) + +--anaCostSym i ins sym = pCostRange i ins (Range sym sym) + +anaGetFirsts (AnaParser p l z od) = firsts od + +anaSetFirsts newexp (AnaParser _ l zd od) + = mkParser l zd (od{firsts = newexp }) + +-- ======================================================================================= +-- ===== UTILITIES ======================================================================== +-- ======================================================================================= +mapOnePars fp ~(OneDescr fi t) = OneDescr fi [ (k, TableEntry (fp p) (fp.corr)) + | (k, TableEntry p corr ) <- t + ] + +-- ======================================================================================= +-- ===== MKPARSER ======================================================================== +-- ======================================================================================= +mkParser length zd ~descr@(OneDescr firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers + = let parstab = foldr1 mergeTables [[(k, p)]| (k, TableEntry p _) <- tab] + mkactualparser getp + = let ptab = [(k, (getp pr) )| (k, pr) <- parstab] + find = case ptab of + [(s1, p1)] -> ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else Nothing ) + where r1 = symInRange s1 + [(s1, p1), (s2, p2)] -> ({-# SCC "Locating" #-} \ s -> if r1 s then Just p1 else + if r2 s then Just p2 else Nothing) + where r1 = symInRange s1 + r2 = symInRange s2 + [(s1, p1), (s2, p2), (s3, p3)] -> ({-# SCC "Locating" #-}\ s -> if r1 s then Just p1 else + if r2 s then Just p2 else + if r3 s then Just p3 else Nothing) + where r1 = symInRange s1 + r2 = symInRange s2 + r3 = symInRange s3 + _ -> lookupSym (tab2tree ptab) + zerop = getp (case zd of + Nothing -> libFail + Just (_, Left v) -> libSucceed v + Just (_, Right p) -> p + ) +-- SDS/AD 20050603: only the shortest alternative in possible corrections now is taken +-- insertsyms = foldr1 lib_correct [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ] + insertsyms = head [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ] + correct k inp + = case splitState inp of + ({-#L-} s, ss {-L#-}) -> let { msg = Msg firsts (getPosition inp) (Delete s) + ; newinp = deleteSymbol s (reportError msg ss) + } + in libCorrect (StRepair (deleteCost s) msg (result k newinp)) + (insertsyms k inp) id id + result = if null tab then zerop + else case zd of + Nothing ->({-# SCC "mkParser1" #-}\k inp -> + case splitStateE inp of + Left' s ss -> case find s of + Just p -> p k inp + Nothing -> correct k inp + Right' ss -> insertsyms k ss) + Just (True, _) ->({-# SCC "mkParser2" #-}\k inp -> + case splitStateE inp of + Left' s ss -> case find s of + Just p -> p k inp + Nothing -> let r = zerop k inp + in if hasSuccess r then r else libCorrect r (correct k inp) id id + Right' ss -> zerop k ss) + Just (False, _) ->({-# SCC "mkParser3" #-}\k inp -> + case splitStateE inp of + Left' s ss -> case find s of + Just p -> p k inp `libBest` zerop k inp + Nothing -> let r = zerop k inp + in if hasSuccess r then r else libCorrect r (correct k inp) id id + Right' ss -> zerop k ss) + in result + res = mkPR (P ( \ acc -> mkactualparser (\ (PR (P p, _ , _)) -> p acc)) + ,R ( mkactualparser (\ (PR (_ , R p, _)) -> p )) + ) + in AnaParser res length zd descr + +-- ======================================================================================= +-- ===== MINIMAL LENGTHS (lazily formulated) ============================================= +-- ======================================================================================= +data Nat = Zero + | Succ Nat + | Infinite + deriving (Eq, Show) + +nat_le Zero _ = True +nat_le _ Zero = False +nat_le Infinite _ = False +nat_le _ Infinite = True +nat_le (Succ l) (Succ r) = nat_le l r + +nat_min Infinite r = (r, flip) +nat_min l Infinite = (l, id) +nat_min Zero _ = (Zero, id) +nat_min _ Zero = (Zero, flip) +nat_min (Succ ll) (Succ rr) = let (v, fl) = ll `nat_min` rr in (Succ v, fl) + +nat_add Infinite _ = Infinite +nat_add Zero r = r +nat_add (Succ l) r = Succ (nat_add l r) +-- ======================================================================================= +-- ===== CHOICE STRUCTURES ============================================================= +-- ======================================================================================= +mergeTables l [] = l +mergeTables [] r = r +mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs) + = let ct'' = ct `libOr` ct' + in if cd then mergeTables rss lss + else (le,ct'') : mergeTables ls rs-- equals + +-- ======================================================================================= +-- ===== WRAPPING AND MAPPING ============================================================== +-- ======================================================================================= + +libMap :: OutputState result => + (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps r'' s p)) + -> (forall r . state -> Steps ( r) s p -> ( state, Steps r s p)) + -> ParsRec state result s p a -> ParsRec state result s p b +libMap f f' (PR (P p, R r, _)) = mkPR ( P(\acc -> let pp = p (,) + facc = f acc + in \ k instate -> let inresult = pp k outstate + (outstate, outresult) = facc instate inresult + in outresult + ) + , R(\ k instate -> let inresult = r k outstate + (outstate, outresult) = f' instate inresult + in outresult) + ) + +pMap :: OutputState result => + (forall r r'' . (b -> r -> r'') -> state -> Steps (a, r) s p -> ( state, Steps r'' s p)) + -> (forall r . state -> Steps ( r) s p -> ( state, Steps r s p)) + -> AnaParser state result s p a -> AnaParser state result s p b + +pMap f f' (AnaParser p l z o) = AnaParser (libMap f f' p) + l + (case z of + Nothing -> Nothing + Just (b, v) -> Just (b, case v of + Left w -> Right (libMap f f' (libSucceed w)) + Right pp -> Right (libMap f f' pp))) + (mapOnePars (libMap f f') o) + + +libWrap :: OutputState result => + (forall r r'' . (b -> r -> r'') + -> state + -> Steps (a, r) s p + -> (state -> Steps r s p) + -> (state, Steps r'' s p, state -> Steps r s p)) + -> (forall r . state + -> Steps r s p + -> (state -> Steps r s p) + -> (state, Steps r s p, state -> Steps r s p)) + -> ParsRec state result s p a -> ParsRec state result s p b +libWrap f f' (PR (P p, R r, _)) = mkPR ( P(\ acc -> let pp = p (,) + facc = f acc + in \ k instate -> let (stl, ar, str2rr) = facc instate rl k + rl = pp str2rr stl + in ar + ) + , R(\ k instate -> let (stl, ar, str2rr) = f' instate rl k + rl = r str2rr stl + in ar) + ) + +pWrap :: OutputState result + => (forall r r'' . (b -> r -> r'') + -> state + -> Steps (a, r) s p + -> (state -> Steps r s p) + -> (state, Steps r'' s p, state -> Steps r s p)) + -> (forall r . state + -> Steps r s p + -> (state -> Steps r s p) + -> (state, Steps r s p, state -> Steps r s p)) + -> AnaParser state result s p a -> AnaParser state result s p b + +pWrap f f' (AnaParser p l z o) = AnaParser (libWrap f f' p) + l + (case z of + Nothing -> Nothing + Just (b, v) -> Just (b, case v of + Left w -> Right (libWrap f f' (libSucceed w)) + Right pp -> Right (libWrap f f' pp))) + (mapOnePars (libWrap f f') o) + + + +-- ======================================================================================= +-- ===== BINARY SEARCH TREES ============================================================= +-- ======================================================================================= + +lookupSym :: Ord a => BinSearchTree (SymbolR a, b) -> a -> Maybe b +lookupSym = btFind symRS diff --git a/src/UU/Parsing/MachineInterface.hs b/src/UU/Parsing/MachineInterface.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/MachineInterface.hs @@ -0,0 +1,152 @@ +module UU.Parsing.MachineInterface where + +-- | The 'InputState' class contains the interface that the AnaParser +-- parsers expect for the input. A minimal complete instance definition +-- consists of 'splitStateE', 'splitState' and 'getPosition'. +class InputState state s pos | state -> s, state -> pos where + -- | Splits the state in a strict variant of 'Either', with 'Left'' if a symbol + -- can be split off and 'Right'' if none can + splitStateE :: state -> Either' state s + -- | Splits the state in the first symbol and the remaining state + splitState :: state -> ({-#L-} s, state {-L#-}) + -- | Gets the current position in the input + getPosition :: state -> pos + -- | Reports an error + reportError :: Message s pos -> state -> state + reportError _ = id + -- | Modify the state as the result of inserting a symbol 's' in the input. + -- The symbol that has already been considered as having been inserted + -- is passed. It should normally not be added to the state. + insertSymbol :: s -> state -> state + insertSymbol _ = id + -- | Modify the state as the result of deleting a symbol 's' from the input. + -- The symbol that has already been deleted from the input state is passed. + -- It should normally not be deleted from the state. + deleteSymbol :: s -> state -> state + deleteSymbol _ = id + {-# INLINE splitStateE #-} + {-# INLINE splitState #-} + {-# INLINE insertSymbol #-} + {-# INLINE deleteSymbol #-} + +class OutputState r where + acceptR :: v -> rest -> r v rest + nextR :: (a -> rest -> rest') -> (b -> a) -> (r b rest) -> rest' + {-# INLINE acceptR #-} + {-# INLINE nextR #-} + +class Symbol s where + deleteCost :: s -> Int{-#L-} + symBefore :: s -> s + symAfter :: s -> s + deleteCost b = 5{-#L-} + symBefore = error "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred" + symAfter = error "You should have made your token type an instance of the Class Symbol. eg by defining symAfter = succ" + +data Either' state s = Left' !s (state ) + | Right' (state ) + +-- ======================================================================================= +-- ===== STEPS =========================================================================== +-- ======================================================================================= +data Steps val s p + = forall a . OkVal (a -> val) (Steps a s p) + | Ok { rest :: Steps val s p} + | Cost {costing::Int{-#L-} , rest :: Steps val s p} + | StRepair {costing::Int{-#L-}, m :: !(Message s p) , rest :: Steps val s p} + | Best (Steps val s p) (Steps val s p) ( Steps val s p) + | NoMoreSteps val +data Action s = Insert s + | Delete s + | Other String + +val :: (a -> b) -> Steps a s p -> Steps b s p + +val f (OkVal a rest) = OkVal (f.a) rest +val f (Ok rest) = OkVal f rest +val f (Cost i rest) = Cost i (val f rest) +val f (StRepair c m r) = StRepair c m (val f r) +val f (Best l s r) = Best (val f l) (val f s) (val f r) +val f (NoMoreSteps v) = NoMoreSteps (f v) + +evalSteps :: Steps a s p -> a +evalSteps (OkVal v rest ) = v (evalSteps rest) +evalSteps (Ok rest ) = evalSteps rest +evalSteps (Cost _ rest ) = evalSteps rest +evalSteps (StRepair _ msg rest ) = evalSteps rest +evalSteps (Best _ rest _) = evalSteps rest +evalSteps (NoMoreSteps v ) = v + + +getMsgs :: Steps a s p -> [Message s p] +getMsgs (OkVal _ rest) = getMsgs rest +getMsgs (Ok rest) = getMsgs rest +getMsgs (Cost _ rest) = getMsgs rest +getMsgs (StRepair _ m rest) = m:getMsgs rest +getMsgs (Best _ m _) = getMsgs m +getMsgs (NoMoreSteps _ ) = [] + +data Message sym pos = Msg (Expecting sym) !pos (Action sym) +-- Msg (String, String, Expecting s) -- action, position, expecting +instance (Eq s, Show s) => Show (Expecting s) where + show (ESym s) = show s + show (EStr str) = str + show (EOr []) = "Nothing expected " + show (EOr [e]) = show e + show (EOr (e:ee)) = show e ++ " or " ++ show (EOr ee) + show (ESeq seq) = concat (map show seq) + +instance (Eq s, Show s, Show p) => Show (Message s p) where + show (Msg expecting position action) + = "\n?? Error : " ++ show position ++ + "\n?? Expecting : " ++ show expecting ++ + "\n?? Repaired by: " ++ show action ++"\n" + +instance Show s => Show (Action s) where + show (Insert s) = "inserting: " ++ show s + show (Delete s) = "deleting: " ++ show s + show (Other s) = s +data Expecting s = ESym (SymbolR s) + | EStr String + | EOr [Expecting s] + | ESeq [Expecting s] + deriving (Ord, Eq) +-- ======================================================================================= +-- ===== SYMBOLS and RANGES ============================================================== +-- ======================================================================================= + +data SymbolR s = Range !s !s | EmptyR deriving (Eq,Ord) + +instance (Eq s,Show s) => Show (SymbolR s) where + show EmptyR = "the empty range" + show (Range a b) = if a == b then show a else show a ++ ".." ++ show b + + +mk_range l r = if l > r then EmptyR else Range l r + +symInRange (Range l r) = if l == r then (l==) + else (\ s -> s >= l && s <= r) + +symRS (Range l r) + = if l == r then (compare l) + else (\ s -> if s < l then GT + else if s > r then LT + else EQ) + +range `except` elems + = foldr removeelem [range] elems + where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem] + EmptyR `minus` _ = [] + ran@(Range l r) `minus` elem = if symInRange ran elem + then [mk_range l (symBefore elem), mk_range (symAfter elem) r] + else [ran] +-- ======================================================================================= +-- ===== TRACING and ERRORS and MISC =================================================== +-- ======================================================================================= +usererror m = error ("Your grammar contains a problem:\n" ++ m) +systemerror modname m + = error ("I apologise: I made a mistake in my design. This should not have happened.\n" + ++ + " Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n") + + diff --git a/src/UU/Parsing/Merge.hs b/src/UU/Parsing/Merge.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Merge.hs @@ -0,0 +1,25 @@ +module UU.Parsing.Merge((<||>), pMerged, list_of) where + +import UU.Parsing + +-- ==== merging +-- e.g. chars_digs = cat3 `pMerged` (list_of pDig <||> list_of pL <||> list_of pU) +-- parsing "12abCD1aV" now returns "121abaCDV", so the sequence of +-- recognised elements is stored in three lists, which are then passed to cat3 + +(<||>) :: IsParser p s => (c,p (d -> d),e -> f -> g) -> (h,p (i -> i),g -> j -> k) -> ((c,h),p ((d,i) -> (d,i)),e -> (f,j) -> k) +(pe, pp, punp) <||> (qe, qp, qunp) + =( (pe, qe) + , (\f (pv, qv) -> (f pv, qv)) <$> pp + <|> + (\f (pv, qv) -> (pv, f qv)) <$> qp + , \f (x, y) -> qunp (punp f x) y + ) + +pMerged :: IsParser p s => c -> (d,p (d -> d),c -> d -> e) -> p e +sem `pMerged` (units, alts, unp) + = let pres = alts <*> pres `opt` units + in unp sem <$> pres + +list_of :: IsParser p s => p c -> ([d],p ([c] -> [c]),e -> e) +list_of p = ([], (:) <$> p, id) diff --git a/src/UU/Parsing/Offside.hs b/src/UU/Parsing/Offside.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Offside.hs @@ -0,0 +1,231 @@ +module UU.Parsing.Offside( parseOffside + , pBlock + , pBlock1 + , pOffside + , pOpen + , pClose + , pSeparator + , scanOffside + , OffsideSymbol(..) + , OffsideInput + , Stream + , OffsideParser(..) + ) where + +import UU.Parsing.Interface +import UU.Parsing.Machine +import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep) +import UU.Scanner.Position + +data OffsideSymbol s = + Symbol s + | SemiColon + | CloseBrace + | OpenBrace + deriving (Ord,Eq,Show) + + +scanOffside :: (InputState i s p, Position p, Eq s) + => s -> s -> s -> [s] -> i -> OffsideInput i s p +scanOffside mod open close triggers ts = start ts [] + where + isModule t = t == mod + isOpen t = t == open + isClose t = t == close + isTrigger t = t `elem` triggers + end ts = Off (getPosition ts) (End ts) + cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p + cons p s r = Off p (Cons s r) Nothing + start = case splitStateE ts of + Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (column (getPosition ts) ) + _ -> layoutL 0 + + -- L (:ts) (m:ms) = ; : (L ts (m:ms)) if m = n + -- = } : (L (:ts) ms) if n < m + -- L (:ts) ms = L ts ms + startlnL l n ts (m:ms) | m == n = cons (getPosition ts) SemiColon (layoutL (line (getPosition ts)) ts (m:ms)) + | n < m = cons (getPosition ts) CloseBrace (startlnL l n ts ms) + startlnL l n ts ms = layoutL (line (getPosition ts)) ts ms + -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n > m (Note 1) + -- L ({n}:ts) [] = { : (L ts [n]) if n > 0 (Note 1) + -- L ({n}:ts) ms = { : } : (L (:ts) ms) (Note 2) + implicitL l n ts (m:ms) | n > m = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms)) + implicitL l n ts [] | n > 0 = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n]) + implicitL l n ts ms = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms)) + layoutL ln ts ms | ln /= sln = startln (column pos) ts ms + | otherwise = sameln ts ms + + where sln = line pos + pos = getPosition ts + layout = layoutL ln + implicit = implicitL ln + startln = startlnL ln + -- If a let ,where ,do , or of keyword is not followed by the lexeme {, + -- the token {n} is inserted after the keyword, where nis the indentation of + -- the next lexeme if there is one, or 0 if the end of file has been reached. + aftertrigger ts ms = case splitStateE ts of + Left' t _ | isOpen t -> layout ts ms + | otherwise -> implicit (column(getPosition ts)) ts ms + Right' _ -> implicit 0 ts ms + + + -- L ( }:ts) (0:ms) = } : (L ts ms) (Note 3) + -- L ( }:ts) ms = parse-error (Note 3), matching of implicit/explicit braces is handled by parser + -- L ( {:ts) ms = {: (L ts (0:ms)) (Note 4) + -- L (t:ts) (m:ms) = }: (L (t:ts) ms) if m /= 0 and parse-error(t) (Note 5) + -- L (t:ts) ms = t : (L ts ms) + sameln tts ms = case splitStateE tts of + Left' t ts | isTrigger t -> cons pos (Symbol t) (aftertrigger ts ms) + | isClose t -> cons pos (Symbol t) + (case ms of + 0:ms -> layout ts ms + _ -> layout ts ms + ) + | isOpen t -> cons pos (Symbol t) (layout ts (0:ms)) + | otherwise -> let parseError = case ms of + m:ms | m /= 0 -> Just (layout tts ms) + _ -> Nothing + in Off pos (Cons (Symbol t) (layout ts ms)) parseError + Right' rest -> endofinput pos rest ms + where pos = getPosition tts + + -- L [] [] = [] + -- L [] (m:ms) = } : L [] ms if m /=0 (Note 6) + -- = L [] ms, if m == 0 (this is an error, the parser should yield a parse error, if this situation occurs) + endofinput pos rest [] = Off pos (End rest) Nothing + endofinput pos rest (m:ms) | m /= 0 = cons pos CloseBrace (endofinput pos rest ms) + | otherwise = endofinput pos rest ms + + +data Stream inp s p = Cons (OffsideSymbol s) (OffsideInput inp s p) + | End inp + +data OffsideInput inp s p = Off p (Stream inp s p) (Maybe (OffsideInput inp s p)) + +instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where + splitStateE inp@(Off p stream _) = case stream of + Cons s rest -> Left' s rest + _ -> Right' inp + splitState (Off _ stream _) = + case stream of + Cons s rest -> (s ,rest) + + getPosition (Off pos _ _ ) = pos + +instance Symbol s => Symbol (OffsideSymbol s) where + deleteCost s = case s of + Symbol s -> deleteCost s + SemiColon -> 5 + OpenBrace -> 5 + CloseBrace -> 5 + symBefore s = case s of + Symbol s -> Symbol (symBefore s) + SemiColon -> error "Symbol.symBefore SemiColon" + OpenBrace -> error "Symbol.symBeforeOpenBrace" + CloseBrace -> error "Symbol.symBefore CloseBrace" + symAfter s = case s of + Symbol s -> Symbol (symAfter s) + SemiColon -> error "Symbol.symAfter SemiColon" + OpenBrace -> error "Symbol.symAfter OpenBrace" + CloseBrace -> error "Symbol.symAfter CloseBrace" + +newtype OffsideParser i o s p a = OP (AnaParser (OffsideInput i s p) o (OffsideSymbol s) p a) + +instance (Symbol s, Ord s, InputState i s p, OutputState o) => IsParser (OffsideParser i o s p) s where + (<*>) = operator (<*>) + (<* ) = operator (<* ) + ( *>) = operator ( *>) + (<|>) = operator (<|>) + (<$>) = operatorr (<$>) + (<$ ) = operatorr (<$ ) + pSucceed = OP . pSucceed + pLow = OP . pLow + pFail = OP pFail + pCostRange c s (Range l r) = OP (getSymbol <$> pCostRange c (Symbol s) (Range (Symbol l)(Symbol r))) + pCostSym c s t = OP (getSymbol <$> pCostSym c (Symbol s) (Symbol t)) + pSym s = OP (getSymbol <$> pSym (Symbol s)) + pRange s (Range l r) = OP (getSymbol <$> pRange (Symbol s) (Range (Symbol l)(Symbol r))) + getfirsts (OP p) = removeSymbol (getfirsts p) + setfirsts exp (OP p) = OP (setfirsts (addSymbol exp) p) + getzerop (OP p) = fmap OP (getzerop p) + getonep (OP p) = fmap OP (getonep p) + +removeSymbol exp = case exp of + ESym (Range (Symbol l) (Symbol r)) -> ESym (Range l r) + ESym _ -> EOr [] + EStr txt -> EStr txt + EOr exps -> EOr (map removeSymbol exps) + ESeq exps -> ESeq (map removeSymbol exps) + +addSymbol exp = case exp of + ESym (Range l r) -> ESym (Range (Symbol l) (Symbol r)) + EStr txt -> EStr txt + EOr exps -> EOr (map addSymbol exps) + ESeq exps -> ESeq (map addSymbol exps) + +getSymbol (Symbol s) = s + +operator f (OP p) (OP q) = OP (f p q) +operatorr f g (OP p) = OP (f g p) + +pSeparator :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) + => OffsideParser i o s p () +pSeparator = OP (() <$ pCostSym 5 SemiColon SemiColon) + +pClose, pOpen :: (OutputState o, InputState i s p, Position p, Symbol s, Ord s) + => OffsideParser i o s p () + + +pClose = OP (pWrap f g ( () <$ pSym CloseBrace) ) + where g state steps1 k = (state,ar,k) + where ar = case state of + Off _ _ (Just state') -> let steps2 = k state' + in if not (hasSuccess steps1) && hasSuccess steps2 then steps2 else steps1 + _ -> steps1 + + f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps) k + in (stl ,val (acc ()) ar , str2rr ) + +pOpen = OP (() <$ pSym OpenBrace) + +pOffside :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p a + -> OffsideParser i o s p a + -> OffsideParser i o s p a +pOffside open close bodyE bodyI = + open *> bodyE <* close + <|> pOpen *> bodyI <* pClose + +pBlock :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p [a] +pBlock open sep close p = pOffside open close explicit implicit + where elem = (:) <$> p `opt` id + sep' = () <$ sep + elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) + +pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p [a] +pBlock1 open sep close p = pOffside open close explicit implicit + where sep' = () <$ sep + elems s = pList s *> pList1Sep (pList1 s) p <* pList s + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) + +parseOffside :: (Symbol s, InputState i s p, Position p) + => OffsideParser i Pair s p a + -> OffsideInput i s p + -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p +parseOffside (OP p) inp = val fromPair (parse p inp) + where fromPair (Pair x (Pair y _)) = (x,y) diff --git a/src/UU/Parsing/Perms.hs b/src/UU/Parsing/Perms.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/Perms.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -fglasgow-exts #-} +module UU.Parsing.Perms(Perms(), pPerms, pPermsSep, succeedPerms, (~*~), (~$~)) where + +import UU.Parsing +import Maybe + +-- ======================================================================================= +-- ===== PERMUTATIONS ================================================================ +-- ======================================================================================= + +newtype Perms p a = Perms (Maybe (p a), [Br p a]) +data Br p a = forall b. Br (Perms p (b -> a)) (p b) + +instance IsParser p s => Functor (Perms p) where + fmap f (Perms (mb, bs)) = Perms (fmap (f<$>) mb, map (fmap f) bs) + +instance IsParser p s => Functor (Br p) where + fmap f (Br perm p) = Br (fmap (f.) perm) p + +(~*~) :: IsParser p s => Perms p (a -> b) -> p a -> Perms p b +perms ~*~ p = perms `add` (getzerop p, getonep p) + +(~$~) :: IsParser p s => (a -> b) -> p a -> Perms p b +f ~$~ p = succeedPerms f ~*~ p + +succeedPerms :: IsParser p s => a -> Perms p a +succeedPerms x = Perms (Just (pLow x), []) + +add :: IsParser p s => Perms p (a -> b) -> (Maybe (p a),Maybe (p a)) -> Perms p b +add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb) + = let changing :: IsParser p s => (a -> b) -> Perms p a -> Perms p b + f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np]) + in Perms + ( do { f <- eb2a + ; x <- eb + ; return (f <*> x) + } + , (case nb of + Nothing -> id + Just pb -> (Br b2a pb:) + )[ Br ((flip `changing` c) `add` bp) d | Br c d <- nb2a] + ) + +pPerms :: IsParser p s => Perms p a -> p a +pPerms (Perms (empty,nonempty)) + = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp + | Br pp p <- nonempty + ] + +pPermsSep :: IsParser p s => p x -> Perms p a -> p a +pPermsSep (sep :: p z) perm = p2p (pSucceed ()) perm + where p2p :: IsParser p s => p x -> Perms p a -> p a + p2p fsep (Perms (mbempty, nonempties)) = + let empty = fromMaybe pFail mbempty + pars (Br t p) = flip ($) <$ fsep <*> p <*> p2p sep t + in foldr (<|>) empty (map pars nonempties) + p2p_sep = p2p sep diff --git a/src/UU/Parsing/StateParser.hs b/src/UU/Parsing/StateParser.hs new file mode 100644 --- /dev/null +++ b/src/UU/Parsing/StateParser.hs @@ -0,0 +1,35 @@ +module UU.Parsing.StateParser(StateParser(..)) where +import UU.Parsing.MachineInterface +import UU.Parsing.Machine(AnaParser, ParsRec(..),RealParser(..),RealRecogn(..), mkPR, anaDynE) + +instance (InputState inp s p) => InputState (inp, state) s p where + splitStateE (inp, st) = case splitStateE inp of + Left' x xs -> Left' x (xs, st) + Right' xs -> Right' (xs, st) + splitState (inp, st) = case splitState inp of + (x,xs) -> (x, (xs, st)) + getPosition (inp, _) = getPosition inp + +class StateParser p st | p -> st where + change :: (st -> st) -> p st -- return the old state + set :: st -> p st + set x = change (const x) + get :: p st + get = change id + +fconst x y = y + +instance (InputState inp s p ,OutputState out) => + StateParser (AnaParser (inp, st) out s p) st where + get = anaDynE (mkPR (rp,rr)) + where f addRes k state = (val (addRes (snd state)) (k state)) + rp = P f + rr = R (f fconst ) + + change ch = anaDynE (mkPR (rp,rr)) + where f addRes k state = case state of (inp, st) -> val (addRes st) (k (inp, ch st)) + rp = P f + rr = R (f fconst) + +newtype Errors s p = Errors [[Message s p]] + diff --git a/src/UU/Pretty.hs b/src/UU/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/UU/Pretty.hs @@ -0,0 +1,5 @@ +module UU.Pretty(module UU.Pretty.Basic, module UU.Pretty.Ext ) where + +import UU.Pretty.Basic +import UU.Pretty.Ext + diff --git a/src/UU/Pretty/Basic.hs b/src/UU/Pretty/Basic.hs new file mode 100644 --- /dev/null +++ b/src/UU/Pretty/Basic.hs @@ -0,0 +1,798 @@ +-- $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Basic.hs,v 1.2 2003/02/26 11:18:27 uust Exp $ +-- $Name: $ (version name) + +module UU.Pretty.Basic ( PP (..), PP_Doc, PP_Exp + -- Single layout combinators + , empty, text, indent, (>|<), (>-<), fill , fillblock + -- Multiple layout combinators + , (>//<), join, par, (>>$<) + , eindent, (>>|<<), (>>-<<), (>>//<<), ejoin, (>>$<<) + -- Displaying the result + , render, renderAll, disp + -- Additional generated combinators + , c2e, element_h1, eelement_h1, vcenter, invisible + -- Additional derived combinators + , fpar, spar + ) where + +{- Pretty-printers and pretty-printing combinators. Version 2.0d + Authors: S. Doaitse Swierstra and Pablo R. Azero + Date: July, 1999 + -} + +-- ................................................................... +-- ..... Interface definition ........................................ + +infixr 3 >|< , >>|<< +infixr 2 >-< , >>-<< +infixr 1 >//<, >>//<< +infixr 0 >>$<, >>$<< + +-- ------------------------------------------------------------------- +-- PP class ---------------------------------------------------------- + +newtype PP_Doc = PPDoc T_PPS + +class Show a => PP a where + pp :: a -> PP_Doc + pp = text . show + + ppList :: [a] -> PP_Doc + ppList as = if null as + then empty + else foldr (>|<) empty . map pp $ as + +instance PP PP_Doc where + pp = id + +instance PP Char where + pp c = text [c] + ppList = text + +instance PP a => PP [a] where + pp = ppList + +instance Show PP_Doc where + show p = disp p 200 "" + +-- ------------------------------------------------------------------- +-- Single layout combinators ----------------------------------------- + +empty :: PP_Doc +empty = PPDoc sem_PPS_Empty + +text :: String -> PP_Doc +text = PPDoc . sem_PPS_Text + +indent :: PP a => Int -> a -> PP_Doc +indent i fs = PPDoc (sem_PPS_Indent i nfs) + where (PPDoc nfs) = pp fs + +(>|<) :: (PP a, PP b) => a -> b -> PP_Doc +l >|< r = PPDoc (sem_PPS_Beside ppl ppr) + where (PPDoc ppl) = pp l + (PPDoc ppr) = pp r + +(>-<) :: (PP a, PP b) => a -> b -> PP_Doc +u >-< l = PPDoc (sem_PPS_Above ppu ppl) + where (PPDoc ppu) = pp u + (PPDoc ppl) = pp l + +fill :: PP a => [a] -> PP_Doc +fill = PPDoc . sem_PPS_Fill . foldr fill_alg sem_FillList_Nil + where fill_alg f + = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp) + +fillblock :: PP a => Int -> [a] -> PP_Doc +fillblock i = PPDoc . sem_PPS_FillBlock i . foldr fill_alg sem_FillList_Nil + where fill_alg f + = sem_FillList_Cons (case (pp f) of (PPDoc ppp) -> ppp) + +-- ------------------------------------------------------------------- +-- Multiple layout combinators --------------------------------------- + +(>//<) :: (PP a, PP b) => a -> b -> PP_Doc +a >//< b = PPDoc (sem_PPS_Dup ppa ppb) + where (PPDoc ppa) = pp a + (PPDoc ppb) = pp b + +join :: PP_Doc -> PP_Doc +join (PPDoc d) = PPDoc . sem_PPS_Join $ d + +newtype PP_Exp = PPExp T_PPC + +eindent :: Int -> PP_Exp -> PP_Exp +eindent i (PPExp ppc) = PPExp (sem_PPC_Indent i ppc) + +(>>|<<), (>>-<<), (>>//<<) :: PP_Exp -> PP_Exp -> PP_Exp +(PPExp l) >>|<< (PPExp r) = PPExp (sem_PPC_Beside l r) +(PPExp u) >>-<< (PPExp l) = PPExp (sem_PPC_Above u l) +(PPExp a) >>//<< (PPExp b) = PPExp (sem_PPC_Dup a b) + +ejoin :: PP_Exp -> PP_Exp +ejoin (PPExp dc) = PPExp . sem_PPC_Join $ dc + +par :: PP_Exp +par = PPExp sem_PPC_Par + +(>>$<) :: PP a => PP_Exp -> [a] -> PP_Doc +(PPExp e) >>$< pl = PPDoc . sem_PPS_Apply e . foldr ppslist sem_PPSArgs_Nil $ pl + where ppslist p = sem_PPSArgs_Cons (case (pp p) of (PPDoc ppp) -> ppp) + +(>>$<<) :: PP_Exp -> [PP_Exp] -> PP_Exp +(PPExp e) >>$<< pl = PPExp . sem_PPC_Apply e . foldr ppclist sem_PPCArgs_Nil $ pl + where ppclist (PPExp p) = sem_PPCArgs_Cons p + +-- ------------------------------------------------------------------- +-- Displaying the result --------------------------------------------- + +render, renderAll :: PP_Doc -> Int -> IO () +render (PPDoc fs) = putStr . sem_Root_Best fs +renderAll (PPDoc fs) = putStr . sem_Root_All fs + +disp :: PP_Doc -> Int -> ShowS +disp (PPDoc fs) = sem_Disp_Disp fs + +-- ------------------------------------------------------------------- +-- Additional generated combinators ---------------------------------- + +c2e :: PP a => a -> PP_Exp +c2e s = let (PPDoc s') = pp s in PPExp . sem_PPC_Pps $ s' + +element_h1 :: PP_Doc -> PP_Doc +element_h1 = \(PPDoc fs) -> PPDoc (sem_PPS_Filt fs) + +eelement_h1 :: PP_Exp -> PP_Exp +eelement_h1 (PPExp pe) = PPExp . sem_PPC_Filt $ pe + +vcenter :: PP a => [ a ] -> PP_Doc +vcenter = PPDoc . sem_PPS_Center . foldr center_alg sem_CenterList_Nil + where center_alg f = sem_CenterList_Cons (case (pp f) of (PPDoc pf) -> pf) + +invisible :: PP_Doc -> PP_Doc +invisible (PPDoc a) = PPDoc . sem_PPS_Inv $ a + +-- ------------------------------------------------------------------- +-- Additional derived combinators ------------------------------------ + +fpar, spar :: PP_Exp +fpar = plift first par +spar = plift second par + +first fs = case fs of + (TFormats fa _ ea _) -> (AFormat fa, ea ) + (AFormat fa) -> (AFormat fa, False) +second fs = case fs of + (TFormats _ fb _ eb) -> (AFormat fb, eb ) + (AFormat fb) -> (AFormat fb, False) + +-- Utilities + +lift :: (T_Formats -> T_Formats) -> PP_Doc -> PP_Doc +lift f (PPDoc p) = PPDoc . sem_LiftS_Lift p $ f + +--elift :: (T_Formats -> T_Formats) -> T_PPC -> T_PPC +elift f (PPExp e) = PPExp . sem_LiftC_Lift e $ f + +--plift :: (a -> b) -> T_PPC -> T_PPC +plift f (PPExp e) = PPExp . sem_LiftC_Pair e $ f + +-- ................................................................... +-- ..... Basic machinery ............................................. + +type Formats = [Format] + +{- Pretty-printer combinators with global page width -} + +type T_PW = Int +type T_PLL = Int +type T_PH = Int +-- Width Width last line +data T_Frame = F T_PW T_PLL + deriving Eq + +instance Ord T_Frame where + max x@(F w _) y@(F w' _) + | w > w' = x + | otherwise = y + +empty_fmts ::Formats +empty_fmts = [] + +text_fmts :: String -> Formats +text_fmts s = [ s2fmt s ] + +indent_fmts :: T_Frame -> Int -> Formats -> Formats +indent_fmts (F pw _) i = map (indent_fmt i) + . dropWhile (notFits (pw - i)) +notFits delta e = total_w e > delta + +beside_fmts :: T_Frame -> Formats -> Formats -> Formats +beside_fmts (F pw _) left right + = mergel [ map (l `beside_fmt`) + . dropWhile (tooWide pw l) + $ right + | l <- left + ] +tooWide pw x y + = (total_w x `max` (last_w x + total_w y)) > pw + +above_fmts :: Formats -> Formats -> Formats +above_fmts [] ls = [] +above_fmts us [] = [] +above_fmts up@(upper:ru) low@(lower:rl) + | utw >= ltw = firstelem : above_fmts ru low + | utw < ltw = firstelem : above_fmts up rl + where utw = total_w upper + ltw = total_w lower + firstelem = upper `above_fmt` lower + +{- Pretty-printing with error correction -} + +error_indent :: Int -> Formats -> Formats +error_indent i = map (indent_fmt i) + +error_beside :: Formats -> Formats -> Formats +error_beside left right = mergel [ map (l `beside_fmt`) right + | l <- left + ] + +-- ------------------------------------------------------------------- +-- Formatting one layout --------------------------------------------- + +data Format = Elem { height :: T_PH + , last_w :: T_PLL + , total_w :: T_PW + , txtstr :: Int -> String -> String + } + +instance Eq Format where + x == y = height x == height y + && total_w x == total_w y + && last_w x == last_w y + +instance Ord Format where + x < y = height x < height y + || ( height x == height y + && total_w x < total_w y ) + +s2fmt :: String -> Format +s2fmt s = Elem 1 l l (\_ -> (s++)) + where l = length s + +indent_fmt :: Int -> Format -> Format +indent_fmt i (Elem dh dl dw dt) + = Elem dh (i + dl) (i + dw) (\n -> ((sp i) ++) . dt (i + n)) + +above_fmt, beside_fmt :: Format -> Format -> Format +(Elem uh ul uw ut) `above_fmt` (Elem lh ll lw lt) + = Elem (uh + lh) ll (uw `max` lw) + (make_ts_above ut lt) + where make_ts_above ut lt = \n -> let nl_skip = (('\n':sp n)++) + in ut n . nl_skip . lt n +(Elem lh ll lw lt) `beside_fmt` (Elem rh rl rw rt) + = Elem (lh + rh - 1) (ll + rl) + (lw `max` (ll + rw)) (\n -> lt n . rt (ll + n)) + +-- ------------------------------------------------------------------- +-- Display the layout found ------------------------------------------ + +best fs = if null fs then "" else (txtstr . head $ fs) 0 "" +allf = concatMap (\fmt -> (txtstr fmt) 0 "\n\n") +dispf fs = if null fs then id else (txtstr . head $ fs) 0 + +-- ------------------------------------------------------------------- +-- Utility functions ------------------------------------------------- + +merge [] ys = ys +merge xs [] = xs +merge xl@(x:xs) yl@(y:ys) + | x == y = x : merge xs ys + | x < y = x : merge xs yl + | otherwise = y : merge xl ys + +spaces = ' ':spaces +sp n = if n >= 0 then take n spaces else "" + +mergel :: Ord a => [[a]] -> [a] +mergel = foldr merge [] + +-- ................................................................... +-- ..... Generated code from Pretty.ag ............................... + +narrow_frame i (F s l) = F (s - i) (l - i) +narrow_ll i (F s l) = F s (l - i) + +type T_Mins = [ (T_PW, T_PLL, T_PH) ] + +set_var_apply cond va vb = if cond then va else vb + +type T_Reqs = [ T_Frame ] + +type T_Fmts = [ T_Formats ] +type T_Errs = [ T_Error ] + +beside_height lh rh + = lh + rh - if (lh == 0 || rh == 0) then 0 else 1 + +cons_height pPh acth avail + | acth == 0 = if pPh > 0 then 1 else 0 + | otherwise = acth + if avail then 0 else 1 + +type T_Error = Bool + +data T_Formats = AFormat Formats + | TFormats Formats Formats T_Error T_Error + +afmt_txt = AFormat . text_fmts + +set_fmts_empty = AFormat empty_fmts + +set_fmts_text string minw error + = afmt_txt string + --(if error then (asts minw) else string) + +set_fmts_indent int fmts pw minw frame error + | int < 0 = afmt_txt "" + -- int > pw = afmt_txt . asts $ minw + | error = set_fmts_indent' error_indent + | otherwise = set_fmts_indent' (indent_fmts frame) + where set_fmts_indent' fmt_fc + = case fmts of + AFormat fs -> AFormat (fmt_fc int fs) + TFormats as bs ae be + -> TFormats (fmt_fc int as) + (fmt_fc int bs) ae be + +set_fmts_beside ls rs lh rh frame err + = set_fmts_ab ls rs set_fmts_beside' "" + where set_fmts_beside' as bs + = set_ab (lh == 0) (rh == 0) as bs + (if err then error_beside + else beside_fmts frame) + +set_fmts_above us ls uh lh + = set_fmts_ab us ls set_fmts_above' "" + where set_fmts_above' as bs = set_ab (uh == 0) (lh == 0) as bs above_fmts + +set_ab aempty bempty as bs fmt_fc + = if aempty {- left operand empty? -} + then bs + else if bempty {- right operand empty? -} + then as + else fmt_fc as bs + +set_fmts_ab fs gs fmt_fc etxt + = case fs of + AFormat ffmts -> case gs of + AFormat gfmts -> ( AFormat (fmt_fc ffmts gfmts), False ) + TFormats as bs ae be + -> ( TFormats (fmt_fc ffmts as) + (fmt_fc ffmts bs) ae be + , False ) + TFormats as bs ae be + -> case gs of + AFormat gfmts -> ( TFormats (fmt_fc as gfmts) + (fmt_fc bs gfmts) ae be + , False ) + otherwise -> ( afmt_txt etxt, True ) + +sem_fmts_dup afs bfs ae be minw + = {-if (ae && be) + then afmt_txt . asts $ minw + else-} + let get_fmts fs + = case fs of + AFormat as -> as + TFormats _ _ _ _ -> text_fmts "" + afmts = get_fmts afs + bfmts = get_fmts bfs + in TFormats afmts bfmts ae be + +set_fmts_join (TFormats as bs ae be) err + = ( AFormat $ if be + then (if null as then bs else as) + else if ae + then (if null bs then as else bs) + else merge as bs + , False + ) +set_fmts_join fs@(AFormat _) err + = if err then (fs, err) + else (afmt_txt "", True) + +set_fmts_apply True a _ = a +set_fmts_apply False _ b = b + +set_fmts_fillblock int fmts + | int < 0 = afmt_txt "" + | otherwise = AFormat fmts + +set_error_msg numpars len + = "" +{- +asts 0 = "" +asts 1 = "*" +asts s = '<' : replicate (s-2) '*' ++ ">" +-} +sem_fmts_cdup afs bfs ae be an bn minw em + = if an /= bn then afmt_txt em + else sem_fmts_dup afs bfs ae be minw + +set_error_msg' apars bpars + = "" + +set_fmts_filllist ifmts nfmts ih nh frame avail + = case nfmts of + AFormat ns -> if ih == 0 {- left operand empty? -} + then (ns, False) + else if nh == 0 {- right operand empty? -} + then (ifmts, False) + else if nh <= 1 + then ( choose_ab (beside_fmts frame) ifmts ns, False ) + else ( choose_ab error_beside + ifmts (text_fmts "") + , True ) + otherwise -> ( set_fmts_filllist' . text_fmts $ "" + , True ) + where set_fmts_filllist' fs + = set_ab (ih == 0) (nh == 0) fs ifmts (choose_ab error_beside) + choose_ab bsd_fc = if avail then bsd_fc else above_fmts + +set_fmts_render pw fs + = if pw < 0 + then text_fmts "" + else case fs of + AFormat fmts -> fmts + otherwise -> text_fmts "" + +type T_Function = T_Formats -> T_Formats + +set_fmts_filt (AFormat fs ) minw + = {-if null height1 then ( afmt_txt . asts $ minw , True ) + else-} ( AFormat height1 , False ) + where height1 = takeWhile ((<=1).height) fs +set_fmts_filt _ _ + = ( afmt_txt $ "", True ) + +set_fmts_inv fs + = case fs of + AFormat fmts -> AFormat . set_inv $ fmts + TFormats as bs ae be -> TFormats (set_inv as) (set_inv bs) ae be + where set_inv = (:[]) . (Elem 1 0 0) . txtstr . head + +type T_SynPPS = ( T_Formats, T_Error, T_PH, T_PLL, T_PW ) + +vapp fmts spaces pPS frame + = sem_PPS_Above (\frame -> fmts) (sem_PPS_Indent spaces pPS) frame + +---------------------- PPS ------------------------- +-- semantic domains +type T_PPS = T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW) +-- funcs +sem_PPS_Empty :: T_PPS +sem_PPS_Empty lhs_frame = ( (set_fmts_empty), False, 0, (0), (0) ) +sem_PPS_Text ::String -> T_PPS +sem_PPS_Text string lhs_frame + = let{ minw = (length string) + ; error = (minw > pw) + ; f@(F pw _ ) = (lhs_frame) + }in ( (set_fmts_text string minw error), error, (1), (minw), minw ) +sem_PPS_Indent ::Int -> T_PPS -> T_PPS +sem_PPS_Indent int pPS lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (narrow_frame int lhs_frame) + ; minw = (int + pPS_minw) + ; f@(F pw _ ) = (lhs_frame) + }in ( (set_fmts_indent int pPS_fmts pw minw lhs_frame pPS_error) + , (or [int < 0, int > pw, pPS_error]) + , pPS_maxh + , (int + pPS_minll) + , (minw) + ) +sem_PPS_Beside :: T_PPS -> T_PPS -> T_PPS +sem_PPS_Beside left right lhs_frame + = let{ ( left_fmts, left_error, left_maxh, left_minll, left_minw ) = left (narrow_ll right_minw lhs_frame) + ; ( right_fmts, right_error, right_maxh, right_minll, right_minw ) = right (narrow_frame left_minll lhs_frame) + ; error = (left_error || right_error) + ; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error) + }in ( (bfmts) + , (error || berror) + , (beside_height left_maxh right_maxh) + , (left_minll + right_minll) + , (left_minw `max` (left_minll + right_minw)) + ) +sem_PPS_Above :: T_PPS -> T_PPS -> T_PPS +sem_PPS_Above upper lower lhs_frame + = let{ ( upper_fmts, upper_error, upper_maxh, upper_minll, upper_minw ) = upper lhs_frame + ; ( lower_fmts, lower_error, lower_maxh, lower_minll, lower_minw ) = lower lhs_frame + ; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh) + }in ( (afmts) + , (or [lower_error, upper_error, aerror]) + , upper_maxh + lower_maxh + , (lower_minll) + , (upper_minw `max` lower_minw) + ) +sem_PPS_Dup :: T_PPS -> T_PPS -> T_PPS +sem_PPS_Dup opta optb lhs_frame + = let{ ( opta_fmts, opta_error, opta_maxh, opta_minll, opta_minw ) = opta lhs_frame + ; ( optb_fmts, optb_error, optb_maxh, optb_minll, optb_minw ) = optb lhs_frame + ; minw = (opta_minw `min` optb_minw) + ; error = (opta_error && optb_error) + }in ( (sem_fmts_dup opta_fmts optb_fmts opta_error optb_error minw) + , (error) + , (opta_maxh `max` optb_maxh) + , (opta_minll `min` optb_minll) + , (minw) + ) +sem_PPS_Join :: T_PPS -> T_PPS +sem_PPS_Join pPS lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame + ; fe@(jfmts,jerror) = (set_fmts_join pPS_fmts pPS_error) + }in ( (jfmts), (pPS_error || jerror), pPS_maxh, pPS_minll, pPS_minw ) +sem_PPS_Apply :: T_PPC -> T_PPSArgs -> T_PPS +sem_PPS_Apply pPC pPSArgs lhs_frame + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC (pPSArgs_error) (pPSArgs_fmts) lhs_frame (pPSArgs_mins) + ; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs pPC_reqs + ; error = (set_var_apply error_cond True pPC_error) + ; error_cond = (pPC_numpars /= pPSArgs_len) + ; lem = (length error_msg) + ; error_msg = (set_error_msg pPC_numpars pPSArgs_len) + }in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts) + , (error) + , (set_var_apply error_cond 1 pPC_maxh) + , (set_var_apply error_cond lem pPC_minll) + , (set_var_apply error_cond lem pPC_minw) + ) +sem_PPS_Fill :: T_FillList -> T_PPS +sem_PPS_Fill fillList lhs_frame + = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) + = fillList (empty_fmts) (False) (0) (0) (0) (F w w) (w) + ; f@(F w _ ) = (lhs_frame) + }in ( (AFormat fillList_fmts), fillList_error, fillList_maxh, fillList_minll, fillList_minw ) +sem_PPS_FillBlock ::Int -> T_FillList -> T_PPS +sem_PPS_FillBlock int fillList lhs_frame + = let{ ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) + = fillList (empty_fmts) (False) (0) (0) (0) (f_frame) (f_width) + ; f@(F w _ ) = (lhs_frame) + ; f_width = (if int > w then w else int) + ; f_frame = (if int > w then lhs_frame else (F int int)) + ; error = (or [int < 0, fillList_error]) + }in ( (set_fmts_fillblock int fillList_fmts), (error), fillList_maxh, fillList_minll, fillList_minw ) +sem_PPS_Filt :: T_PPS -> T_PPS +sem_PPS_Filt pPS lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame + ; ef@(fmts,error) = (set_fmts_filt pPS_fmts pPS_minw) + }in ( (fmts), (error || pPS_error), pPS_maxh, pPS_minll, pPS_minw ) +sem_PPS_Inv :: T_PPS -> T_PPS +sem_PPS_Inv pPS lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F maxBound maxBound) + }in ( (set_fmts_inv pPS_fmts), (False), (1), (0), (0) ) +sem_PPS_Center :: T_CenterList -> T_PPS +sem_PPS_Center centerList lhs_frame + = let{ ( centerList_maxw, centerList_fmts ) = centerList (centerList_maxw) (sem_PPS_Empty lhs_frame) lhs_frame + ; clf@(fmts,error,maxh,minll,minw) = (centerList_fmts) + }in ( (fmts), (error), (maxh), (minll), (minw) ) +---------------------- PPC ------------------------- +-- semantic domains +type T_PPC = T_Errs -> T_Fmts -> T_Frame -> T_Mins -> + (T_Formats,T_Error,T_PH,T_Reqs,T_PLL + ,T_PW,Int) +-- funcs +sem_PPC_Indent ::Int -> T_PPC -> T_PPC +sem_PPC_Indent int pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC lhs_fillerrs lhs_fillfmts (narrow_frame int lhs_frame) lhs_fillmins + ; minw = (int + pPC_minw) + ; f@(F pw _ ) = (lhs_frame) + }in ( (set_fmts_indent int pPC_fmts pw minw lhs_frame pPC_error) + , (or [int < 0, int > pw, pPC_error]) + , pPC_maxh + , pPC_reqs + , (int + pPC_minll) + , (minw) + , pPC_numpars + ) +sem_PPC_Beside :: T_PPC -> T_PPC -> T_PPC +sem_PPC_Beside left right lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( left_fmts, left_error, left_maxh, left_reqs, left_minll, left_minw, left_numpars ) + = left (les) (lfs) (narrow_ll right_minw lhs_frame) (lim) + ; ( right_fmts, right_error, right_maxh, right_reqs, right_minll, right_minw, right_numpars ) + = right (res) (rfs) (narrow_frame left_minll lhs_frame) (rim) + ; i@(lim,rim) = (splitAt left_numpars lhs_fillmins) + ; e@(les,res) = (splitAt left_numpars lhs_fillerrs) + ; m@(lfs,rfs) = (splitAt left_numpars lhs_fillfmts) + ; error = (left_error || right_error) + ; fe@(bfmts,berror) = (set_fmts_beside left_fmts right_fmts left_maxh right_maxh lhs_frame error) + }in ( (bfmts) + , (error || berror) + , (beside_height left_maxh right_maxh) + , left_reqs ++ right_reqs + , (left_minll + right_minll) + , (left_minw `max` (left_minll + right_minw)) + , left_numpars + right_numpars + ) +sem_PPC_Above :: T_PPC -> T_PPC -> T_PPC +sem_PPC_Above upper lower lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( upper_fmts, upper_error, upper_maxh, upper_reqs, upper_minll, upper_minw, upper_numpars ) + = upper (ues) (ufs) lhs_frame (uim) + ; ( lower_fmts, lower_error, lower_maxh, lower_reqs, lower_minll, lower_minw, lower_numpars ) + = lower (les) (lfs) lhs_frame (lim) + ; i@(uim,lim) = (splitAt upper_numpars lhs_fillmins) + ; e@(ues,les) = (splitAt upper_numpars lhs_fillerrs) + ; m@(ufs,lfs) = (splitAt upper_numpars lhs_fillfmts) + ; fe@(afmts,aerror) = (set_fmts_above upper_fmts lower_fmts upper_maxh lower_maxh) + }in ( (afmts) + , (or [lower_error, upper_error, aerror]) + , (upper_maxh + lower_maxh) + , upper_reqs ++ lower_reqs + , lower_minll + , (upper_minw `max` lower_minw) + , upper_numpars + lower_numpars + ) +sem_PPC_Dup :: T_PPC -> T_PPC -> T_PPC +sem_PPC_Dup opta optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( opta_fmts, opta_error, opta_maxh, opta_reqs, opta_minll, opta_minw, opta_numpars ) + = opta lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + ; ( optb_fmts, optb_error, optb_maxh, optb_reqs, optb_minll, optb_minw, optb_numpars ) + = optb lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + ; minw = (opta_minw `min` optb_minw) + ; error = (or [opta_numpars /= optb_numpars, opta_error && optb_error]) + ; error_msg = (set_error_msg' opta_numpars optb_numpars) + }in ( (sem_fmts_cdup opta_fmts optb_fmts opta_error optb_error opta_numpars optb_numpars minw error_msg) + , (error) + , (opta_maxh `max` optb_maxh) + , (zipWith max opta_reqs optb_reqs) + , (opta_minll `min` optb_minll) + , (minw) + , (opta_numpars) + ) +sem_PPC_Join :: T_PPC -> T_PPC +sem_PPC_Join pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + ; fe@(jfmts,jerror) = (set_fmts_join pPC_fmts pPC_error) + }in ( (jfmts), (pPC_error || jerror), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) +sem_PPC_Par :: T_PPC +sem_PPC_Par lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ m@(minw,minll,maxh) = (head lhs_fillmins) + ; error = (head lhs_fillerrs) + ; fmts = (head lhs_fillfmts) + }in ( fmts, error, maxh, ([lhs_frame]), minll, minw, 1 ) +sem_PPC_Apply :: T_PPC -> T_PPCArgs -> T_PPC +sem_PPC_Apply pPC pPCArgs lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC (pPCArgs_error) (pPCArgs_fmts) (lhs_frame) (pPCArgs_ofillmins) + ; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len ) + = pPCArgs (lhs_fillerrs) (lhs_fillfmts) (pPC_reqs) (lhs_fillmins) + ; error = (set_var_apply error_cond True pPC_error) + ; error_cond = (pPC_numpars /= pPCArgs_len) + ; lem = (length error_msg) + ; error_msg = (set_error_msg pPC_numpars pPCArgs_len) + }in ( (set_fmts_apply error_cond (AFormat . text_fmts $ error_msg) pPC_fmts) + , (error) + , (set_var_apply error_cond 1 pPC_maxh) + , (pPCArgs_reqs) + , (set_var_apply error_cond lem pPC_minll) + , (set_var_apply error_cond lem pPC_minw) + , (pPCArgs_numpars) + ) +sem_PPC_Pps :: T_PPS -> T_PPC +sem_PPC_Pps pPS lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame + }in ( pPS_fmts, pPS_error, pPS_maxh, ([]), pPS_minll, pPS_minw, (0) ) +sem_PPC_Filt :: T_PPC -> T_PPC +sem_PPC_Filt pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + ; ef@(fmts,error) = (set_fmts_filt pPC_fmts pPC_minw) + }in ( (fmts), (error || pPC_error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) +---------------------- PPSArgs ------------------------- +-- semantic domains +type T_PPSArgs = T_Reqs ->(T_Errs,T_Fmts,T_Mins,Int) +-- funcs +sem_PPSArgs_Nil :: T_PPSArgs +sem_PPSArgs_Nil lhs_reqs = ( ([]), ([]), ([]), (0) ) +sem_PPSArgs_Cons :: T_PPS -> T_PPSArgs -> T_PPSArgs +sem_PPSArgs_Cons pPS pPSArgs lhs_reqs + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (head lhs_reqs) + ; ( pPSArgs_error, pPSArgs_fmts, pPSArgs_mins, pPSArgs_len ) = pPSArgs (tail lhs_reqs) + }in ( (pPS_error:pPSArgs_error), (pPS_fmts:pPSArgs_fmts), ((pPS_minw ,pPS_minll, pPS_maxh):pPSArgs_mins), (pPSArgs_len + 1) ) +---------------------- PPCArgs ------------------------- +-- semantic domains +type T_PPCArgs = T_Errs -> T_Fmts -> T_Reqs -> T_Mins ->(T_Errs,T_Fmts,T_Reqs,T_Mins,Int,Int) +-- funcs +sem_PPCArgs_Nil :: T_PPCArgs +sem_PPCArgs_Nil lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins = ( ([]), ([]), [], ([]), 0, (0) ) +sem_PPCArgs_Cons :: T_PPC -> T_PPCArgs -> T_PPCArgs +sem_PPCArgs_Cons pPC pPCArgs lhs_ifillerrs lhs_ifillfmts lhs_ireqs lhs_ifillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) = pPC (pef) (pff) (head lhs_ireqs) (pim) + ; ( pPCArgs_error, pPCArgs_fmts, pPCArgs_reqs, pPCArgs_ofillmins, pPCArgs_numpars, pPCArgs_len ) + = pPCArgs (lef) (lff) (tail lhs_ireqs) (lim) + ; i@(pim,lim) = (splitAt pPC_numpars lhs_ifillmins) + ; e@(pef,lef) = (splitAt pPC_numpars lhs_ifillerrs) + ; m@(pff,lff) = (splitAt pPC_numpars lhs_ifillfmts) + }in ( (pPC_error:pPCArgs_error) + , (pPC_fmts:pPCArgs_fmts) + , pPC_reqs ++ pPCArgs_reqs + , ((pPC_minw ,pPC_minll,pPC_maxh):pPCArgs_ofillmins) + , pPC_numpars + pPCArgs_numpars + , (pPCArgs_len + 1) + ) +---------------------- FillList ------------------------- +-- semantic domains +type T_FillList = Formats -> T_Error -> T_PH -> T_PW -> T_PLL -> T_Frame -> T_PW ->(Formats,T_Error,T_PH,T_PW,T_PLL) +-- funcs +sem_FillList_Nil :: T_FillList +sem_FillList_Nil lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw + = ( lhs_fmts, lhs_error, lhs_maxh, lhs_minw, lhs_minll ) +sem_FillList_Cons :: T_PPS -> T_FillList -> T_FillList +sem_FillList_Cons pPS fillList lhs_fmts lhs_error lhs_maxh lhs_minw lhs_minll lhs_frame lhs_pw + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame) + ; ( fillList_fmts, fillList_error, fillList_maxh, fillList_minw, fillList_minll ) + = fillList (ffmts) + (lhs_error || ferror) + (cons_height pPS_maxh lhs_maxh avail) + (if (not avail) || (lhs_minw == lhs_pw) then lhs_pw else lhs_minll) + (if ferror then lhs_pw + 1 else if avail then newll else pPS_minw) + lhs_frame + lhs_pw + ; avail = (lhs_pw - newll >= 0) + ; newll = (lhs_minll + pPS_minw) + ; fe@(ffmts,ferror) = (set_fmts_filllist lhs_fmts pPS_fmts lhs_maxh pPS_maxh lhs_frame avail) + }in ( fillList_fmts, (fillList_error || pPS_error), fillList_maxh, fillList_minw, fillList_minll ) +---------------------- Root ------------------------- +-- semantic domains +type T_Root = T_PW ->String +-- funcs +sem_Root_Best :: T_PPS -> T_Root +sem_Root_Best pPS lhs_pw + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) + }in (best . set_fmts_render lhs_pw $ pPS_fmts) +sem_Root_All :: T_PPS -> T_Root +sem_Root_All pPS lhs_pw + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) + }in (allf . set_fmts_render lhs_pw $ pPS_fmts) +---------------------- Disp ------------------------- +-- semantic domains +type T_Disp = T_PW ->ShowS +-- funcs +sem_Disp_Disp :: T_PPS -> T_Disp +sem_Disp_Disp pPS lhs_pw + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (F lhs_pw lhs_pw) + }in (dispf . set_fmts_render lhs_pw $ pPS_fmts) +---------------------- LiftS ------------------------- +-- semantic domains +type T_LiftS = T_Function -> T_Frame ->(T_Formats,T_Error,T_PH,T_PLL,T_PW) +-- funcs +sem_LiftS_Lift :: T_PPS -> T_LiftS +sem_LiftS_Lift pPS lhs_f lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS lhs_frame + }in ( (lhs_f pPS_fmts), pPS_error, pPS_maxh, pPS_minll, pPS_minw ) +---------------------- LiftC ------------------------- +-- funcs +sem_LiftC_Lift pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + }in ( (lhs_f pPC_fmts), pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) +sem_LiftC_Pair pPC lhs_f lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + = let{ ( pPC_fmts, pPC_error, pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) + = pPC lhs_fillerrs lhs_fillfmts lhs_frame lhs_fillmins + ; fe@(fmts,error) = (lhs_f pPC_fmts) + }in ( (fmts), (pPC_error || error), pPC_maxh, pPC_reqs, pPC_minll, pPC_minw, pPC_numpars ) +---------------------- CenterList ------------------------- +-- semantic domains +type T_CenterList = Int -> T_SynPPS -> T_Frame ->(Int,T_SynPPS) +-- funcs +sem_CenterList_Nil :: T_CenterList +sem_CenterList_Nil lhs_maxw lhs_fmts lhs_frame = ( (0), lhs_fmts ) +sem_CenterList_Cons :: T_PPS -> T_CenterList -> T_CenterList +sem_CenterList_Cons pPS centerList lhs_maxw lhs_fmts lhs_frame + = let{ ( pPS_fmts, pPS_error, pPS_maxh, pPS_minll, pPS_minw ) = pPS (lhs_frame) + ; ( centerList_maxw, centerList_fmts ) = centerList lhs_maxw (vapp lhs_fmts spaces pPS lhs_frame) lhs_frame + ; spaces = ((lhs_maxw - pPS_minw) `div` 2) + }in ( (pPS_minw `max` centerList_maxw), centerList_fmts ) diff --git a/src/UU/Pretty/Ext.hs b/src/UU/Pretty/Ext.hs new file mode 100644 --- /dev/null +++ b/src/UU/Pretty/Ext.hs @@ -0,0 +1,190 @@ +-- $Header: /data/cvs-rep/uust/lib/pretty/UU/Pretty/Ext.hs,v 1.1 2002/11/13 16:05:20 uust Exp $ +-- $Name: $ (version name) + +module UU.Pretty.Ext ( -- Derived from single and multiple + (>^<), (>>^<<), (>#<), (>>#<<), wide_text + , vlist, hlist, hlist_sp, list_h1, hlist_h1 + , (>|<<), (>-<<), (>>|<), (>>-<), pp_es + -- Displaying the result + , vdisp + -- Printing brackets + , pp_wrap, pp_quotes, pp_doubleQuotes + , pp_parens, pp_brackets, pp_braces + -- Printing structures + , hv, hv_sp, pp_block, pp_ite + , pp_list, pp_slist, pp_parens_list + ) where + +{- Derived pretty-printing combinators. Version 2.0c + Authors: S. Doaitse Swierstra and Pablo R. Azero + Date: July, 1999 + -} + +import UU.Pretty.Basic + +infixr 3 >#<, >>#<<, >>|<, >|<< +infixr 2 >>-<, >-<< +infixr 1 >^<, >>^<< + +-- ------------------------------------------------------------------- +-- PP instances for often used simple data types --------------------- + +instance PP Int where + pp = text . show + +instance PP Float where + pp = text . show + +-- ------------------------------------------------------------------- +-- Derived from single and multiple ---------------------------------- + +(>^<), (>#<) :: (PP a, PP b) => a -> b -> PP_Doc +a >^< b = join (a >//< b) +l >#< r = l >|< " " >|< r + +pp_es string = if null string then empty else pp string + +wide_text t s | ls > t = text s + | otherwise = text . (if t >= 0 then take t else take 0) $ (s ++ spaces) + where ls = length s + spaces = repeat ' ' + +hlist, vlist, hlist_sp :: PP a => [a] -> PP_Doc +vlist = foldr (>-<) empty +hlist = foldr (>|<) empty +hlist_sp = foldr (>#<) empty + +list_h1 :: [PP_Doc] -> [PP_Doc] +list_h1 = map element_h1 + +hlist_h1 = foldr1 (>|<) . list_h1 + +(>>^<<), (>>#<<) :: PP_Exp -> PP_Exp -> PP_Exp +a >>^<< b = ejoin (a >>//<< b) +l >>#<< r = l >>|<< (" " >|<< r) + +(>|<<), (>-<<) :: PP a => a -> PP_Exp -> PP_Exp +l >|<< r = c2e l >>|<< r +u >-<< l = c2e u >>-<< l + +(>>|<), (>>-<) :: PP a => PP_Exp -> a -> PP_Exp +l >>|< r = l >>|<< c2e r +u >>-< l = u >>-<< c2e l + +-- ------------------------------------------------------------------- +-- Displaying the result --------------------------------------------- + +vdisp :: Int -> [PP_Doc] -> ShowS +vdisp pw = foldr (\f fs -> disp f pw . ("\n"++) . fs) id + +-- ------------------------------------------------------------------- +-- Printing brackets ------------------------------------------------- + +pp_wrap :: PP a => a -> a -> PP_Doc -> PP_Doc +pp_wrap op cl p = op >|< (p >|< cl) + +pp_quotes = pp_wrap '`' '\'' +pp_doubleQuotes = pp_wrap '"' '"' +pp_parens = pp_wrap '(' ')' +pp_brackets = pp_wrap '[' ']' +pp_braces = pp_wrap '{' '}' + +-- ------------------------------------------------------------------- +-- Printing structures + +-- hv: display a list of elements either horizontally or vertically, +-- 2 possible layouts: horizonal or vertical + +hv :: PP a => [a] -> PP_Doc +hv = join . foldr onehv (empty >//< empty) . map pp + where onehv p ps = eelement_h1 par >>|<< fpar + >>//<< par >>-<< spar + >>$< [p, ps] + +-- hv_sp: same as hv but inserts spaces between the elements +-- 2 possible layouts: horizonal or vertical + +hv_sp :: PP a => [a] -> PP_Doc +hv_sp l | null l = empty + | otherwise = lhv_sp . map pp $ l + +lhv_sp fs@(f:fss) = hs >>^<< vs >>$< fs + where (hs, vs) = foldr paralg (par, par) fss + paralg = \_ (nhs,nvs) -> (eelement_h1 par >>#<< nhs, par >>-<< nvs) + +-- pp_block: printing of block structures with open, close and separator +-- keywords +-- 2 possible layouts: horizonal or vertical + +--pp_block :: String -> String -> String -> [PP_Doc] -> PP_Doc +pp_block okw ckw sep fs + | null fs = hv [open, close] + | otherwise = join + ( eelement_h1 par >>|<< fpar + >>//<< par >>-<< spar + >>$< [open >|< (indent (startcolumn-lk) . head $ fs), hvopts] + ) + where lk = length okw + lsep = length sep + startcolumn = (lk `max` lsep) + hvopts = foldr hvoptalg dclose (tail fs) + hvoptalg p ps + = ( par >>|<< eelement_h1 par >>|<< fpar + >>//<< par >>|<< eindent (startcolumn - lsep) par >>-<< spar + ) >>$< [pp_es sep, p, ps] + dclose = eindent (startcolumn-lk) par >>//<< par >>$< [close] + open = pp_es okw + close = pp_es ckw + +-- pp_ite: printing an if-then-else-fi statement +-- three possible layouts: horizonal, vertical or mixed + +--pp_ite :: (PP a, PP b, PP c, PP d) +-- => a -> b -> c -> d -> PP_Doc -> PP_Doc -> PP_Doc -> PP_Doc +pp_ite kw_if kw_then kw_else kw_fi c t e + = ( eelement_h1 ( par >>|<< par >>|<< par >>|<< par ) + >>^<< ( ( ( par >>|<< par >>^<< par >>-<< par ) + >>$<< [par, par >>-<< par] + ) + >>-<< par + ) + ) >>$< [ kw_if >|< c + , kw_then >|< t + , kw_else >|< e + , pp kw_fi + ] + +-- pp_slist: printing a list of elements in a "mini page", needs open, close and +-- separator keywords and a "mini page" width +-- one possible layout: depends on the page width given, when it reaches the end +-- of the page it continues on the next line +-- restrictions: only simple elements allowed (no pp_slists or flexible layouts +-- in the list [PP_Doc]) + +pp_slist :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc +pp_slist pw ol cl sep fl + | null fl = hv [open, close] + | otherwise = eelement_h1 (par >>|<< par) >>^<< (par >>-<< par) + >>$< [nes, close] + where nes = fillblock pw (open: ne: map (pp_es sep >|<) (tail fl)) + ne = (replicate (if ws == 0 then 0 else ws - 1) ' ') + >|< (head fl) + ws = length sep + open = pp_es ol + close = pp_es cl + +-- pp_list: printing a list of elements in a "mini page", needs open, close and +-- separator keywords and a "mini page" width +-- one possible layout: depends on the page width given, when it reaches the end +-- of the page it continues on the next line + +pp_list :: Int -> String -> String -> String -> [PP_Doc] -> PP_Doc +pp_list pw ol cl _ [] = pp_es (ol ++ cl) +pp_list pw ol cl sep (f:fs) + = fillblock pw (pp ol: (pp f): (map (pp_es sep >|<) fs) ++ [ pp cl ]) + +-- pp_parens_list: idem pp_list, with parenthesis and comma separator + +pp_parens_list :: Int -> [PP_Doc] -> PP_Doc +pp_parens_list mpw = pp_list mpw "(" ")" ", " + diff --git a/src/UU/Scanner.hs b/src/UU/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner.hs @@ -0,0 +1,18 @@ +module UU.Scanner + ( module UU.Scanner.Scanner + , module UU.Scanner.Token + , module UU.Scanner.TokenParser + , module UU.Scanner.Position + ) + where + +import UU.Scanner.Scanner +import UU.Scanner.Token +import UU.Scanner.TokenParser +import UU.Scanner.Position + +-- instances +import UU.Scanner.TokenShow() +import UU.Scanner.GenTokenOrd() +import UU.Scanner.GenTokenSymbol() + diff --git a/src/UU/Scanner/GenToken.hs b/src/UU/Scanner/GenToken.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/GenToken.hs @@ -0,0 +1,12 @@ +module UU.Scanner.GenToken where + +import UU.Scanner.Position(Pos) + +data GenToken key tp val = Reserved !key !Pos + | ValToken !tp val !Pos + +position :: GenToken k t v -> Pos +position tok = case tok of + Reserved _ p -> p + ValToken _ _ p -> p + diff --git a/src/UU/Scanner/GenTokenOrd.hs b/src/UU/Scanner/GenTokenOrd.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/GenTokenOrd.hs @@ -0,0 +1,15 @@ +module UU.Scanner.GenTokenOrd() where + +import UU.Scanner.GenToken(GenToken(..)) + +instance (Eq key, Eq tp) => Eq (GenToken key tp val) where + Reserved x _ == Reserved y _ = x == y + ValToken tx _ _ == ValToken ty _ _ = tx == ty + _ == _ = False + +instance (Ord key, Ord tp) => Ord (GenToken key tp val) where + compare (Reserved x _) (Reserved y _) = compare x y + compare (Reserved _ _) _ = LT + compare (ValToken tx _ _) (ValToken ty _ _) = compare tx ty + compare _ _ = GT + diff --git a/src/UU/Scanner/GenTokenParser.hs b/src/UU/Scanner/GenTokenParser.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/GenTokenParser.hs @@ -0,0 +1,54 @@ +module UU.Scanner.GenTokenParser where + +import UU.Parsing.Interface(IsParser(pCostSym, pSym, (<$>))) +import UU.Scanner.GenToken(GenToken(..)) +import UU.Scanner.Position(Pos, noPos) + + +pCostReserved' :: IsParser p (GenToken key tp val) + => Int -> key -> p (GenToken key tp val) +pCostReserved' c key = let tok = Reserved key noPos + in pCostSym c tok tok + +pReserved' :: IsParser p (GenToken key tp val) + => key -> p (GenToken key tp val) +pReserved' key = let tok = Reserved key noPos + in pSym tok + +pCostValToken' :: IsParser p (GenToken key tp val) + => Int -> tp -> val -> p (GenToken key tp val) +pCostValToken' c tp val = let tok = ValToken tp val noPos + in pCostSym c tok tok + +pValToken' :: IsParser p (GenToken key tp val) + => tp -> val -> p (GenToken key tp val) +pValToken' tp val = let tok = ValToken tp val noPos + in pSym tok + + +pCostReserved :: IsParser p (GenToken key tp val) + => Int -> key -> p Pos +pCostReserved c key = let getPos x = case x of + Reserved _ p -> p + ValToken _ _ p -> p + in getPos <$> pCostReserved' c key + +pCostValToken :: IsParser p (GenToken key tp val) + => Int -> tp -> val -> p (val,Pos) +pCostValToken c tp val = let getVal x = case x of + ValToken _ v p -> (v,p) + _ -> error "pValToken: cannot get value of Reserved" + in getVal <$> pCostValToken' c tp val + +pReserved :: IsParser p (GenToken key tp val) + => key -> p Pos +pReserved = pCostReserved 5 + +pValToken :: IsParser p (GenToken key tp val) + => tp -> val -> p (val,Pos) +pValToken = pCostValToken 5 + +pValTokenNoPos :: IsParser p (GenToken key tp val) + => tp -> val -> p val +pValTokenNoPos tp val = fst <$> pValToken tp val + diff --git a/src/UU/Scanner/GenTokenSymbol.hs b/src/UU/Scanner/GenTokenSymbol.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/GenTokenSymbol.hs @@ -0,0 +1,8 @@ +module UU.Scanner.GenTokenSymbol() where + +import UU.Scanner.GenToken(GenToken(..)) +import UU.Parsing.MachineInterface(Symbol(..)) + +instance Symbol (GenToken key tp val) where + deleteCost (Reserved _ _) = 5 + deleteCost _ = 5 diff --git a/src/UU/Scanner/Position.hs b/src/UU/Scanner/Position.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/Position.hs @@ -0,0 +1,70 @@ +module UU.Scanner.Position where + +type Line = Int +type Column = Int +type Filename = String + + +class Position p where + line :: p -> Line + column :: p -> Column + file :: p -> Filename + + +instance Position Pos where + line (Pos l _ _) = l + column (Pos _ c _) = c + file (Pos _ _ f) = f + +data Pos = Pos !Line !Column Filename + +instance Show Pos where + show (Pos l c f) | l == (-1) = "" + | otherwise = let file = if null f then "" else show f + lc = "(line " ++ show l ++ ", column " ++ show c ++")" + in file ++ lc +initPos :: FilePath -> Pos +initPos fn = Pos 1 1 fn + +noPos :: Pos +noPos = Pos (-1) (-1) "" + +advl :: Line -> Pos ->Pos +advl i (Pos l c f) = (Pos (l+i) 1 f) + +advc :: Column -> Pos -> Pos +advc i (Pos l c f) = (Pos l (c+i) f) + +adv :: Pos -> Char -> Pos +adv pos c = case c of + '\t' -> advc (tabWidth (column pos)) pos + '\n' -> advl 1 pos + _ -> advc 1 pos + +updPos :: Char -> Pos -> Pos +updPos x = case x of + '\n' -> newl + '\t' -> tab + _ -> advc 1 + +tab :: Pos -> Pos +tab (Pos l c f) = Pos l (c+tabWidth c) f + +newl :: Pos ->Pos +newl = advl 1 + +tabWidth :: Column -> Int +tabWidth c = 8 - ((c-1) `mod` 8) + + +updPos' :: Char -> Pos -> (Pos -> a) -> a +updPos' c p cont = p `seq` cont (updPos c p) + +advc' :: Int -> Pos -> (Pos -> a) -> a +advc' i p cont = p `seq` cont (advc i p) + +tab' :: Pos -> (Pos -> a) -> a +tab' p cont = p `seq` cont (tab p) + +newl' :: Pos -> (Pos -> a) -> a +newl' p cont = p `seq` cont (newl p) diff --git a/src/UU/Scanner/Scanner.hs b/src/UU/Scanner/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/Scanner.hs @@ -0,0 +1,236 @@ +module UU.Scanner.Scanner where + +import Char(isLower, isUpper, isSpace, isAlphaNum, isDigit, chr, ord) +import List(sort) +import Maybe(isJust) +import UU.Util.BinaryTrees(tab2tree,btLocateIn) +import UU.Scanner.Token(Token, EnumValToken(..), valueToken, reserved, errToken) +import UU.Scanner.Position(Pos, initPos, advc, adv) +{- A parametrisable scanner + - + - Author: Doaitse Swierstra: doaitse@cs.uu.nl + and: Pablo Azero : pablo@cs.uu.nl + - Version 1.0 , May 25, 1998, SDS + first appearance on the software web site. + - Version 1.01, June 7, 1998, SDS + changed String recognition to recognise escaped characters + - Version 1.02, Aug 30, 1998, SDS + includes with unsafePerformIO + - Version 2.1, Jul 7, 1999, slightly different definition of valueToken + ordering between tokens introduced + - Version 2.2, Jul 8, 1999, AG_Scanner and UU_Scanner merged + - Version 2.3, Jul 15, 1999, modifications: recognize decimal, octal and + - hexadecimal numbers; handles ' as part of a + - lower case identifier + - fixes: bug in msort (loops when passing an + - empty list) + - Version 2.4, Jul 23, 1999, additions: recognize characters and infix + - operators + - + - Lang. compat: Hugs 98 (because it is required by UU_Parsing) + - Version 2.5, Aug 15, 1999, changed names, pSym -> pSpec + , all parsers start with p.... + - Version 2.6, Sept 15, 1999, changed error message for unterminated string + - Version 2.7, Sept 23, 1999, changed definition of pOper_Any + - Version 2.8 Aug 14, 2000, adapted to changes in search trees + - ?? Oct 25, 2000, adapted to use column numbers + - ?? Feb 2, 2001, incorporated changes of AD + - ?? Feb 28, 2001, tabs are handled correctly for column numbers + - ?? Mar 1, 2001, now generates space tokens that have to be filtered again + - ?? Apr 4, 2001, tabs are now handled relative to current column number + -} + +scanFile :: [String] -> [String] -> String -> String -> FilePath -> IO [Token] +scanFile keywordstxt keywordsops specchars opchars fn = + do txt <- readFile fn + return (scan keywordstxt keywordsops specchars opchars (initPos fn) txt) + +scan :: [String] -> [String] -> String -> String -> Pos -> String -> [Token] +scan keywordstxt keywordsops specchars opchars pos input + = doScan pos input + + where + locatein :: Ord a => [a] -> a -> Bool + locatein es = isJust . btLocateIn compare (tab2tree (sort es)) + iskw = locatein keywordstxt + isop = locatein keywordsops + isSymbol = locatein specchars + isOpsym = locatein opchars + + isIdStart c = isLower c || c == '_' + + isIdChar c = isAlphaNum c + || c == '\'' + || c == '_' + + scanIdent p s = let (name,rest) = span isIdChar s + in (name,advc (length name) p,rest) + + + doScan p [] = [] + doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s + in doScan (foldl adv p (c:sp)) next + + doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('{':'-':s) = lexNest doScan (advc 2 p) s + doScan p ('"':ss) + = let (s,swidth,rest) = scanString ss + in if null rest || head rest /= '"' + then errToken "Unterminated string literal" p : doScan (advc swidth p) rest + else valueToken TkString s p : doScan (advc (swidth+2) p) (tail rest) + + doScan p ('\'':ss) + = let (mc,cwidth,rest) = scanChar ss + in case mc of + Nothing -> errToken "Error in character literal" p : doScan (advc cwidth p) rest + Just c -> if null rest || head rest /= '\'' + then errToken "Unterminated character literal" p : doScan (advc (cwidth+1) p) rest + else valueToken TkChar [c] p : doScan (advc (cwidth+2) p) (tail rest) + + {- + In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier) + doScan p ('`':ss) + = case ss of + [] -> [errToken "Unterminated infix identifier" p] + (c:s) -> let res | isIdStart c || isUpper c = + let (name,p1,rest) = scanIdent (advc 2 p) s + ident = c:name + tokens | null rest || + head rest /= '`' = errToken "Unterminated infix identifier" p + : doScan p1 rest + | iskw ident = errToken ("Keyword used as infix identifier: " ++ ident) p + : doScan (advc 1 p1) (tail rest) + | otherwise = valueToken TkOp ident p + : doScan (advc 1 p1) (tail rest) + in tokens + | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p + : doScan (adv p c) s + in res + -} + doScan p cs@(c:s) + | isSymbol c = reserved [c] p + : doScan(advc 1 p) s + | isIdStart c || isUpper c + = let (name', p', s') = scanIdent (advc 1 p) s + name = c:name' + tok = if iskw name + then reserved name p + else if null name' && isSymbol c + then reserved [c] p + else valueToken (if isIdStart c then TkVarid else TkConid) name p + in tok : doScan p' s' + | isOpsym c = let (name, s') = span isOpsym cs + tok | isop name = reserved name p + | c==':' = valueToken TkConOp name p + | otherwise = valueToken TkOp name p + in tok : doScan (foldl adv p name) s' + | isDigit c = let (tktype,number,width,s') = getNumber cs + in valueToken tktype number p : doScan (advc width p) s' + | otherwise = errToken ("Unexpected character " ++ show c) p + : doScan (adv p c) s + +{- + +-- ks: no clean implementation of columns +readname s lc = (name,orest,nlc) + where (line,irest) = span (/='\n') s + orest = if null irest then "" else irest + nlc = if null irest then lc else (lc `advl` 1) + name = takename . dropWhile (\x -> not $ x `elem` "{[") $ line + takename ln | null ln = "" + | otherwise = if not (null tln) && (isAlpha . head $ tln) + then if not (null rln) && (head rln `elem` "}]") + then cname + else err lc 1 + else err lc 1 + where (cname, rln) = span validChar tln + tln = tail ln + validChar c = isAlpha c || c `elem` ".-_" || isDigit c + +-- ks: changed definition from (lc+1) to (lc) +err lc 1 = error ("in scanner bad name definition" ++ maybeshow (lc)) +err lc fn 2 + = error ("in scanner not a valid name in file inclusion" ++ maybeshow (lc)) +-} +lexNest :: (Pos -> String -> [Token]) + -> Pos + -> String + -> [Token] +lexNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('-':'}':s) = c (advc 2 p) s + lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (adv p x) s + lexNest' _ _ [] = [ errToken "Unterminated nested comment" pos] + +scanString :: String -> (String,Int,String) +scanString [] = ("",0,[]) +scanString ('\\':'&':xs) = let (str,w,r) = scanString xs + in (str,w+2,r) +scanString ('\'':xs) = let (str,w,r) = scanString xs + in ('\'': str,w+1,r) +scanString xs = let (ch,cw,cr) = getchar xs + (str,w,r) = scanString cr + str' = maybe "" (:str) ch + in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch + +scanChar :: [Char] -> (Maybe Char,Int,[Char]) +scanChar ('"' :xs) = (Just '"',1,xs) +scanChar xs = getchar xs + +getchar :: [Char] -> (Maybe Char,Int,[Char]) +getchar [] = (Nothing,0,[]) +getchar s@('\n':_ ) = (Nothing,0,s ) +getchar s@('\t':_ ) = (Nothing,0,s) +getchar s@('\'':_ ) = (Nothing,0,s) +getchar s@('\"' :_ ) = (Nothing,0,s) +getchar ('\\':xs) = let (c,l,r) = getEscChar xs + in (c,l+1,r) +getchar (x:xs) = (Just x,1,xs) + +getEscChar :: [Char] -> (Maybe Char,Int,[Char]) +getEscChar [] = (Nothing,0,[]) +getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s + val = case tp of + TkInteger8 -> readn 8 n + TkInteger16 -> readn 16 n + TkInteger10 -> readn 10 n + in if val >= 0 && val <= 255 + then (Just (chr val),len, rest) + else (Nothing,1,rest) + | otherwise = case x `lookup` cntrChars of + Nothing -> (Nothing,0,s) + Just c -> (Just c,1,xs) + where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') + ,('v','\v'),('\\','\\'),('\"','\"'),('\'','\'')] + +readn :: Int -> [Char] -> Int +readn base n = foldl (\r x -> value x + base * r) 0 n + +getNumber :: [Char] -> (EnumValToken,[Char],Int,[Char]) +getNumber cs@(c:s) + | c /= '0' = num10 + | null s = const0 + | hs == 'x' || hs == 'X' = num16 + | hs == 'o' || hs == 'O' = num8 + | otherwise = num10 + where (hs:ts) = s + const0 = (TkInteger10, "0",1,s) + num10 = let (n,r) = span isDigit cs + in (TkInteger10,n,length n,r) + num16 = readNum isHexaDigit ts TkInteger16 + num8 = readNum isOctalDigit ts TkInteger8 + readNum p ts tk + = let nrs@(n,rs) = span p ts + in if null n then const0 + else (tk , n, 2+length n,rs) + +isHexaDigit :: Char -> Bool +isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') + +isOctalDigit :: Char -> Bool +isOctalDigit d = d >= '0' && d <= '7' + +value :: Char -> Int +value c | isDigit c = ord c - ord '0' + | isUpper c = ord c - ord 'A' + 10 + | isLower c = ord c - ord 'a' + 10 diff --git a/src/UU/Scanner/Token.hs b/src/UU/Scanner/Token.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/Token.hs @@ -0,0 +1,32 @@ +module UU.Scanner.Token where + +import UU.Scanner.GenToken(GenToken(..)) +import UU.Scanner.Position(Pos) + +type Token = GenToken String EnumValToken String + +data EnumValToken + = TkVarid + | TkConid + | TkString + | TkChar + | TkInteger8 + | TkInteger10 + | TkInteger16 + | TkFraction + | TkTextnm + | TkTextln + | TkOp + | TkConOp + | TkError + deriving (Eq, Ord) + +reserved :: String -> Pos -> Token +reserved = Reserved + +valueToken :: EnumValToken -> String -> Pos -> Token +valueToken = ValToken + +errToken :: String -> Pos -> Token +errToken = valueToken TkError + diff --git a/src/UU/Scanner/TokenParser.hs b/src/UU/Scanner/TokenParser.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/TokenParser.hs @@ -0,0 +1,107 @@ +module UU.Scanner.TokenParser where + +import UU.Parsing.Interface(IsParser(..)) +import UU.Parsing.Derived(pListSep, pPacked) +import UU.Scanner.Position(Pos) +import UU.Scanner.GenTokenParser(pReserved, pValToken) +import UU.Scanner.Token(Token,EnumValToken(..)) + +------------------------------------------------------------------------- +-- IsParsers for Symbols +------------------------------------------------------------------------- + +pKeyPos :: IsParser p Token => String -> p Pos +pKeyPos keyword = pReserved keyword + + +pSpecPos :: IsParser p Token => Char -> p Pos +pSpecPos s = pReserved [s] + +pKey :: IsParser p Token => String -> p String +pKey key = key <$ pKeyPos key + +pSpec :: IsParser p Token => Char -> p String +pSpec c = [c] <$ pSpecPos c + +pStringPos, pCharPos, + pInteger8Pos, pInteger10Pos, pInteger16Pos, pFractionPos, + pVaridPos, pConidPos, + pTextnmPos, pTextlnPos, pIntegerPos, pVarsymPos, pConsymPos :: IsParser p Token => p (String,Pos) + +pStringPos = pValToken TkString "" +pCharPos = pValToken TkChar "\NUL" +pInteger8Pos = pValToken TkInteger8 "0" +pInteger10Pos = pValToken TkInteger10 "0" +pInteger16Pos = pValToken TkInteger16 "0" +pFractionPos = pValToken TkFraction "0.0" +pVaridPos = pValToken TkVarid "" +pConidPos = pValToken TkConid "" +pConsymPos = pValToken TkConOp "" +pVarsymPos = pValToken TkOp "" +pTextnmPos = pValToken TkTextnm "" +pTextlnPos = pValToken TkTextln "" +pIntegerPos = pInteger10Pos + +pString, pChar, + pInteger8, pInteger10, pInteger16, pFraction, + pVarid, pConid, + pTextnm, pTextln, pInteger, pVarsym, pConsym :: IsParser p Token => p String + +pString = fst <$> pStringPos +pChar = fst <$> pCharPos +pInteger8 = fst <$> pInteger8Pos +pInteger10 = fst <$> pInteger10Pos +pInteger16 = fst <$> pInteger16Pos +pFraction = fst <$> pFractionPos +pVarid = fst <$> pVaridPos +pConid = fst <$> pConidPos +pVarsym = fst <$> pVarsymPos +pConsym = fst <$> pConsymPos +pTextnm = fst <$> pTextnmPos +pTextln = fst <$> pTextlnPos +pInteger = fst <$> pIntegerPos + +pComma, pSemi, pOParen, pCParen, pOBrack, pCBrack, pOCurly, pCCurly + :: IsParser p Token => p String + +pComma = pSpec ',' +pSemi = pSpec ';' +pOParen = pSpec '(' +pCParen = pSpec ')' +pOBrack = pSpec '[' +pCBrack = pSpec ']' +pOCurly = pSpec '{' +pCCurly = pSpec '}' + +pCommaPos, pSemiPos, pOParenPos, pCParenPos, pOBrackPos, pCBrackPos, pOCurlyPos, pCCurlyPos + :: IsParser p Token => p Pos + +pCommaPos = pSpecPos ',' +pSemiPos = pSpecPos ';' +pOParenPos = pSpecPos '(' +pCParenPos = pSpecPos ')' +pOBrackPos = pSpecPos '[' +pCBrackPos = pSpecPos ']' +pOCurlyPos = pSpecPos '{' +pCCurlyPos = pSpecPos '}' + +pCommas :: IsParser p Token => p a -> p [a] +pSemics :: IsParser p Token => p a -> p [a] +pParens :: IsParser p Token => p a -> p a +pBracks :: IsParser p Token => p a -> p a +pCurly :: IsParser p Token => p a -> p a + +pCommas = pListSep pComma +pSemics = pListSep pSemi +pParens = pPacked pOParen pCParen +pBracks = pPacked pOBrack pCBrack +pCurly = pPacked pOCurly pCCurly + +pParens_pCommas :: IsParser p Token => p a -> p [a] +pBracks_pCommas :: IsParser p Token => p a -> p [a] +pCurly_pSemics :: IsParser p Token => p a -> p [a] + +pParens_pCommas = pParens.pCommas +pBracks_pCommas = pBracks.pCommas +pCurly_pSemics = pCurly .pSemics + diff --git a/src/UU/Scanner/TokenShow.hs b/src/UU/Scanner/TokenShow.hs new file mode 100644 --- /dev/null +++ b/src/UU/Scanner/TokenShow.hs @@ -0,0 +1,35 @@ +module UU.Scanner.TokenShow() where + +import UU.Scanner.Token(Token,EnumValToken(..)) +import UU.Scanner.Position(Pos(..)) +import UU.Scanner.GenToken(GenToken(..)) + +instance Show Token where + showsPrec _ token + = showString + (case token of + Reserved key pos -> "symbol " ++ key ++ maybeshow pos + ValToken tp val pos -> show tp ++ " " ++ val ++ maybeshow pos + ) +instance Show EnumValToken where + show tp = case tp of + TkOp -> "operator" + TkConOp -> "con operator" + TkString -> "string" + TkChar -> "character" + TkInteger8 -> "octal integer" + TkInteger10 -> "decimal Integer" + TkInteger16 -> "hexadecimal integer" + TkFraction -> "fraction (float,...)" + TkVarid -> "lower case identifier" + TkConid -> "upper case identifier" + TkTextnm -> "text name" + TkTextln -> "text lines" + TkError -> "error in scanner:" + +maybeshow :: Pos -> String +maybeshow (Pos l c fn) | l <= 0 || c <= 0 = "" + | otherwise = " at line " ++ show l + ++ ", column " ++ show c + ++ " of file " ++ show fn + diff --git a/src/UU/Util/BinaryTrees.hs b/src/UU/Util/BinaryTrees.hs new file mode 100644 --- /dev/null +++ b/src/UU/Util/BinaryTrees.hs @@ -0,0 +1,84 @@ +{- Copyright: S. Doaitse Swierstra + Department of Computer Science + Utrecht University + P.O. Box 80.089 + 3508 TB UTRECHT + the Netherlands + swierstra@cs.uu.nl +-} +module UU.Util.BinaryTrees + +( BinSearchTree(..) +, tab2tree +, btFind +, btLocateIn +, btLookup +) +where +-- ======================================================================================= +-- ===== BINARY SEARCH TREES ============================================================= +-- ======================================================================================= + +data BinSearchTree av + = Node (BinSearchTree av) av (BinSearchTree av) + | Nil + +tab2tree :: [av] -> BinSearchTree av +tab2tree tab = tree + where + (tree,[]) = sl2bst (length tab) (tab) + sl2bst 0 list = (Nil , list) + sl2bst n list + = let + ll = (n - 1) `div` 2 ; rl = n - 1 - ll + (lt,a:list1) = sl2bst ll list + (rt, list2) = sl2bst rl list1 + in (Node lt a rt, list2) + +-- remember we compare the key value with the lookup value + +btFind :: (a -> b -> Ordering) -> BinSearchTree (a, c) -> b -> Maybe c +btFind = btLookup fst snd + +btLocateIn :: (a -> b -> Ordering) -> BinSearchTree a -> b -> Maybe a +btLocateIn = btLookup id id + +btLookup :: (a -> b) -> (a -> c) -> (b -> d -> Ordering) -> BinSearchTree a -> d -> Maybe c +btLookup key val cmp (Node Nil kv Nil) + = let comp = cmp (key kv) + r = val kv + in \i -> case comp i of + LT -> Nothing + EQ -> Just r + GT -> Nothing + +btLookup key val cmp (Node left kv Nil) + = let comp = cmp (key kv) + findleft = btLookup key val cmp left + r = val kv + in \i -> case comp i of + LT -> Nothing + EQ -> Just r + GT -> findleft i + +btLookup key val cmp (Node Nil kv right ) + = let comp = cmp (key kv) + findright = btLookup key val cmp right + r = val kv + in \i -> case comp i of + LT -> findright i + EQ -> Just r + GT -> Nothing + +btLookup key val cmp (Node left kv right) + = let comp = cmp (key kv) + findleft = btLookup key val cmp left + findright = btLookup key val cmp right + r = val kv + in \i -> case comp i of + LT -> findright i + EQ -> Just r + GT -> findleft i + +btLookup _ _ _ Nil = \i -> Nothing + diff --git a/src/UU/Util/PermTree.hs b/src/UU/Util/PermTree.hs new file mode 100644 --- /dev/null +++ b/src/UU/Util/PermTree.hs @@ -0,0 +1,57 @@ +module UU.Util.PermTree where + +import Monad(ap,liftM2) + +------------------------------------------------------------------------------------ +-- data type for permutation trees +------------------------------------------------------------------------------------ + +data Perms p a = Choice (Maybe a) [Branch p a] +data Branch p a = forall x . Br (p x) (Perms p (x->a)) + +------------------------------------------------------------------------------------ +-- definition of fmap on permutation trees +------------------------------------------------------------------------------------ + +instance Functor (Perms p) where + fmap f (Choice e bs) = Choice (fmap f e) (map (fmap f) bs) + +instance Functor (Branch p) where + fmap f (Br p ps) = Br p (fmap (f.) ps) + +------------------------------------------------------------------------------------ +-- add single parser to permutation tree +------------------------------------------------------------------------------------ + +{- +ap :: Maybe (a->b)-> Maybe a -> Maybe b +ap (Just f) (Just x) = Just (f x) +ap _ _ = Nothing +-} + +add :: Maybe a -> p a -> Perms p (a->b) -> Perms p b +add da pa tab@(Choice dab bsab) = let empty = dab `ap` da + insert (Br px txab) = Br px (add da pa (fmap flip txab)) + in Choice empty (Br pa tab:map insert bsab) + + +------------------------------------------------------------------------------------ +-- permutation construction combinators +------------------------------------------------------------------------------------ +empty :: a -> Perms p a +empty x = Choice (Just x) [] + + +(<$$>) :: (a->b) -> p a -> Perms p b +f <$$> p = empty f <||> p + +(<$?>) :: (a->b) -> (a, p a) -> Perms p b +f <$?> (e,p) = empty f <|?> (e,p) + +(<||>) :: Perms p (a->b) -> p a -> Perms p b +ps <||> p = add Nothing p ps + +(<|?>) :: Perms p (a->b) -> (a, p a) -> Perms p b +ps <|?> (e,p) = add (Just e) p ps + + diff --git a/src/UU/Util/Utils.hs b/src/UU/Util/Utils.hs new file mode 100644 --- /dev/null +++ b/src/UU/Util/Utils.hs @@ -0,0 +1,19 @@ +module UU.Util.Utils where + +newtype Id x = Id x + +cross :: (a->c) -> (b->d) -> (a,b) -> (c,d) +cross f g (x,y) = (f x, g y) + +split :: (a->b) -> (a->c) -> a -> (b,c) +split f g x = (f x,g x) + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c + diff --git a/uulib.cabal b/uulib.cabal new file mode 100644 --- /dev/null +++ b/uulib.cabal @@ -0,0 +1,31 @@ +cabal-version: >=1.1 +build-type: Simple +name: uulib +version: 0.9.5 +license: LGPL +license-file: COPYRIGHT +maintainer: Arie Middelkoop +homepage: http://www.cs.uu.nl/wiki/HUT/WebHome +description: Fast Parser Combinators and Pretty Printing Combinators +synopsis: Haskell Utrecht Tools Library +category: Parsing +stability: Stable +copyright: Universiteit Utrecht +build-depends: base, haskell98 +exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived + UU.Parsing.Interface UU.Parsing.MachineInterface + UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms + UU.Parsing.StateParser UU.Parsing UU.DData.IntBag + UU.DData.Map UU.DData.MultiSet UU.DData.Queue + UU.DData.Scc UU.DData.Seq UU.DData.Set UU.PPrint + UU.Pretty.Ext UU.Pretty UU.Scanner.GenToken UU.Scanner.GenTokenOrd + UU.Scanner.GenTokenParser UU.Scanner.GenTokenSymbol + UU.Scanner.Position UU.Scanner.Scanner + UU.Scanner.Token UU.Scanner.TokenParser UU.Scanner.TokenShow + UU.Scanner UU.Util.BinaryTrees UU.Util.PermTree UU.Util.Utils + UU.Pretty.Basic UU.Parsing.Machine + UU.DData.IntMap + UU.DData.IntSet +extensions: RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification +hs-source-dirs: src +extra-source-files: README, LICENSE-LGPL