From 2cd6e3f9bfe40693c0f08a5d1461d17aa094d43d Mon Sep 17 00:00:00 2001 From: Mike Furr Date: Tue, 2 Oct 2007 22:35:40 +0200 Subject: Import ocaml-reins_0.1a.orig.tar.gz [dgit import orig ocaml-reins_0.1a.orig.tar.gz] --- AUTHORS | 2 + COPYING | 20 + INSTALL | 18 + LGPL-2.1 | 510 +++++++++++++++++++++++++ OMakefile | 13 + OMakeroot | 14 + config.omake | 15 + doc/OMakefile | 2 + doc/html/index.html | 128 +++++++ header | 6 + src/META.in | 3 + src/OMakefile | 56 +++ src/base/OMakefile | 6 + src/base/quickcheck.ml | 66 ++++ src/base/quickcheck.mli | 73 ++++ src/base/types.ml | 452 ++++++++++++++++++++++ src/base/types.mli | 632 ++++++++++++++++++++++++++++++ src/heap/OMakefile | 7 + src/heap/binomialHeap.ml | 121 ++++++ src/heap/binomialHeap.mli | 16 + src/heap/heaps.ml | 63 +++ src/heap/heaps.mli | 66 ++++ src/heap/skewBinomialHeap.ml | 134 +++++++ src/heap/skewBinomialHeap.mli | 16 + src/iterator/OMakefile | 8 + src/iterator/iterator.ml | 48 +++ src/iterator/iterator.mli | 122 ++++++ src/iterator/iteratorMixin.ml | 149 ++++++++ src/iterator/listIterator.ml | 77 ++++ src/iterator/listIterator.mli | 42 ++ src/iterator/treeSetIterator.ml | 152 ++++++++ src/iterator/treeSetIterator.mli | 39 ++ src/list/OMakefile | 15 + src/list/catenableList.ml | 126 ++++++ src/list/catenableList.mli | 129 +++++++ src/list/doubleList.ml | 152 ++++++++ src/list/doubleList.mli | 224 +++++++++++ src/list/doubleQueue.ml | 115 ++++++ src/list/doubleQueue.mli | 160 ++++++++ src/list/listCommon.ml | 22 ++ src/list/listCursor.ml | 75 ++++ src/list/listCursor.mli | 85 +++++ src/list/lists.ml | 39 ++ src/list/lists.mli | 105 +++++ src/list/sList.ml | 51 +++ src/list/sList.mli | 117 ++++++ src/list/skewBinaryList.ml | 227 +++++++++++ src/list/skewBinaryList.mli | 155 ++++++++ src/map/OMakefile | 9 + src/map/aVLMap.ml | 677 +++++++++++++++++++++++++++++++++ src/map/aVLMap.mli | 52 +++ src/map/maps.ml | 203 ++++++++++ src/map/maps.mli | 203 ++++++++++ src/map/patriciaMap.ml | 390 +++++++++++++++++++ src/map/patriciaMap.mli | 28 ++ src/map/rBMap.ml | 674 ++++++++++++++++++++++++++++++++ src/map/rBMap.mli | 20 + src/map/splayMap.ml | 489 ++++++++++++++++++++++++ src/map/splayMap.mli | 37 ++ src/oracle/OMakefile | 14 + src/oracle/dug.ml | 63 +++ src/oracle/dug.mli | 42 ++ src/oracle/dugADT.ml | 43 +++ src/oracle/dugADT.mli | 71 ++++ src/oracle/dugExtractor.ml | 61 +++ src/oracle/dugExtractor.mli | 28 ++ src/oracle/dugGenerator.ml | 220 +++++++++++ src/oracle/dugGenerator.mli | 20 + src/oracle/dugProfile.ml | 214 +++++++++++ src/oracle/dugProfile.mli | 46 +++ src/oracle/oracle.ml | 40 ++ src/oracle/oracle.mli | 25 ++ src/oracle/oracleList.ml | 167 ++++++++ src/oracle/oracleList.mli | 36 ++ src/oracle/oracleSet.ml | 336 ++++++++++++++++ src/oracle/oracleSet.mli | 37 ++ src/oracle/randomBag.ml | 35 ++ src/oracle/replayList.ml | 133 +++++++ src/set/OMakefile | 9 + src/set/aVLSet.ml | 505 ++++++++++++++++++++++++ src/set/aVLSet.mli | 121 ++++++ src/set/patriciaSet.ml | 288 ++++++++++++++ src/set/patriciaSet.mli | 33 ++ src/set/rBSet.ml | 604 +++++++++++++++++++++++++++++ src/set/rBSet.mli | 40 ++ src/set/sets.ml | 124 ++++++ src/set/sets.mli | 246 ++++++++++++ src/set/splaySet.ml | 388 +++++++++++++++++++ src/set/splaySet.mli | 51 +++ src/version.mli | 11 + test/OMakefile | 2 + test/perf/OMakefile | 28 ++ test/perf/bench.ml | 25 ++ test/perf/bench_driver.ml | 34 ++ test/perf/bench_helper.ml | 28 ++ test/perf/dug_set_tests.ml | 172 +++++++++ test/perf/list_bench.ml | 133 +++++++ test/perf/set/OMakefile | 5 + test/perf/set/set_bench.ml | 225 +++++++++++ test/unit/OMakefile | 26 ++ test/unit/genericTest.ml | 48 +++ test/unit/heap/OMakefile | 7 + test/unit/heap/binomialHeapTest.ml | 21 + test/unit/heap/genericHeapTest.ml | 63 +++ test/unit/heap/skewBinomialHeapTest.ml | 21 + test/unit/list/OMakefile | 10 + test/unit/list/catenableListTest.ml | 24 ++ test/unit/list/doubleListTest.ml | 85 +++++ test/unit/list/doubleQueueTest.ml | 42 ++ test/unit/list/genericListTest.ml | 226 +++++++++++ test/unit/list/sListTest.ml | 35 ++ test/unit/list/skewBinaryListTest.ml | 86 +++++ test/unit/map/OMakefile | 10 + test/unit/map/aVLMapTest.ml | 30 ++ test/unit/map/genericMapTest.ml | 363 ++++++++++++++++++ test/unit/map/patriciaMapTest.ml | 26 ++ test/unit/map/rBMapTest.ml | 26 ++ test/unit/map/splayMapTest.ml | 62 +++ test/unit/set/OMakefile | 11 + test/unit/set/aVLSetTest.ml | 36 ++ test/unit/set/genericSetTest.ml | 311 +++++++++++++++ test/unit/set/patriciaSetTest.ml | 29 ++ test/unit/set/rBSetTest.ml | 29 ++ test/unit/set/splaySetTest.ml | 65 ++++ test/unit/set/treeSetIteratorTest.ml | 142 +++++++ test/unit/test_helper.ml | 27 ++ test/unit/test_runner.ml | 62 +++ 127 files changed, 14281 insertions(+) create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 INSTALL create mode 100644 LGPL-2.1 create mode 100644 OMakefile create mode 100644 OMakeroot create mode 100644 config.omake create mode 100644 doc/OMakefile create mode 100644 doc/html/index.html create mode 100644 header create mode 100644 src/META.in create mode 100644 src/OMakefile create mode 100644 src/base/OMakefile create mode 100644 src/base/quickcheck.ml create mode 100644 src/base/quickcheck.mli create mode 100644 src/base/types.ml create mode 100644 src/base/types.mli create mode 100644 src/heap/OMakefile create mode 100644 src/heap/binomialHeap.ml create mode 100644 src/heap/binomialHeap.mli create mode 100644 src/heap/heaps.ml create mode 100644 src/heap/heaps.mli create mode 100644 src/heap/skewBinomialHeap.ml create mode 100644 src/heap/skewBinomialHeap.mli create mode 100644 src/iterator/OMakefile create mode 100644 src/iterator/iterator.ml create mode 100644 src/iterator/iterator.mli create mode 100644 src/iterator/iteratorMixin.ml create mode 100644 src/iterator/listIterator.ml create mode 100644 src/iterator/listIterator.mli create mode 100644 src/iterator/treeSetIterator.ml create mode 100644 src/iterator/treeSetIterator.mli create mode 100644 src/list/OMakefile create mode 100644 src/list/catenableList.ml create mode 100644 src/list/catenableList.mli create mode 100644 src/list/doubleList.ml create mode 100644 src/list/doubleList.mli create mode 100644 src/list/doubleQueue.ml create mode 100644 src/list/doubleQueue.mli create mode 100644 src/list/listCommon.ml create mode 100644 src/list/listCursor.ml create mode 100644 src/list/listCursor.mli create mode 100644 src/list/lists.ml create mode 100644 src/list/lists.mli create mode 100644 src/list/sList.ml create mode 100644 src/list/sList.mli create mode 100644 src/list/skewBinaryList.ml create mode 100644 src/list/skewBinaryList.mli create mode 100644 src/map/OMakefile create mode 100644 src/map/aVLMap.ml create mode 100644 src/map/aVLMap.mli create mode 100644 src/map/maps.ml create mode 100644 src/map/maps.mli create mode 100644 src/map/patriciaMap.ml create mode 100644 src/map/patriciaMap.mli create mode 100644 src/map/rBMap.ml create mode 100644 src/map/rBMap.mli create mode 100644 src/map/splayMap.ml create mode 100644 src/map/splayMap.mli create mode 100644 src/oracle/OMakefile create mode 100644 src/oracle/dug.ml create mode 100644 src/oracle/dug.mli create mode 100644 src/oracle/dugADT.ml create mode 100644 src/oracle/dugADT.mli create mode 100644 src/oracle/dugExtractor.ml create mode 100644 src/oracle/dugExtractor.mli create mode 100644 src/oracle/dugGenerator.ml create mode 100644 src/oracle/dugGenerator.mli create mode 100644 src/oracle/dugProfile.ml create mode 100644 src/oracle/dugProfile.mli create mode 100644 src/oracle/oracle.ml create mode 100644 src/oracle/oracle.mli create mode 100644 src/oracle/oracleList.ml create mode 100644 src/oracle/oracleList.mli create mode 100644 src/oracle/oracleSet.ml create mode 100644 src/oracle/oracleSet.mli create mode 100644 src/oracle/randomBag.ml create mode 100644 src/oracle/replayList.ml create mode 100644 src/set/OMakefile create mode 100644 src/set/aVLSet.ml create mode 100644 src/set/aVLSet.mli create mode 100644 src/set/patriciaSet.ml create mode 100644 src/set/patriciaSet.mli create mode 100644 src/set/rBSet.ml create mode 100644 src/set/rBSet.mli create mode 100644 src/set/sets.ml create mode 100644 src/set/sets.mli create mode 100644 src/set/splaySet.ml create mode 100644 src/set/splaySet.mli create mode 100644 src/version.mli create mode 100644 test/OMakefile create mode 100644 test/perf/OMakefile create mode 100644 test/perf/bench.ml create mode 100644 test/perf/bench_driver.ml create mode 100644 test/perf/bench_helper.ml create mode 100644 test/perf/dug_set_tests.ml create mode 100644 test/perf/list_bench.ml create mode 100644 test/perf/set/OMakefile create mode 100644 test/perf/set/set_bench.ml create mode 100644 test/unit/OMakefile create mode 100644 test/unit/genericTest.ml create mode 100644 test/unit/heap/OMakefile create mode 100644 test/unit/heap/binomialHeapTest.ml create mode 100644 test/unit/heap/genericHeapTest.ml create mode 100644 test/unit/heap/skewBinomialHeapTest.ml create mode 100644 test/unit/list/OMakefile create mode 100644 test/unit/list/catenableListTest.ml create mode 100644 test/unit/list/doubleListTest.ml create mode 100644 test/unit/list/doubleQueueTest.ml create mode 100644 test/unit/list/genericListTest.ml create mode 100644 test/unit/list/sListTest.ml create mode 100644 test/unit/list/skewBinaryListTest.ml create mode 100644 test/unit/map/OMakefile create mode 100644 test/unit/map/aVLMapTest.ml create mode 100644 test/unit/map/genericMapTest.ml create mode 100644 test/unit/map/patriciaMapTest.ml create mode 100644 test/unit/map/rBMapTest.ml create mode 100644 test/unit/map/splayMapTest.ml create mode 100644 test/unit/set/OMakefile create mode 100644 test/unit/set/aVLSetTest.ml create mode 100644 test/unit/set/genericSetTest.ml create mode 100644 test/unit/set/patriciaSetTest.ml create mode 100644 test/unit/set/rBSetTest.ml create mode 100644 test/unit/set/splaySetTest.ml create mode 100644 test/unit/set/treeSetIteratorTest.ml create mode 100644 test/unit/test_helper.ml create mode 100644 test/unit/test_runner.ml diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..7661867 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ + +Mike Furr diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..f49f1fd --- /dev/null +++ b/COPYING @@ -0,0 +1,20 @@ + +The OCaml Reins library is distributed under the terms of the Lesser +General Public License version 2.1 (provided in the file LGPL-2.1) +with the following linking exception. + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Lesser General +Public License. By "a publicly distributed version of the Library", we +mean either the unmodified Library as distributed by the official +ocaml-reins website (currently ocaml-reins.sourceforge.net), or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Lesser General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Lesser General +Public License. + diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..a589ff1 --- /dev/null +++ b/INSTALL @@ -0,0 +1,18 @@ + +The following software is required to build OCaml Reins + * OCaml versions >= 3.09.2; earlier versions have not been tested. + * OCaml findlib (http://www.ocaml-programming.de/programming/findlib.html) + * OMake (http://omake.metaprl.org) version >= 0.9.8.5 + * OUnit (http://www.xs4all.nl/~mmzeeman/ocaml/) version >= 1.0.1. + +To build the library simply type: + $ omake + +To install it (using ocaml-findlib) type: + $ omake install + +To build the api documentation type: + $ omake doc + +The documentation can then be installed by copying it from +doc/html/api to the desired location. \ No newline at end of file diff --git a/LGPL-2.1 b/LGPL-2.1 new file mode 100644 index 0000000..2d2d780 --- /dev/null +++ b/LGPL-2.1 @@ -0,0 +1,510 @@ + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 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/OMakefile b/OMakefile new file mode 100644 index 0000000..b741412 --- /dev/null +++ b/OMakefile @@ -0,0 +1,13 @@ + +include config.omake + +OCAMLFLAGS += -dtypes + +.SUBDIRS: src doc + +.SUBDIRS: test + +.PHONY: clean + +clean: + rm -f $(filter-proper-targets $(ls R, .)) diff --git a/OMakeroot b/OMakeroot new file mode 100644 index 0000000..87dc131 --- /dev/null +++ b/OMakeroot @@ -0,0 +1,14 @@ + +open build/OCaml +open configure/Configure + +# +# The command-line variables are defined *after* the +# standard configuration has been loaded. +# +DefineCommandVars() + +# +# Include the OMakefile in this directory. +# +.SUBDIRS: . diff --git a/config.omake b/config.omake new file mode 100644 index 0000000..4417254 --- /dev/null +++ b/config.omake @@ -0,0 +1,15 @@ + +static. = + BYTE_ENABLED = true + USE_OCAMLFIND=true + if $(not $(OCAMLFIND_EXISTS)) + eprintln(ocaml-findlib is required to build this project) + exit 1 + OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) + OCAMLDEP=$(OCAMLDEP_MODULES) + PREFIX=$(shell ocamlc -where) + VERSION=0.1a + ConfMsgChecking(oUnit) + OUNIT_DIR=$(shell ocamlfind query oUnit) + ConfMsgResult($(OUNIT_DIR)) + export diff --git a/doc/OMakefile b/doc/OMakefile new file mode 100644 index 0000000..139597f --- /dev/null +++ b/doc/OMakefile @@ -0,0 +1,2 @@ + + diff --git a/doc/html/index.html b/doc/html/index.html new file mode 100644 index 0000000..efdaa81 --- /dev/null +++ b/doc/html/index.html @@ -0,0 +1,128 @@ + + + + O'Caml Reins Data Structure Library + + + +
+

O'Caml Reins

+
+ +

+ Welcome to the home page for the O'Caml Reins persistent data + structure library. This project began as an OCaml Summer Project + sponsored by Jane St. Capital and is now continuing on here at + sourceforge. Since it is my goal to include as many data structures + as possible in this library, I am always looking for contributions + from others. Even if you don't have time to contribute code, but + know of a data structure that you would like to see included, please + let us know by sending a message to the mailing + list. In addition to providing a large collection of data + structures, the O'Caml Reins project also includes several features + that I hope will make developing O'Caml applications easier such as + a random testing framework and a collection of "standard" modules. +

+

Current features

+
    +
  • List data types: +
      +
    • Single linked lists (compatible with the standard library type)
      • +
    • O(1) catenable lists
      • +
    • Acyclic double linked lists
      • +
    • Random access lists with O(1) hd/cons/tl and O(log i) + lookup/update for i'th element
      • +
    • +
  • Double ended queues
    • +
  • Sets/Maps: +
      +
    • AVL
      • +
    • Red/Black
      • +
    • Big-endian Patricia
      • +
    • Splay
      • +
    • +
  • Heaps: +
      +
    • Binomial
      • +
    • Skew Binomial
      • +
    +
    • +
  • Zipper style cursor interfaces
    • +
  • Persistent, bi-directional cursor based iterators (currently + only for lists and sets)
    • +
  • All standard types hoisted into the module level (Int, Bool, etc...)
    • +
  • A collection of functor combinators to minimize boilerplate + (e.g., constructing compare or to_string + functions)
    • +
  • Quickcheck testing framework +
    • Each structure provides a gen function that can + generate a random instance of itself
    +
    • +
  • Completely safe code. No -unsafe or references to Obj.*
    • +
  • Consistent function signatures. For instance, all fold + functions take the accumulator in the same position.
    • +
  • All operations use no more than O(log n) stack space (except + for a few operations on splay trees which currently have O(log n) + expected time, but O(n) worst case)
    • + +
+ +

Coming features

+There are several features that were not quite ready for this release + but are in the works: +
    +
  • Space and time asymptotic bounds on all functions
    • +
  • Automatic benchmarking of all included data structures (based + on Graeme Moss's PhD thesis) +
    • Including a set of Oracle data structures which + recommend a specific implementation based on observed executions
    +
    • +
  • Fill in missing functionality. For instance sets and maps + need a {to,from}_list function and many list functions are still + missing.
    • +
  • More data structures: +
      +
    • weight balanced trees
      • +
    • persistent arrays
      • +
    • more heap implementations
      • +
    +
    • +
  • Iterators for maps and heaps
    • +
  • 100% code coverage from the test suite
    • +
  • Web based manual / tutorial for using some of the less + intuitive features
    • +
+ +

More Information

+

+ Check out the sourceforce + project + page for access to svn, bug tracker, etc...
+ +There is also a + mailing + list setup.
+ + You can also browse the ocamldoc API pages available here +

+ +

+This page is hosted by: SourceForge.net Logo +

+ +
+

+ + + Valid XHTML 1.0! + +

+ + + diff --git a/header b/header new file mode 100644 index 0000000..e465a7a --- /dev/null +++ b/header @@ -0,0 +1,6 @@ +The OCaml Reins Library + +Copyright 2007 Mike Furr. +All rights reserved. This file is distributed under the terms of the +GNU Lesser General Public License version 2.1 with the linking +exception given in the COPYING file. diff --git a/src/META.in b/src/META.in new file mode 100644 index 0000000..6cbc725 --- /dev/null +++ b/src/META.in @@ -0,0 +1,3 @@ +version="0.1" +archive(byte)="reins.cma" +archive(native)="reins.cmxa" \ No newline at end of file diff --git a/src/OMakefile b/src/OMakefile new file mode 100644 index 0000000..983799d --- /dev/null +++ b/src/OMakefile @@ -0,0 +1,56 @@ + +FILES[] = version +OCAMLFLAGS += -for-pack Reins + +DIRS = base list iterator set map heap oracle + +.SUBDIRS: $(DIRS) + include OMakefile + export FILES + +version.ml: + echo "let version = \"$(VERSION)\"" > version.ml + +META: META.in + sed "s/@version/$(VERSION)/" META.in > META + +reins.mli: $(addsuffix .cmi, $(FILES)) :optional: $(addsuffix .mli, $(FILES)) + rm -f $@ + echo "(** The OCaml Reins library *)" > $@ + foreach(name, \ + $(filter-exists \ + $(replacesuffixes .cmi, .mli, \ + $(file-sort .BUILDORDER, \ + $(filter %.cmi, \ + $^))))) + mod = $(capitalize $(removesuffix $(basename $(name)))) + echo "module $(mod) : sig" >> $@ + cat $(name) >> $@ + echo "end" >> $@ + +section + # hack for pre 3.10 -pack behavior + OCAMLFLAGS = $(mapprefix -I,$(DIRS)) + REINS_PKG = $(OCamlPackage reins, $(FILES)) + REINS_LIB = $(OCamlLibrary reins, reins) + export REINS_LIB + +REINS_TOP = reins +$(REINS_TOP) : libreins.cma + $(OCAMLMKTOP) -o $(REINS_TOP) nums.cma unix.cma libreins.cma + +.PHONY: doc + +doc: reins.mli + ocamldoc -v -sort -warn-error -html -d $(ROOT)/doc/html/api reins.mli + +.DEFAULT: $(REINS_LIB) #$(REINS_TOP) + +.PHONY: install + +REINS_CMX=$(if $(NATIVE_ENABLED), reins.cmx) + +install: META $(REINS_LIB) + mkdir -p $(PREFIX)/reins + ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) \ + $(filter-exists $(addsuffix .mli, $(FILES))) diff --git a/src/base/OMakefile b/src/base/OMakefile new file mode 100644 index 0000000..29ead04 --- /dev/null +++ b/src/base/OMakefile @@ -0,0 +1,6 @@ + +FILES[] += + base/types + base/quickcheck + + diff --git a/src/base/quickcheck.ml b/src/base/quickcheck.ml new file mode 100644 index 0000000..9667373 --- /dev/null +++ b/src/base/quickcheck.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open Types + +module type Law = sig + module Arg : Types.Mono.Arbitrary + val desc : string + val law : Arg.t -> bool +end + +module type Config = sig + val num_iterations : int + val size_arg : int option + val max_trivial_percentage : float +end + +exception Trivial + +module Check(Conf : Config)(L : Law) = struct + let max_trivs = + int_of_float ((float Conf.num_iterations) *. + Conf.max_trivial_percentage) + + let fail_exn iter e arg = + let msg = sprintf "Test <%s> raised exception after %d tries.\nInput was %s\n Exception was %s\n" + L.desc iter (L.Arg.to_string arg) (Printexc.to_string e) + in failwith msg + + let fail_test iter arg = + let msg = sprintf "Test <%s> failed after %d tries.\nInput was %s\n" + L.desc iter (L.Arg.to_string arg) + in failwith msg + + let fail_trivial trivs n = + let msg = sprintf "Test <%s> could not be tested due to excessive trivial input. %d trivial inputs and %d non-trivial inputs were tried\n" + L.desc trivs n + in failwith msg + + let test rs = + let rec loop trivs n : unit = + if trivs >= max_trivs then fail_trivial trivs n + else if n >= Conf.num_iterations then () + else + let arg = match Conf.size_arg with + | None -> L.Arg.gen rs + | Some s -> L.Arg.gen ~size:s rs + in + try let res = + try L.law arg + with Trivial -> raise Trivial | e -> fail_exn n e arg + in + if res then loop trivs (n+1) else fail_test n arg + with Trivial -> loop (trivs+1) n + in loop 0 1 + + let desc = L.desc +end + diff --git a/src/base/quickcheck.mli b/src/base/quickcheck.mli new file mode 100644 index 0000000..e3a9219 --- /dev/null +++ b/src/base/quickcheck.mli @@ -0,0 +1,73 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Random Testing Framework + + This module implements a random testing framework based on + Claessen and Hughes's QuickCheck library for Haskell. + + *) + +exception Trivial + +module type Law = +sig + module Arg : Types.Mono.Arbitrary + (** A value of type Arg.t will be randomly generated and passed to + the law function below. *) + + val desc : string + (** Description of the test. This value is simply stored in the + result of the Check functor below for easy access by a test + driver. + *) + + val law : Arg.t -> bool + (** The function that implements the law. The function should + return [true] when the law holds for the input and [false] if + the law does not hold. It may also raise the exception + {!Trivial} if the law only trivially applies to the input, in + which case a new input will be attempted. + *) +end + +module type Config = +sig + val num_iterations : int + (** This value determines how many inputs will be passed to the + {!Law.law} function. Values that are signaled to be trivial + are not counted. + *) + + val size_arg : int option + (** This value is passed as the option size paramter to the + function {!Types.Mono.Arbitrary.gen} when generating input + for a law. + *) + + val max_trivial_percentage : float + (** This value determines how many inputs are allowed to be + classified as trivial before giving up and classifying the law + as failed. The value should be in the range \[0\.0,1\.0) + *) + +end + + +module Check : + functor (Conf : Config) -> + functor (L : Law) -> sig + val desc : string + (** A copy of the test description supplied by the Law + module *) + + val test : Random.State.t -> unit + (** The function which executes the series random tests on law + [L] *) + end diff --git a/src/base/types.ml b/src/base/types.ml new file mode 100644 index 0000000..0fea396 --- /dev/null +++ b/src/base/types.ml @@ -0,0 +1,452 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(* combinator for composing compare functions *) +let cmp2 c1 f a1 a2 = match c1 with + | 0 -> f a1 a2 + | _ -> c1 + +module Poly = struct + + module type Equatable = + sig + type 'a t + val equal : 'a t -> 'a t -> bool + end + + module type Comparable = + sig + type 'a t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val to_string : ('a -> string) -> 'a t -> string + end + + module type Hashable = + sig + include Equatable + val hash : 'a t -> int + end + + module type Arbitrary = + sig + type 'a t + val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> + Random.State.t -> 'a t + val to_string : ('a -> string) -> 'a t -> string + end + + module type ArbitraryComparable = + sig + include Arbitrary + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + end + + module ComposeComparable (A : Comparable) (B : Comparable) : + Comparable with type 'a t = 'a B.t A.t = + struct + type 'a t = 'a B.t A.t + let compare f = A.compare (B.compare f) + let to_string f = A.to_string (B.to_string f) + end + + module ComposeGen (A : Arbitrary) (B : Arbitrary) : + Arbitrary with type 'a t = 'a B.t A.t = struct + type 'a t = 'a B.t A.t + let to_string to_s t = A.to_string (B.to_string to_s) t + let gen (gen1: ?size:int -> Random.State.t -> 'a) ?size rs = + A.gen (B.gen gen1) ?size rs + end + + module ComposeGenComparable + (A : ArbitraryComparable) + (B : ArbitraryComparable) + : ArbitraryComparable with type 'a t = 'a B.t A.t = struct + include ComposeGen(A)(B) + let compare f x y = A.compare (B.compare f) x y + end + + (* This module allows you to close the Compose* functors. *) + module Close = struct + type 'a t = 'a + let to_string to_s t = to_s t + let compare cmp t1 t2 = cmp t1 t2 + end + +end + +module Mono = struct + module type Equatable = + sig + type t + val equal : t -> t -> bool + end + + module type Comparable = + sig + type t + val compare : t -> t -> int + val to_string : t -> string + end + + module type Hashable = + sig + include Equatable + val hash : t -> int + end + + module type Arbitrary = + sig + type t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + end + + module type ArbitraryComparable = + sig + include Arbitrary + val compare : t -> t -> int + end + + module ComposeComparable (P : Poly.Comparable) (M : Comparable) + : Comparable with type t = M.t P.t = + struct + type t = M.t P.t + let compare x y = P.compare M.compare x y + let to_string t = P.to_string M.to_string t + end + + module ComposeGen (P : Poly.Arbitrary) (M : Arbitrary) : + Arbitrary with type t = M.t P.t = struct + type t = M.t P.t + let to_string t = P.to_string M.to_string t + let gen ?size rs = P.gen M.gen ?size rs + end + + module ComposeGenComparable + (P : Poly.ArbitraryComparable) + (M : ArbitraryComparable) + : ArbitraryComparable with type t = M.t P.t = struct + include ComposeGen(P)(M) + let compare x y = P.compare M.compare x y + end + + module ComparablePair(M1 : Comparable)(M2 : Comparable) + : Comparable with type t = M1.t * M2.t = + struct + type t = M1.t * M2.t + let compare (x1,x2) (y1,y2) = + cmp2 (M1.compare x1 y1) M2.compare x2 y2 + + let to_string (a,b) = + Printf.sprintf "(%s, %s)" (M1.to_string a) (M2.to_string b) + end + + module Comparable3Tuple(M1 : Comparable)(M2 : Comparable)(M3 : Comparable) : + Comparable with type t = M1.t * M2.t * M3.t = + struct + type t = M1.t * M2.t * M3.t + let compare (x1,x2,x3) (y1,y2,y3) = + cmp2 (cmp2 (M1.compare x1 y1) M2.compare x2 y2) M3.compare x3 y3 + + let to_string (a,b,c) = + Printf.sprintf "(%s, %s, %s)" + (M1.to_string a) (M2.to_string b) (M3.to_string c) + end + + module GenPair(A : Arbitrary)(B : Arbitrary) : + Arbitrary with type t = A.t * B.t = + struct + type t = A.t * B.t + let gen ?size r = A.gen ?size r, B.gen ?size r + let to_string (a,b) = + Printf.sprintf "(%s, %s)" (A.to_string a) (B.to_string b) + end + + module Gen3Tuple(A : Arbitrary)(B : Arbitrary)(C : Arbitrary) : + Arbitrary with type t = A.t * B.t * C.t = + struct + type t = (A.t * B.t * C.t) + let gen ?size r = A.gen ?size r, B.gen ?size r, C.gen ?size r + let to_string (a,b,c) = + Printf.sprintf "(%s, %s, %s)" + (A.to_string a) (B.to_string b) (C.to_string c) + end + +end + +(** Base Types *) +module type Integral = sig + type t + val zero : t + val one : t + val minus_one : t + + val abs : t -> t + val neg : t -> t + + val succ : t -> t + val pred : t -> t + + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val rem : t -> t -> t + + val logand : t -> t -> t + val lognot : t -> t + + val logor : t -> t -> t + val logxor : t -> t -> t + + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + + val compare : t -> t -> int + + val of_int : int -> t + val to_int : t -> int + + val of_float : float -> t + val to_float : t -> float + + val to_string : t -> string + val of_string : string -> t +end + +module Int = struct + type t = int + let zero = 0 + let one = 1 + let minus_one = -1 + + let abs = Pervasives.abs + let neg = ( ~- ) + let succ = Pervasives.succ + let pred = Pervasives.pred + + let add = (+) + let sub = (-) + let mul = ( * ) + let div = ( / ) + let rem x y = x mod y + + let logxor x y = x lxor y + let logand x y = x land y + let lognot x = lnot x + let logor x y = x lor y + + let shift_left x y = x lsl y + let shift_right x y = x asr y + let shift_right_logical x y = x lsr y + let of_int x = x + let to_int x = x + let of_float = Pervasives.int_of_float + let to_float = Pervasives.float_of_int + let to_string = Pervasives.string_of_int + let of_string = Pervasives.int_of_string + + let compare (x:int) (y:int) = Pervasives.compare x y + let equal x y = (compare x y) = 0 + let hash x = x + let to_string x = string_of_int x + let gen ?(size=max_int) r = + let nsize = Nativeint.of_int size in + let rand = Random.State.nativeint r nsize in + Nativeint.to_int rand +end + +module Float = struct + type t = float + let compare (x:float) (y:float) = compare x y + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?(size=max_int) r = Random.State.float r (float size) + let to_string = string_of_float +end + +module Bool = struct + type t = bool + let compare (x:bool) (y:bool) = compare x y + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = Random.State.bool r + let to_string = string_of_bool +end + +module Char = struct + type t = char + let compare (x:char) (y:char) = compare x y + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?(size=256) r = Char.chr (Random.State.int r (size mod 256)) + let to_string c = String.make 1 c +end + +module Int32 = struct + include Int32 + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = Random.State.int32 r Int32.max_int +end + +module Int64 = struct + include Int64 + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = Random.State.int64 r Int64.max_int +end + +module Nativeint = struct + include Nativeint + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = Random.State.nativeint r Nativeint.max_int +end + +module Big_int = struct + include Big_int + type t = big_int + let equal x y = (compare_big_int x y) = 0 + let compare = eq_big_int + let hash x = Hashtbl.hash x + let gen ?size r = + Big_int.big_int_of_string + (Int64.to_string (Random.State.int64 r Int64.max_int)) + + let zero = zero_big_int + let one = unit_big_int + let minus_one = minus_big_int one + + let abs = abs_big_int + let neg = minus_big_int + let succ = succ_big_int + let pred = pred_big_int + + let add = add_big_int + let sub = sub_big_int + let mul = mult_big_int + let div = div_big_int + let rem = mod_big_int + +(* + let logxor = ( lxor ) + let logand = ( land ) + let lognot = ( lnot ) + let logor = ( lor ) + + let shift_left = ( lsl ) + let shift_right = ( asr ) + let shift_right_logical = ( lsr ) +*) + + let of_int x = big_int_of_int + let to_int x = int_of_big_int + let of_float f = big_int_of_string (string_of_float (floor f)) + let to_float = float_of_big_int + let to_string = string_of_big_int + let of_string = big_int_of_string + +end + +module Ratio = struct + include Ratio + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = Ratio.create_ratio (Big_int.gen r) (Big_int.gen r) +end + +module Complex = struct + include Complex + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?size r = {Complex.re = Float.gen r; im = Float.gen r} +end + +module String = struct + include String + let equal x y = (compare x y) = 0 + let hash x = Hashtbl.hash x + let gen ?(size=100) rs = + let len = (Random.State.int rs size) mod Sys.max_string_length in + let s = String.create len in + for i = 0 to (len-1) do + s.[i] <- Char.gen ~size:size rs + done; + s + let to_string x = x +end + +let _ = + let module Test1 = (Int : Integral) in + let module Test2 = (Int32 : Integral) in + let module Test3 = (Int64 : Integral) in + let module Test4 = (Nativeint : Integral) in +(* let module Test5 = (Big_int : Integral) in + missing logical ops... :-( +*) + () + + +module Option = struct + type 'a t = 'a option + + let compare cmp x y = match x,y with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some a, Some b -> cmp a b + + let equal x y = (compare Pervasives.compare x y) = 0 + + let gen (gen:?size:int -> Random.State.t -> 'a) ?size r : 'a option = + if Random.State.bool r + then None + else Some (gen ?size r) + + let to_string to_s = function + | None -> "None" + | Some x -> "Some " ^ (to_s x) +end + + +(* CR SW: There's some room for code sharing, both at the module type level and + at the functor level. First, there is a technique by which one can get + multiple interface inheritance. This would allow you to mix and match all of + the various signatures (comparable, hashable, equality, ...) to write down + an explicit signature that describes a module that meets some subset of them. + + The trick is to *not* use "t" when defining "abstract" signatures + (characterizing some aspect of behavior), and instead to use the name of the + of the behavior as the name of the type. For example, one could do: + +module type MonoEquatable = sig + type equatable + val equal : equatable -> equatable -> bool +end + +module type MonoHashable = sig + type hashable + val hash : hashable -> int +end + + Then, whenever you have a type t in some signature that you want to have + a particaular behavior, you do "include Behavior with type behavior = t". + For example, for a monotype that supports equal and hash, you could do. + +module type Z = sig + type t + include MonoEquatable with type equatable = t + include MonoHashable with type hashable = t +end + +*) + + diff --git a/src/base/types.mli b/src/base/types.mli new file mode 100644 index 0000000..c5be9d9 --- /dev/null +++ b/src/base/types.mli @@ -0,0 +1,632 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Various modules and functors used by Reins *) + +(** Signatures/functors for modules with parameterized (polymorphic) + types. *) +module Poly : +sig + module type Equatable = + sig + type 'a t + val equal : 'a t -> 'a t -> bool + end + + module type Comparable = + sig + type 'a t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val to_string : ('a -> string) -> 'a t -> string + end + + module type Hashable = + sig + include Equatable + val hash : 'a t -> int + end + + module type Arbitrary = + sig + type 'a t + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t + val to_string : ('a -> string) -> 'a t -> string + end + + module type ArbitraryComparable = + sig + include Arbitrary + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + end + + module ComposeComparable : + functor (A : Comparable) -> + functor (B : Comparable) -> + sig + type 'a t = 'a B.t A.t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val to_string : ('a -> string) -> 'a t -> string + end + + module ComposeGen : + functor (A : Arbitrary) -> + functor (B : Arbitrary) -> + sig + type 'a t = 'a B.t A.t + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t + val to_string : ('a -> string) -> 'a t -> string + end + + module ComposeGenComparable : + functor (A : ArbitraryComparable) -> + functor (B : ArbitraryComparable) -> + sig + type 'a t = 'a B.t A.t + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t + val to_string : ('a -> string) -> 'a t -> string + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + end + + (** This module can be used to "close" a series of functors to + produce a module with a parameterized type. For example, + [module CC = ComposeComparable + module L = CC(CC(List)(Option))(Close)] + creates a module with type + [type 'a t = 'a list option] + *) + module Close : + sig + type 'a t = 'a + val to_string : ('a -> 'b) -> 'a -> 'b + val compare : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c + end +end + +(** Signatures/functors for modules with unparameterized + (monomorphic) types *) +module Mono : +sig + module type Equatable = + sig + type t + val equal : t -> t -> bool + end + + module type Comparable = + sig + type t + val compare : t -> t -> int + val to_string : t -> string + end + + module type Hashable = + sig + include Equatable + val hash : t -> int + end + + module type Arbitrary = + sig + type t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + end + + module type ArbitraryComparable = + sig + include Arbitrary + val compare : t -> t -> int + end + + module ComposeComparable : + functor (P : Poly.Comparable) -> + functor (M : Comparable) -> + sig + type t = M.t P.t + val compare : t -> t -> int + val to_string : t -> string + end + + module ComposeGen : + functor (P : Poly.Arbitrary) -> + functor (M : Arbitrary) -> + sig + type t = M.t P.t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + end + + module ComposeGenComparable : + functor (P : Poly.ArbitraryComparable) -> + functor (M : ArbitraryComparable) -> + sig + type t = M.t P.t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + val compare : t -> t -> int + end + + module ComparablePair : + functor (M1 : Comparable) -> + functor (M2 : Comparable) -> + sig + type t = M1.t * M2.t + val compare : t -> t -> int + val to_string : t -> string + end + + module Comparable3Tuple : + functor (M1 : Comparable) -> + functor (M2 : Comparable) -> + functor (M3 : Comparable) -> + sig + type t = M1.t * M2.t * M3.t + val compare : t -> t -> int + val to_string : t -> string + end + + module GenPair : + functor (A : Arbitrary) -> + functor (B : Arbitrary) -> + sig + type t = A.t * B.t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + end + + module Gen3Tuple : + functor (A : Arbitrary) -> + functor (B : Arbitrary) -> + functor (C : Arbitrary) -> + sig + type t = A.t * B.t * C.t + val gen : ?size:int -> Random.State.t -> t + val to_string : t -> string + end +end + +module type Integral = +sig + type t + val zero : t + val one : t + val minus_one : t + val abs : t -> t + val neg : t -> t + val succ : t -> t + val pred : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val rem : t -> t -> t + val logand : t -> t -> t + val lognot : t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + val compare : t -> t -> int + val of_int : int -> t + val to_int : t -> int + val of_float : float -> t + val to_float : t -> float + val to_string : t -> string + val of_string : string -> t +end + +module Int : +sig + type t = int + val zero : int + val one : int + val minus_one : int + val abs : int -> int + val neg : int -> int + val succ : int -> int + val pred : int -> int + val add : int -> int -> int + val sub : int -> int -> int + val mul : int -> int -> int + val div : int -> int -> int + val rem : int -> int -> int + val logxor : int -> int -> int + val logand : int -> int -> int + val lognot : int -> int + val logor : int -> int -> int + val shift_left : int -> int -> int + val shift_right : int -> int -> int + val shift_right_logical : int -> int -> int + val of_int : 'a -> 'a + val to_int : 'a -> 'a + val of_float : float -> int + val to_float : int -> float + val of_string : string -> int + val compare : int -> int -> int + val equal : int -> int -> bool + val hash : 'a -> 'a + val to_string : int -> string + val gen : ?size:int -> Random.State.t -> int +end + +module Float : +sig + type t = float + val compare : float -> float -> int + val equal : float -> float -> bool + val hash : 'a -> int + val gen : ?size:int -> Random.State.t -> float + val to_string : float -> string +end + +module Bool : +sig + type t = bool + val compare : bool -> bool -> int + val equal : bool -> bool -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> bool + val to_string : bool -> string +end + +module Char : +sig + type t = char + val compare : char -> char -> int + val equal : char -> char -> bool + val hash : 'a -> int + val gen : ?size:int -> Random.State.t -> char + val to_string : char -> string +end + +module Int32 : +sig + val zero : int32 + val one : int32 + val minus_one : int32 + external neg : int32 -> int32 = "%int32_neg" + external add : int32 -> int32 -> int32 = "%int32_add" + external sub : int32 -> int32 -> int32 = "%int32_sub" + external mul : int32 -> int32 -> int32 = "%int32_mul" + external div : int32 -> int32 -> int32 = "%int32_div" + external rem : int32 -> int32 -> int32 = "%int32_mod" + val succ : int32 -> int32 + val pred : int32 -> int32 + val abs : int32 -> int32 + val max_int : int32 + val min_int : int32 + external logand : int32 -> int32 -> int32 = "%int32_and" + external logor : int32 -> int32 -> int32 = "%int32_or" + external logxor : int32 -> int32 -> int32 = "%int32_xor" + val lognot : int32 -> int32 + external shift_left : int32 -> int -> int32 = "%int32_lsl" + external shift_right : int32 -> int -> int32 = "%int32_asr" + external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" + external of_int : int -> int32 = "%int32_of_int" + external to_int : int32 -> int = "%int32_to_int" + external of_float : float -> int32 = "caml_int32_of_float" + external to_float : int32 -> float = "caml_int32_to_float" + external of_string : string -> int32 = "caml_int32_of_string" + val to_string : int32 -> string + external bits_of_float : float -> int32 = "caml_int32_bits_of_float" + external float_of_bits : int32 -> float = "caml_int32_float_of_bits" + type t = int32 + val compare : t -> t -> int + external format : string -> int32 -> string = "caml_int32_format" + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Int32.t +end + +module Int64 : +sig + val zero : int64 + val one : int64 + val minus_one : int64 + external neg : int64 -> int64 = "%int64_neg" + external add : int64 -> int64 -> int64 = "%int64_add" + external sub : int64 -> int64 -> int64 = "%int64_sub" + external mul : int64 -> int64 -> int64 = "%int64_mul" + external div : int64 -> int64 -> int64 = "%int64_div" + external rem : int64 -> int64 -> int64 = "%int64_mod" + val succ : int64 -> int64 + val pred : int64 -> int64 + val abs : int64 -> int64 + val max_int : int64 + val min_int : int64 + external logand : int64 -> int64 -> int64 = "%int64_and" + external logor : int64 -> int64 -> int64 = "%int64_or" + external logxor : int64 -> int64 -> int64 = "%int64_xor" + val lognot : int64 -> int64 + external shift_left : int64 -> int -> int64 = "%int64_lsl" + external shift_right : int64 -> int -> int64 = "%int64_asr" + external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" + external of_int : int -> int64 = "%int64_of_int" + external to_int : int64 -> int = "%int64_to_int" + external of_float : float -> int64 = "caml_int64_of_float" + external to_float : int64 -> float = "caml_int64_to_float" + external of_int32 : int32 -> int64 = "%int64_of_int32" + external to_int32 : int64 -> int32 = "%int64_to_int32" + external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" + external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" + external of_string : string -> int64 = "caml_int64_of_string" + val to_string : int64 -> string + external bits_of_float : float -> int64 = "caml_int64_bits_of_float" + external float_of_bits : int64 -> float = "caml_int64_float_of_bits" + type t = int64 + val compare : t -> t -> int + external format : string -> int64 -> string = "caml_int64_format" + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Int64.t +end + +module Nativeint : +sig + val zero : nativeint + val one : nativeint + val minus_one : nativeint + external neg : nativeint -> nativeint = "%nativeint_neg" + external add : nativeint -> nativeint -> nativeint = "%nativeint_add" + external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" + external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" + external div : nativeint -> nativeint -> nativeint = "%nativeint_div" + external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" + val succ : nativeint -> nativeint + val pred : nativeint -> nativeint + val abs : nativeint -> nativeint + val size : int + val max_int : nativeint + val min_int : nativeint + external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" + external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" + external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" + val lognot : nativeint -> nativeint + external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" + external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" + external shift_right_logical : nativeint -> int -> nativeint + = "%nativeint_lsr" + external of_int : int -> nativeint = "%nativeint_of_int" + external to_int : nativeint -> int = "%nativeint_to_int" + external of_float : float -> nativeint = "caml_nativeint_of_float" + external to_float : nativeint -> float = "caml_nativeint_to_float" + external of_int32 : int32 -> nativeint = "%nativeint_of_int32" + external to_int32 : nativeint -> int32 = "%nativeint_to_int32" + external of_string : string -> nativeint = "caml_nativeint_of_string" + val to_string : nativeint -> string + type t = nativeint + val compare : t -> t -> int + external format : string -> nativeint -> string = "caml_nativeint_format" + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Nativeint.t +end + +module Big_int : +sig + type big_int = Big_int.big_int + val zero_big_int : big_int + val unit_big_int : big_int + val minus_big_int : big_int -> big_int + val abs_big_int : big_int -> big_int + val add_big_int : big_int -> big_int -> big_int + val succ_big_int : big_int -> big_int + val add_int_big_int : int -> big_int -> big_int + val sub_big_int : big_int -> big_int -> big_int + val pred_big_int : big_int -> big_int + val mult_big_int : big_int -> big_int -> big_int + val mult_int_big_int : int -> big_int -> big_int + val square_big_int : big_int -> big_int + val sqrt_big_int : big_int -> big_int + val quomod_big_int : big_int -> big_int -> big_int * big_int + val div_big_int : big_int -> big_int -> big_int + val mod_big_int : big_int -> big_int -> big_int + val gcd_big_int : big_int -> big_int -> big_int + val power_int_positive_int : int -> int -> big_int + val power_big_int_positive_int : big_int -> int -> big_int + val power_int_positive_big_int : int -> big_int -> big_int + val power_big_int_positive_big_int : big_int -> big_int -> big_int + val sign_big_int : big_int -> int + val compare_big_int : big_int -> big_int -> int + val eq_big_int : big_int -> big_int -> bool + val le_big_int : big_int -> big_int -> bool + val ge_big_int : big_int -> big_int -> bool + val lt_big_int : big_int -> big_int -> bool + val gt_big_int : big_int -> big_int -> bool + val max_big_int : big_int -> big_int -> big_int + val min_big_int : big_int -> big_int -> big_int + val num_digits_big_int : big_int -> int + val string_of_big_int : big_int -> string + val big_int_of_string : string -> big_int + val big_int_of_int : int -> big_int + val is_int_big_int : big_int -> bool + val int_of_big_int : big_int -> int + val float_of_big_int : big_int -> float + val nat_of_big_int : big_int -> Nat.nat + val big_int_of_nat : Nat.nat -> big_int + val base_power_big_int : int -> int -> big_int -> big_int + val sys_big_int_of_string : string -> int -> int -> big_int + val round_futur_last_digit : string -> int -> int -> bool + val approx_big_int : int -> big_int -> string + type t = big_int + val equal : big_int -> big_int -> bool + val compare : big_int -> big_int -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Big_int.big_int + val zero : big_int + val one : big_int + val minus_one : big_int + val abs : big_int -> big_int + val neg : big_int -> big_int + val succ : big_int -> big_int + val pred : big_int -> big_int + val add : big_int -> big_int -> big_int + val sub : big_int -> big_int -> big_int + val mul : big_int -> big_int -> big_int + val div : big_int -> big_int -> big_int + val rem : big_int -> big_int -> big_int + val of_int : 'a -> int -> big_int + val to_int : 'a -> big_int -> int + val of_float : float -> big_int + val to_float : big_int -> float + val to_string : big_int -> string + val of_string : string -> big_int +end + +module Ratio : +sig + type ratio = Ratio.ratio + val null_denominator : ratio -> bool + val numerator_ratio : ratio -> Big_int.big_int + val denominator_ratio : ratio -> Big_int.big_int + val sign_ratio : ratio -> int + val normalize_ratio : ratio -> ratio + val cautious_normalize_ratio : ratio -> ratio + val cautious_normalize_ratio_when_printing : ratio -> ratio + val create_ratio : Big_int.big_int -> Big_int.big_int -> ratio + val create_normalized_ratio : Big_int.big_int -> Big_int.big_int -> ratio + val is_normalized_ratio : ratio -> bool + val report_sign_ratio : ratio -> Big_int.big_int -> Big_int.big_int + val abs_ratio : ratio -> ratio + val is_integer_ratio : ratio -> bool + val add_ratio : ratio -> ratio -> ratio + val minus_ratio : ratio -> ratio + val add_int_ratio : int -> ratio -> ratio + val add_big_int_ratio : Big_int.big_int -> ratio -> ratio + val sub_ratio : ratio -> ratio -> ratio + val mult_ratio : ratio -> ratio -> ratio + val mult_int_ratio : int -> ratio -> ratio + val mult_big_int_ratio : Big_int.big_int -> ratio -> ratio + val square_ratio : ratio -> ratio + val inverse_ratio : ratio -> ratio + val div_ratio : ratio -> ratio -> ratio + val integer_ratio : ratio -> Big_int.big_int + val floor_ratio : ratio -> Big_int.big_int + val round_ratio : ratio -> Big_int.big_int + val ceiling_ratio : ratio -> Big_int.big_int + val eq_ratio : ratio -> ratio -> bool + val compare_ratio : ratio -> ratio -> int + val lt_ratio : ratio -> ratio -> bool + val le_ratio : ratio -> ratio -> bool + val gt_ratio : ratio -> ratio -> bool + val ge_ratio : ratio -> ratio -> bool + val max_ratio : ratio -> ratio -> ratio + val min_ratio : ratio -> ratio -> ratio + val eq_big_int_ratio : Big_int.big_int -> ratio -> bool + val compare_big_int_ratio : Big_int.big_int -> ratio -> int + val lt_big_int_ratio : Big_int.big_int -> ratio -> bool + val le_big_int_ratio : Big_int.big_int -> ratio -> bool + val gt_big_int_ratio : Big_int.big_int -> ratio -> bool + val ge_big_int_ratio : Big_int.big_int -> ratio -> bool + val int_of_ratio : ratio -> int + val ratio_of_int : int -> ratio + val ratio_of_nat : Nat.nat -> ratio + val nat_of_ratio : ratio -> Nat.nat + val ratio_of_big_int : Big_int.big_int -> ratio + val big_int_of_ratio : ratio -> Big_int.big_int + val div_int_ratio : int -> ratio -> ratio + val div_ratio_int : ratio -> int -> ratio + val div_big_int_ratio : Big_int.big_int -> ratio -> ratio + val div_ratio_big_int : ratio -> Big_int.big_int -> ratio + val approx_ratio_fix : int -> ratio -> string + val approx_ratio_exp : int -> ratio -> string + val float_of_rational_string : ratio -> string + val string_of_ratio : ratio -> string + val ratio_of_string : string -> ratio + val float_of_ratio : ratio -> float + val power_ratio_positive_int : ratio -> int -> ratio + val power_ratio_positive_big_int : ratio -> Big_int.big_int -> ratio + val equal : 'a -> 'a -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Ratio.ratio +end + +module Complex : +sig + type t = Complex.t = { re : float; im : float; } + val zero : t + val one : t + val i : t + val neg : t -> t + val conj : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val inv : t -> t + val div : t -> t -> t + val sqrt : t -> t + val norm2 : t -> float + val norm : t -> float + val arg : t -> float + val polar : float -> float -> t + val exp : t -> t + val log : t -> t + val pow : t -> t -> t + val equal : 'a -> 'a -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Complex.t +end + +module String : +sig + external length : string -> int = "%string_length" + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> int -> int -> string + val fill : string -> int -> int -> char -> unit + val blit : string -> int -> string -> int -> int -> unit + val concat : string -> string list -> string + val iter : (char -> unit) -> string -> unit + val escaped : string -> string + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t = string + val compare : t -> t -> int + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + external unsafe_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + external unsafe_fill : string -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:int -> Random.State.t -> string + val to_string : 'a -> 'a +end + +module Option : +sig + type 'a t = 'a option + val compare : ('a -> 'b -> int) -> 'a option -> 'b option -> int + val equal : 'a option -> 'a option -> bool + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a option + val to_string : ('a -> string) -> 'a option -> string +end diff --git a/src/heap/OMakefile b/src/heap/OMakefile new file mode 100644 index 0000000..cec3761 --- /dev/null +++ b/src/heap/OMakefile @@ -0,0 +1,7 @@ + +OCAMLINCLUDES += ../base +FILES[] += + heap/binomialHeap + heap/skewBinomialHeap + heap/heaps +# heap/soft diff --git a/src/heap/binomialHeap.ml b/src/heap/binomialHeap.ml new file mode 100644 index 0000000..c9e4d18 --- /dev/null +++ b/src/heap/binomialHeap.ml @@ -0,0 +1,121 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module Base = struct + + type 'a tree = Node of int * 'a * 'a tree list + (* An element of type 'a tree is a binomial tree where the + children are kept in a pre-order traversal with respect to + their comparison function. + *) + + type 'a binheap = 'a tree list + (* A heap is a sparse collection of trees kept in increasing + order of rank. *) + + let empty = [] + + let is_empty = function [] -> true | _ -> false + + let singleton x = [Node(0,x,[])] + + let link cmp t1 t2 = match t1,t2 with + | Node(r,x1,c1), Node(_,x2,c2) -> + if cmp x1 x2 <= 0 + then Node(r+1,x1,t2::c1) + else Node(r+1,x2,t1::c2) + + let rank = function + | Node(r,_,_) -> r + + (* find a tree with the same rank and link them *) + let rec insTree cmp t1 h = match h with + | [] -> [t1] + | t2::rest as ts -> + if rank t1 < rank t2 + then t1::ts + else insTree cmp (link cmp t1 t2) rest + + let insert cmp x h = insTree cmp (Node(0,x,[])) h + + let rec merge cmp h1 h2 = match h1,h2 with + | [], h | h, [] -> h + | t1::t1s, t2::t2s -> + if rank t1 < rank t2 then t1::(merge cmp t1s (t2::t2s)) + else if rank t2 < rank t1 then t2::(merge cmp (t1::t1s) t2s) + else insTree cmp (link cmp t1 t2) (merge cmp t1s t2s) + + let root = function Node(_,v,_) -> v + + let rec find_min cmp = function + | [] -> raise Not_found + | t::[] -> root t + | t::ts -> + let x = root t in + let y = find_min cmp ts in + if cmp x y <= 0 then x else y + + let delete_min cmp = function + | [] -> raise Not_found + | ts -> + let rec get_min = function + | [] -> assert false + | t::[] -> t, [] + | t::ts -> + let t',ts' = get_min ts in + if cmp (root t) (root t') <= 0 + then (t,ts) + else (t', t::ts') + in + let Node(_,t,ts1),ts2 = get_min ts in + merge cmp (List.rev ts1) ts2 + + let to_string cmp t = "" +end + +module MonoHeap(C : Types.Mono.Comparable) = struct + include Base + type elt = C.t + type 'a elt_ = elt + type t = C.t binheap + type 'a heap = t + + let insert x t = insert C.compare x t + let merge t1 t2 = merge C.compare t1 t2 + let find_min t = find_min C.compare t + let delete_min t = delete_min C.compare t + + let to_string t = to_string C.compare t +end + +module GenHeap(C : Types.Mono.ArbitraryComparable) = struct + include MonoHeap(C) + let gen ?(size=50) rs = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (insert (C.gen rs) t) + in + loop num empty +end + +module PolyHeap = struct + include Base + type 'a elt_ = 'a + type 'a t = 'a binheap + type 'a heap = 'a t + + let insert x t = insert Pervasives.compare x t + let merge t1 t2 = merge Pervasives.compare t1 t2 + let find_min t = find_min Pervasives.compare t + let delete_min t = delete_min Pervasives.compare t + +end diff --git a/src/heap/binomialHeap.mli b/src/heap/binomialHeap.mli new file mode 100644 index 0000000..6cf2ec2 --- /dev/null +++ b/src/heap/binomialHeap.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Binomial Heap. All operations are O(log n) time. *) + +module MonoHeap : Heaps.MonoHeapSigFn + +module GenHeap : Heaps.GenHeapSigFn + +module PolyHeap : Heaps.PolyHeapSig diff --git a/src/heap/heaps.ml b/src/heap/heaps.ml new file mode 100644 index 0000000..70c87bd --- /dev/null +++ b/src/heap/heaps.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type Heap_ = +sig + + type 'a elt_ + + type 'a heap + + val empty : 'a heap + + val is_empty : 'a heap -> bool + + val singleton : 'a elt_ -> 'a heap + + val insert : 'a elt_ -> 'a heap -> 'a heap + + val merge : 'a heap -> 'a heap -> 'a heap + + val find_min : 'a heap -> 'a elt_ + + val delete_min : 'a heap -> 'a heap + +end + +module type MonoHeapSig = sig + type t + type elt + + include Heap_ with type 'a elt_ = elt + and type 'a heap = t + + val to_string : 'a heap -> string +end + +module type MonoHeapSigFn = + functor(C : Types.Mono.Comparable) -> + MonoHeapSig with type elt = C.t + +module type GenHeapSig = sig + include MonoHeapSig + val gen : ?size:int -> Random.State.t -> t +end + +module type GenHeapSigFn = + functor(C : Types.Mono.ArbitraryComparable) -> + GenHeapSig with type elt = C.t + +module type PolyHeapSig = sig + type 'a t + + include Heap_ with type 'a elt_ = 'a + and type 'a heap = 'a t + + val to_string : ('a -> string) -> 'a heap -> string +end diff --git a/src/heap/heaps.mli b/src/heap/heaps.mli new file mode 100644 index 0000000..98dbe27 --- /dev/null +++ b/src/heap/heaps.mli @@ -0,0 +1,66 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Abstract signature for Heaps *) + +module type Heap_ = +sig + + type 'a elt_ + + type 'a heap + + val empty : 'a heap + + val is_empty : 'a heap -> bool + + val singleton : 'a elt_ -> 'a heap + + val insert : 'a elt_ -> 'a heap -> 'a heap + + val merge : 'a heap -> 'a heap -> 'a heap + + val find_min : 'a heap -> 'a elt_ + + val delete_min : 'a heap -> 'a heap + +end + +module type MonoHeapSig = sig + type t + type elt + + include Heap_ with type 'a elt_ = elt + and type 'a heap = t + + val to_string : 'a heap -> string +end + +module type MonoHeapSigFn = + functor(C : Types.Mono.Comparable) -> + MonoHeapSig with type elt = C.t + +module type GenHeapSig = sig + include MonoHeapSig + val gen : ?size:int -> Random.State.t -> t +end + +module type GenHeapSigFn = + functor(C : Types.Mono.ArbitraryComparable) -> + GenHeapSig with type elt = C.t + +module type PolyHeapSig = sig + type 'a t + + include Heap_ with type 'a elt_ = 'a + and type 'a heap = 'a t + + val to_string : ('a -> string) -> 'a heap -> string +end + diff --git a/src/heap/skewBinomialHeap.ml b/src/heap/skewBinomialHeap.ml new file mode 100644 index 0000000..44114ad --- /dev/null +++ b/src/heap/skewBinomialHeap.ml @@ -0,0 +1,134 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module Base = struct + type 'a tree = Node of int * 'a * 'a list * 'a tree list + type 'a skewheap = 'a tree list + + let empty = [] + + let is_empty = function [] -> true | _ -> false + + let rank (Node(r,x,xs,c)) = r + let root (Node(r,x,xs,c)) = x + + let link cmp (Node(r,x1,xs1,c1) as t1) (Node(_,x2,xs2,c2) as t2) = + if cmp x1 x2 <= 0 + then Node(r+1,x1,xs1,t2::c1) + else Node(r+1,x2,xs2,t1::c2) + + let skew_link cmp x t1 t2 = + let Node(r,y,ys,c) = link cmp t1 t2 in + if cmp x y <= 0 + then Node(r,x,y::ys,c) + else Node(r,y,x::ys,c) + + let rec insTree cmp t1 t = match t with + | [] -> [t1] + | t2::ts -> + if rank t1 < rank t2 + then t1::t2::ts + else insTree cmp (link cmp t1 t2) ts + + let rec mergeTrees cmp tl1 tl2 = match tl1,tl2 with + | _,[] -> tl1 + | [],_ -> tl2 + | t1::ts1, t2::ts2 -> + if rank t1 < rank t2 then t1::(mergeTrees cmp ts1 (t2::ts2)) + else if rank t2 < rank t1 then t2::(mergeTrees cmp (t1::ts1) ts2) + else insTree cmp (link cmp t1 t2) (mergeTrees cmp ts1 ts2) + + let normalize cmp = function + | [] -> [] + | t::ts -> insTree cmp t ts + + let insert cmp x ts = match ts with + | t1::t2::rest -> + if rank t1 = rank t2 + then (skew_link cmp x t1 t2) :: rest + else Node(0,x,[],[])::ts + | _ -> Node(0,x,[],[])::ts + + let singleton x = [Node(0,x,[],[])] + + + let merge cmp ts1 ts2 = mergeTrees cmp (normalize cmp ts1) (normalize cmp ts2) + + let rec find_min cmp = function + | [] -> raise Not_found + | [t] -> root t + | t::ts -> + let x = root t in + let y = find_min cmp ts in + if cmp x y <= 0 then x else y + + let delete_min cmp = function + | [] -> failwith "SkewBinomial:delete_min" + | ts -> + let rec get_min = function + | [] -> assert false + | [t] -> t,[] + | t::ts -> + let t',ts' = get_min ts in + if cmp (root t) (root t') <= 0 + then t,ts + else t', (t::ts') + in + let Node(_,x,xs,c),ts' = get_min ts in + let rec insert_all t1 t2 = match t1 with + | [] -> t2 + | x::xs -> insert_all xs (insert cmp x t2) + in + insert_all xs (mergeTrees cmp (List.rev c) (normalize cmp ts')) + + let to_string cmp t = "" +end + +module MonoHeap (C : Types.Mono.Comparable) = struct + include Base + type elt = C.t + type 'a elt_ = elt + type t = C.t skewheap + type 'a heap = t + + let insert x t = insert C.compare x t + let merge t1 t2 = merge C.compare t1 t2 + let find_min t = find_min C.compare t + let delete_min t = delete_min C.compare t + let to_string t = to_string C.compare t + +end + +module GenHeap (C : Types.Mono.ArbitraryComparable) = struct + include MonoHeap(C) + let gen ?(size=50) rs = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (insert (C.gen rs) t) + in + loop num empty +end + +module PolyHeap = struct + include Base + + type 'a elt_ = 'a + type 'a t = 'a skewheap + type 'a heap = 'a skewheap + + let insert x t = insert Pervasives.compare x t + let merge t1 t2 = merge Pervasives.compare t1 t2 + let find_min t = find_min Pervasives.compare t + let delete_min t = delete_min Pervasives.compare t + let to_string t = to_string t + +end diff --git a/src/heap/skewBinomialHeap.mli b/src/heap/skewBinomialHeap.mli new file mode 100644 index 0000000..35a87ba --- /dev/null +++ b/src/heap/skewBinomialHeap.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Skew Binomial Heap. O(1) insert, O(log n) rest *) + +module MonoHeap : Heaps.MonoHeapSigFn + +module GenHeap : Heaps.GenHeapSigFn + +module PolyHeap : Heaps.PolyHeapSig diff --git a/src/iterator/OMakefile b/src/iterator/OMakefile new file mode 100644 index 0000000..58fd222 --- /dev/null +++ b/src/iterator/OMakefile @@ -0,0 +1,8 @@ + +OCAMLINCLUDES += ../base ../set ../map ../list + +FILES[] += + iterator/listIterator + iterator/treeSetIterator + iterator/iterator + iterator/iteratorMixin diff --git a/src/iterator/iterator.ml b/src/iterator/iterator.ml new file mode 100644 index 0000000..f44cca6 --- /dev/null +++ b/src/iterator/iterator.ml @@ -0,0 +1,48 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type S = sig + + type 'a t + type 'a elt + type 'a cursor + type 'a collection + + type direction + + type 'a traversal = + | Traverse_All + | Traverse_If of ('a -> bool) + | Traverse_While of ('a -> bool) + + + val create : direction -> 'a elt traversal -> 'a collection -> 'a t + val from_cursor : direction -> 'a elt traversal -> 'a cursor -> 'a t + + val value : 'a t -> 'a elt option + val get_value : 'a t -> 'a elt + + val at_end : 'a t -> bool + val at_beg : 'a t -> bool + + val has_next : 'a t -> bool + val next : 'a t -> 'a t + + val has_prev : 'a t -> bool + val prev : 'a t -> 'a t + + val goto_beg : 'a t -> 'a t + val goto_end : 'a t -> 'a t + + val flip : 'a t -> 'a t + + val iter : ('a elt -> unit) -> 'a t -> unit + val fold : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a + +end diff --git a/src/iterator/iterator.mli b/src/iterator/iterator.mli new file mode 100644 index 0000000..f37648a --- /dev/null +++ b/src/iterator/iterator.mli @@ -0,0 +1,122 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(* CR SW: It seems pointless to have both and ml and an mli for a definition of + a module type. I'd just have the ml. +*) +(** The signature for an iterator over an arbitrary collection *) +module type S = sig + + type 'a t + (** The type of iterators. An iterator serves as a pointer into + the middle of a collection. When possible, it always points + to a valid element in the collection (skipping over any + intermediate nodes that hold no value. *) + + type 'a elt + (** The type of elements in the collection. *) + + type 'a cursor + (** The type of the cursor that points into the collection *) + + type 'a collection + (** The type of the collection *) + + type direction + (** A type which guides the order of the traversal. Different + collections may support different directions. *) + + type 'a traversal = + | Traverse_All + (** [Traverse_All] will visit every element in the collection. *) + | Traverse_If of ('a -> bool) + (** [Traverse_If f] will traverse only those elements for + which [f] returns true. *) + | Traverse_While of ('a -> bool) + (** [Traverse_While f] will traverse elements as long as [f] + is true. *) + (** This type defines the traversal strategy. It determines + which elements will be visited by the iterator.*) + + val create : direction -> 'a elt traversal -> 'a collection -> 'a t + (** [create dir trav col] Create an iterator for the collection + [col] using the direction and traversal given. *) + + val from_cursor : direction -> 'a elt traversal -> 'a cursor -> 'a t + (** [from_cursor dir trav curs] Create an iterator for the + collection starting at the cursor [curs]. The cursor need not + point to the beginning of the collection. If it does point to + an element, then this element will be the first element + visited by the iterator. *) + + val value : 'a t -> 'a elt option + (** Return the element currently pointed to by the iterator. This + will return [None] only when the iterator has reached the end + of the collection. *) + + val get_value : 'a t -> 'a elt + (** Similar to {!Iterator.S.value} except it throws the exception [Failure + "get_value"] if the iterator has reached the end of the + collection . *) + + val at_end : 'a t -> bool + (** Returns true if the iterator has reached the end of the + collection as governed by the current traversal strategy. *) + + val at_beg : 'a t -> bool + (** Returns true if the iterator is at the beginning of the + collection as governed by the current traversal strategy. + This is equivalent to {!Iterator.S.has_prev}. *) + + val has_next : 'a t -> bool + (** Returns true if there is another element in the traversal + after the current element. *) + + val next : 'a t -> 'a t + (** Advances the iterator to the next element in the collection. + If the iterator is at the end of the collection, it raises + [Failure "next"]. + *) + + val has_prev : 'a t -> bool + (** Returns true if there is another element that occurs before + the current element. Equivalent to {!Iterator.S.at_beg}. *) + + val prev : 'a t -> 'a t + (** Advances the iterator to the previous element in the + collection. If the iterator is at the beginning of the + collection, it raises [Failure "prev"]. *) + + val goto_beg : 'a t -> 'a t + (** Advance the iterator to the beginning of the collection as + governed by the traversal strategy *) + + val goto_end : 'a t -> 'a t + (** Advance the iterator to the end of the collection as governed + by the traversal strategy *) + + val flip : 'a t -> 'a t + (** Reverse the direction of the iterator. All elements that were + previously reachable by [next] are now reachable by [prev] and + vice versa. *) + + val iter : ('a elt -> unit) -> 'a t -> unit + (** [iter f t] Apply [f] to each element in the collection that + satisfies the traversal strategy. If the iterator is not at + the beginning of the collection, the elements reachable by + {!Iterator.S.prev} will not be visited. *) + + val fold : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in the collection that satisfies the + traversal strategy. If the iterator is not at the beginning + of the collection, the elements reachable by + {!Iterator.S.prev} will not be visited. *) + +end diff --git a/src/iterator/iteratorMixin.ml b/src/iterator/iteratorMixin.ml new file mode 100644 index 0000000..b8b6a93 --- /dev/null +++ b/src/iterator/iteratorMixin.ml @@ -0,0 +1,149 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +module type PartIterator = sig + type 'a elt + type 'a cursor + type direction + + val has_curs_value : 'a cursor -> bool + val get_curs_value : 'a cursor -> 'a elt + val has_more_elements : direction -> 'a cursor -> bool + val move_cursor_next_element : direction -> 'a cursor -> 'a cursor + val flip_dir : direction -> direction + +end + +module Mixin(IT : PartIterator) (* CR SW: add result signature *) = struct + + type 'a traversal = + | Traverse_All + | Traverse_If of ('a -> bool) + | Traverse_While of ('a -> bool) + + type 'a t = { + curs : 'a IT.cursor; + dir : IT.direction; + trav : 'a IT.elt traversal; + next : 'a t option Lazy.t; + prev : 'a t option Lazy.t; + } + + (* This is the main work horse of the module. It serves to + simultaneously check if the iterator has reached the end (returns + [None]) and move the iterator to the next element (retruns [Some + it]). This is to minimize duplicated work between calls to + [at_end] and [next] (and [at_beg]/[prev]). This is also the + thunk that is stored in the [next] and [prev] fields of the + iterator record, so it must not (recursively) force those + values. *) + let rec goto_next it = + (* Check if the underlying collection has more elements *) + if not (IT.has_more_elements it.dir it.curs) then None + else match it.trav with + | Traverse_All -> Some (move_one it) + | Traverse_If f -> + (* We are at the end only if f returns false for every + element in the remainder of the collection. *) + let it' = move_one it in + if f (IT.get_curs_value it'.curs) + then Some it' (* found an element where f is true *) + else goto_next it' (* check the next element *) + | Traverse_While f -> + (* We are at the end as soon as the condition returns false + on any element. We don't have to scan to the end of the + list in this case. *) + if not (IT.has_curs_value it.curs) + then goto_next (move_one it) + else if f (IT.get_curs_value it.curs) + then Some (move_one it) + else None + + and move_one it = + let curs' = IT.move_cursor_next_element it.dir it.curs in + set_curs curs' it + + and reset_next it = + let rec t = {it with + next = lazy (goto_next t); + prev = lazy (goto_next {t with dir=IT.flip_dir it.dir});} + in t + + and set_dir d it = reset_next {it with dir=d} + and set_curs c it = reset_next {it with curs=c} + + let flip t = set_dir (IT.flip_dir t.dir) t + + let has_next it = match Lazy.force it.next with + | None -> false + | _ -> true + + let has_prev it = match Lazy.force it.prev with + | None -> false + | _ -> true + + let rec next it = match Lazy.force it.next with + | None -> failwith "next" + | Some it' -> it' + + let rec prev it = match Lazy.force it.next with + | None -> failwith "prev" + | Some it' -> it' + + let at_end t = + not (has_next t) && not (IT.has_curs_value t.curs) + + let at_beg = has_prev + + let rec goto_beg t = + if at_beg t then t + else goto_beg (prev t) + + let rec goto_end t = + if at_end t then t + else goto_end (next t) + + let from_cursor dir trav curs = + let t = + reset_next + {dir = dir; trav = trav; curs = curs; + prev = lazy None; + next = lazy None; + } + in + match trav with + | Traverse_While f -> + (* Check to see if f is false for the first element and if so + return an iterator that is always at_end. *) + if IT.has_curs_value curs && not (f (IT.get_curs_value curs)) then + {dir = dir; trav = trav; curs = curs; + prev = lazy None; next = lazy None} + else t + | _ -> + if IT.has_curs_value curs then t + else if at_end t then t + else next t (* move the cursor to the first value *) + + let rec fold f acc it = + let acc = + if at_end it + then acc + else f acc (IT.get_curs_value it.curs) + in + if has_next it + then fold f acc (next it) + else acc + + let iter f it = fold (fun () -> f) () it + + let get_value t = try IT.get_curs_value t.curs with _ -> failwith "get_value" + let value t = try Some (get_value t) with _ -> None + +end diff --git a/src/iterator/listIterator.ml b/src/iterator/listIterator.ml new file mode 100644 index 0000000..183e45b --- /dev/null +++ b/src/iterator/listIterator.ml @@ -0,0 +1,77 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type S = sig + + type direction_ = + | Left_Right + | Right_Left + + include Iterator.S with type direction = direction_ + +end + +module Base(I : ListCursor.S) = struct + type 'a elt = 'a + type 'a cursor = 'a I.cursor + type 'a collection = 'a I.list_ + + type direction_ = + | Left_Right + | Right_Left + + type direction = direction_ + + let flip_dir = function + | Right_Left -> Left_Right + | Left_Right -> Right_Left + + let has_curs_value curs = match I.value curs with + | None -> false + | Some _ -> true + + let get_curs_value curs = match I.value curs with + | None -> assert false + | Some x -> x + + let has_more_elements dir curs = match dir with + | Right_Left -> not (I.at_front curs) + | Left_Right -> not (I.at_back curs) + + let move_cursor_next_element dir curs = match dir with + | Right_Left -> I.move_prev curs + | Left_Right -> I.move_next curs + +end + + +module Make(I : ListCursor.S) + : S with type 'a collection = 'a I.list_ + and type 'a cursor = 'a I.cursor + and type 'a elt = 'a += struct + + (* Can't include the Base code in this module (and make it a module + rec) since the type checker does not support instantiating + recursive functors. It gives "Cannot safely evaluate the + definition of the recursively-defined module" *) + + include Base(I) + include IteratorMixin.Mixin(Base(I)) + + let create dir trav l = from_cursor dir trav (I.to_cursor l) + +end + +module From_List(L : Lists.ListSig) + : S with type 'a elt = 'a + and type 'a cursor = 'a ListCursor.Make(L).cursor + and type 'a collection = 'a L.t + = Make(ListCursor.Make(L)) + diff --git a/src/iterator/listIterator.mli b/src/iterator/listIterator.mli new file mode 100644 index 0000000..82d87bd --- /dev/null +++ b/src/iterator/listIterator.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** The signature for an iterator over a List. *) +module type S = +sig + + (** List iterators support only two directions. [Left_Right] + iterates through the list in the forward direction, visiting the + head of the list before the tail. [Right_Left] is the opposite. + It iterates through all elements in the tail before visiting the + head. *) + type direction_ = + | Left_Right + | Right_Left + + include Iterator.S with type direction = direction_ +end + +(** Create a list iterator from an arbitrary cursor type *) +module Make : + functor (I : ListCursor.S) -> + S with type 'a collection = 'a I.list_ + and type 'a cursor = 'a I.cursor + and type 'a elt = 'a + +(** Create a list iterator for the list [L] using the standard + List_Cursor interface for the cursor. *) +module From_List : + functor (L : Lists.ListSig) -> + S with type 'a collection = 'a L.t + and type 'a elt = 'a + and type 'a cursor = 'a ListCursor.Make(L).cursor + + + diff --git a/src/iterator/treeSetIterator.ml b/src/iterator/treeSetIterator.ml new file mode 100644 index 0000000..cf014b0 --- /dev/null +++ b/src/iterator/treeSetIterator.ml @@ -0,0 +1,152 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(* CR SW: again, the capitalization of the filename seems weird. Why is + "tree" lowercase but "Iterator" uppercase? *) + +module type S = sig + type ordering = + | PreOrder + | InOrder + | PostOrder + + type direction_ = + | Ascending of ordering + | Descending of ordering + + include Iterator.S with type direction = direction_ + +end + +module Base(T : Sets.Set_) = struct + type 'a elt = 'a T.elt_ + type 'a cursor = 'a T.cursor_ + type 'a collection = 'a T.set + + type ordering = + | PreOrder (* root, left, right *) + | InOrder (* left, root, right *) + | PostOrder (* left, right, root *) + + type direction_ = + | Ascending of ordering + | Descending of ordering + + type direction = direction_ + + (* move to the bottom, left most node in the tree*) + let rec move_bottom_left curs = + if T.at_left curs then curs + else move_bottom_left (T.move_down_left curs) + + (* move to the bottom, right most node in the tree*) + let rec move_bottom_right curs = + if T.at_right curs then curs + else move_bottom_right (T.move_down_right curs) + + (* walk up the tree looking for the last branch where we went left + *) + let rec find_left curs = + if T.at_top curs then raise Exit + else if T.went_left curs then curs + else find_left (T.move_up curs) + + (* walk up the tree looking for the last branch where we went + right *) + let rec find_right curs = + if T.at_top curs then raise Exit + else if T.went_right curs then curs + else find_right (T.move_up curs) + + let rec move_inorder curs = (* left root right *) + if T.at_right curs then T.move_up (find_left curs) + else move_bottom_left (T.move_down_right curs) + + let rec move_inorder_rev curs = (* right root left *) + if T.at_left curs then T.move_up (find_right curs) + else move_bottom_right (T.move_down_left curs) + + let rec move_preorder curs = (* root left right *) + if T.at_left curs + then T.move_down_right (T.move_up (find_left curs)) + else T.move_down_left curs + + let rec move_preorder_rev curs = (* right left root *) + if T.went_right curs + then move_bottom_right (T.move_down_left (T.move_up curs)) + else if T.went_left curs then T.move_up curs + else raise Exit + + let rec move_postorder curs = (* left right root *) + if T.went_left curs + then move_bottom_left (T.move_down_right (T.move_up curs)) + else if T.went_right curs then T.move_up curs + else raise Exit + + let rec move_postorder_rev curs = (* root right left *) + if T.at_right curs + then T.move_down_left (T.move_up (find_right curs)) + else T.move_down_right curs + + let rec move_cursor_next_element dir curs = + let curs = match dir with + | Ascending PreOrder -> move_preorder curs + | Ascending InOrder -> move_inorder curs + | Ascending PostOrder -> move_postorder curs + | Descending PreOrder -> move_preorder_rev curs + | Descending InOrder -> move_inorder_rev curs + | Descending PostOrder -> move_postorder_rev curs + in + if T.has_value curs then curs + else move_cursor_next_element dir curs + + let has_more_elements dir curs = + try ignore(move_cursor_next_element dir curs); true + with Exit -> false + + let flip_dir = function + | Ascending PreOrder -> Descending PostOrder + | Ascending InOrder -> Descending InOrder + | Ascending PostOrder -> Descending PreOrder + | Descending PreOrder -> Ascending PostOrder + | Descending InOrder -> Ascending InOrder + | Descending PostOrder -> Ascending PreOrder + + let has_curs_value = T.has_value + let get_curs_value = T.get_value + +end + +module Make(T : Sets.Set_) + : S with type 'a elt = 'a T.elt_ + and type 'a cursor = 'a T.cursor_ + and type 'a collection = 'a T.set += struct + + include Base(T) + include IteratorMixin.Mixin(Base(T)) + + let has_value t = has_curs_value t.curs + let get_value t = get_curs_value t.curs + + let create dir trav t = + (* create the cursor at the top of the tree *) + let curs = T.to_cursor t in + (* Move the cursor to the starting location for the traversal *) + let curs = match dir with + | Ascending PreOrder -> curs + | Ascending InOrder -> move_bottom_left curs + | Ascending PostOrder -> move_bottom_left curs + | Descending PreOrder -> move_bottom_right curs + | Descending InOrder -> move_bottom_right curs + | Descending PostOrder -> curs + in + from_cursor dir trav curs +end + diff --git a/src/iterator/treeSetIterator.mli b/src/iterator/treeSetIterator.mli new file mode 100644 index 0000000..f0236fc --- /dev/null +++ b/src/iterator/treeSetIterator.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** The signature for an iterator over a tree impelementing a set. *) +module type S = +sig + + type ordering = PreOrder | InOrder | PostOrder + (** A [PreOrder] traversal always visits the root of the tree + before its children. An [InOrder] traversal visits one + subtree, then the root, then the other subtree (which + subtree is chosen by the [direction_] type below). Finally, + a [PostOrder] traversal visits the subtrees before visiting + the root. *) + + type direction_ = Ascending of ordering | Descending of ordering + (** An ascending direction traversal always visits the elements in + increasing order of the keys. Similarly, the descending + direction traversal visits elements in decreasing key + order. *) + + include Iterator.S with type direction = direction_ +end + +(** Create an iterator for a Set (note that this implicitly supports + both MonoSets and PolySets). +*) +module Make : + functor (T : Sets.Set_) -> + S with type 'a elt = 'a T.elt_ + and type 'a cursor = 'a T.cursor_ + and type 'a collection = 'a T.set + diff --git a/src/list/OMakefile b/src/list/OMakefile new file mode 100644 index 0000000..d9ac4a8 --- /dev/null +++ b/src/list/OMakefile @@ -0,0 +1,15 @@ + + +OCAMLINCLUDES += ../base/ +#OCAMLFLAGS = -for-pack Reins.Lists + +FILES[] += + list/sList + list/doubleList + list/catenableList + list/doubleQueue + list/skewBinaryList + list/lists + list/listCursor + list/listCommon + diff --git a/src/list/catenableList.ml b/src/list/catenableList.ml new file mode 100644 index 0000000..e465557 --- /dev/null +++ b/src/list/catenableList.ml @@ -0,0 +1,126 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +(** Lists with fast concatenation. Based on Okasaki's implementation *) + +type 'a t = + | Empty + | Cat of 'a * 'a t Lazy.t DoubleQueue.t + +let empty = Empty + +let is_empty = function Empty -> true | _ -> false + +let link (t: 'a t) (s: 'a t Lazy.t) = match t with + | Empty -> assert false + | Cat(x,q) -> Cat(x, DoubleQueue.enqueue s q) + +let rec link_all q = + let t = Lazy.force (DoubleQueue.hd q) in + let q' = DoubleQueue.tl q in + if DoubleQueue.is_empty q' then t + else link t (lazy (link_all q')) + +let append t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | _ -> link t1 (lazy t2) + +let cons x xs = append (Cat(x,DoubleQueue.empty)) xs + +let snoc x xs = append xs (Cat(x,DoubleQueue.empty)) + +let rec last = function + | Empty -> failwith "last" + | Cat(x,q) -> + if DoubleQueue.is_empty q then x + else + let t' = Lazy.force (DoubleQueue.last q) in + last t' + +let hd = function + | Empty -> failwith "hd" + | Cat(x,_) -> x + +let pop = function + | Empty -> failwith "pop" + | Cat(x,q) -> x, (if DoubleQueue.is_empty q then Empty else link_all q) + +let tl = function + | Empty -> failwith "tl" + | Cat(x,q) -> if DoubleQueue.is_empty q then Empty else link_all q + +let rec iter f = function + | Empty -> () + | t -> + let hd,tl = pop t in + f hd; iter f tl + +let rec fold_left f acc = function + | Empty -> acc + | t -> + let hd,tl = pop t in + fold_left f (f acc hd) tl + +(* + let rec fold_right f t acc = match t with + | Empty -> acc + | Cat(x,q) -> + if DoubleQueue.is_empty q + then f x acc + else let rest,last = DoubleQueue.pop_back q in + fold_right f rest (f acc last) +*) +let fold = fold_left + +let rev t = fold (fun acc x -> cons x acc) empty t + +let rev_map f t = + let rec helper acc = function + | Empty -> acc + | t -> let hd,tl = pop t in helper (cons (f hd) acc) tl + in helper Empty t + +let map f t = + let rec helper acc = function + | Empty -> acc + | t -> let hd,tl = pop t in helper (snoc (f hd) acc) tl + in helper Empty t + +let length t = fold (fun acc _ -> acc+1) 0 t + +let to_list t = List.rev (fold (fun acc x -> x::acc) [] t) + +let from_list lst = List.fold_left (fun acc x -> snoc x acc) Empty lst + +let rec flatten t = + let rec helper acc t = + if is_empty t then acc + else let x,xs = pop t in + helper (append acc x) xs + in helper Empty t + +let to_string to_s t = ListCommon.to_string iter pop to_s t + +let rec compare cmp t1 t2 = match t1,t2 with + | Empty, Empty -> 0 + | Empty, t -> -1 + | t, Empty -> 1 + | Cat(x,q1),Cat(y,q2) -> match cmp x y with + | 0 -> compare cmp (tl t1) (tl t2) + | v -> v + +let rec gen (agen : ?size:int -> Random.State.t -> 'a) ?(size=50) rs : 'a t = + let rec helper acc s = + let s = max s 1 in + let i = Random.State.int rs s in + if i <= 1 then acc + else helper (cons (agen ~size:size rs) acc) (s-1) + in helper Empty size + diff --git a/src/list/catenableList.mli b/src/list/catenableList.mli new file mode 100644 index 0000000..ff81425 --- /dev/null +++ b/src/list/catenableList.mli @@ -0,0 +1,129 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Lists with fast concatenation. + + This module implements lists with amortized O(1) [hd], [tl], and + [append] operations. +*) + +type 'a t + +val empty : 'a t + (** The empty list *) + +val is_empty : 'a t -> bool + (** returns true if the list is empty *) + +val length : 'a t -> int + (** [length t] Returns the length of the list [t]. Runs in O(n) + time and O(1) stack space *) + +val rev : 'a t -> 'a t + (** [rev t] Returns the list [t] in reversed order. Runs in O(n) + time and O(1) stack space. *) + +val hd : 'a t -> 'a + (** [hd t] Return the element at the front of the list. O(1) time and + stack space. If the list is empty, it raises [Failure "hd"]. *) + +val tl : 'a t -> 'a t + (** [tl t] Return the tail of the list (the list with the first element + removed). This operation runs in amortized O(1) time and stack + space. If the list is empty, it raises [Failure "tl"]. *) + +val pop : 'a t -> 'a * 'a t + (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. + Runs in amortized O(1) time and stack space. If the list is + empty, it raises [Failure "pop"]. *) + +val cons : 'a -> 'a t -> 'a t + (** [cons x t] Adds [x] onto the front of the list [t]. Runs in + amortized O(1) time and stack space. *) + +val snoc : 'a -> 'a t -> 'a t + (** [snoc t x] Adds [x] onto the back of the list [t]. Runs in + amortized O(1) time and stack space. *) + +val last : 'a t -> 'a + (** [last t] Returns the element at the back of the list. If the + list is empty, it raises [Failure "last"]. Runs in O(1) stack + and O(n) time, but may be more efficient in some circumstances + when t has been constructed with several concatenations. *) + +val append : 'a t -> 'a t -> 'a t + (** [append t1 t2] Appends the list [t2] onto the back of list [t1]. + Runs in amortized O(1) time and stack space. *) + +val flatten : 'a t t -> 'a t + (** [flatten l] Appends all of the elements of [l] into a new list. + Runs in amortized O(n) time and amortized O(1) stack space where + n is the length of [l]. *) + +val from_list : 'a list -> 'a t + (** [from_list l] Convert the standard list l into a CatenableList. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [l]. *) + +val to_list : 'a t -> 'a list + (** [to_list t] Convert the CatenableList [t] into a standard list. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [t]. *) + +val iter : ('a -> unit) -> 'a t -> unit + (** [iter f t] Iterates over each element in the list [t] in order + and applies [f] to that element. Runs in O(n*ft) where ft is + the running time of [f] and uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. Runs in O(n*ft) where ft is the + running time of [f] and uses O(fs) stack space where fs is the + stack space required by [f]. *) + +val rev_map : ('a -> 'b) -> 'a t -> 'b t + (** [rev_map f t] Creates a new list by applying [f] to each element + of [t]. The resulting list is in reverse order of [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] Creates a new list by applying [f] to each element of + [t]. The resulting list is in the same order as [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O(fs) stack space where fs is + the stack space required by [f]. This function is just as + efficient as {!CatenableList.rev_map} (yielding a different + ordering) and more efficient than [CatenableList.rev + (CatenableList.rev_map t)]. *) + +val to_string : ('a -> string) -> 'a t -> string + (** [to_string to_s t] Convert the list [t] into a string using + [to_s] to individually convert each element into a string. Runs + in O(n*st) where st is the running time of [to_s] and uses O(ss) + stack space where ss is the amount of stack required by [to_s]. + *) + +val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to + compare individual elements. Returns 0 if [t1] and [t2] are + equal (under f). Returns [<0] if [t1] is less than [t2] and + returns [>0] otherwise. *) + +val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> + Random.State.t -> 'a t + (** [gen f ?size rs] Generates a random list whose length is bounded + by [size]. Each element in the list is computed by calling [f + ?size rs]. Runs in time O([size] * ft) where ft is the running + time of [f] and uses O(fs) stack space where fs is the stack space + of [f]. + *) + diff --git a/src/list/doubleList.ml b/src/list/doubleList.ml new file mode 100644 index 0000000..ad78d5a --- /dev/null +++ b/src/list/doubleList.ml @@ -0,0 +1,152 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module Make(L : Lists.ListSig) = struct + type 'a dlist = 'a L.t * 'a L.t + + type 'a t = 'a dlist + + let empty = L.empty, L.empty + + let at_front (p,_) = L.is_empty p + + let at_back (_,n) = L.is_empty n + + let is_empty l = at_front l && at_back l + + let next_length (_,n) = L.length n + let prev_length (p,_) = L.length p + + let length (p,n) = (L.length p) + (L.length n) + + let rev (p,n) = (n,p) + + (* + [splice l1 l2] + prev_l2 :: prev_l1 :: next_l1 :: next_l2 + *) + let splice (sp,sn) (p,n) = (L.append sp p), (L.append sn n) + + let rec next (p,n) = + if L.is_empty n then failwith "next" + else let x,n' = L.pop n in (L.cons x p),n' + + let rec prev (p,n) = + if L.is_empty p then failwith "prev" + else let x,p' = L.pop p in p',(L.cons x n) + + let cons x (p,n) = p, (L.cons x n) + + let prev_cons x (p,n) =(L.cons x p), n + + let hd (_,n) = + try fst (L.pop n) with Failure "pop" -> failwith "hd" + + let value (_,n) = if L.is_empty n then None else Some (L.hd n) + + let prev_hd (p,_) = + try fst (L.pop p) with Failure "pop" -> failwith "prev_hd" + + let tl (p,n) = + try let tl = snd (L.pop n) in (p,tl) + with Failure "pop" -> failwith "tl" + + let prev_tl (p,n) = + try let tl = snd (L.pop p) in (tl,n) + with Failure "pop" -> failwith "prev_tl" + + let pop (p,n) = let h,tl = L.pop n in h, (p,tl) + + let prev_pop (p,n) = + try let h,tl = L.pop p in h, (tl,n) + with Failure "pop" -> failwith "prev_pop" + + let rec goto_front l = + if at_front l then l else goto_front (prev l) + + let rec goto_back l = + if at_back l then l else goto_back (next l) + + (* stay at same position in l1 and tack l2 onto the end *) + let append l1 l2 = splice l1 (goto_front l2) + + let snoc x (p,n) = p, (L.snoc x n) + + let last (p,n) = (L.last n) + + let prev_snoc x (p,n) =(L.snoc x p), n + + let rec fold1 f acc l = + if L.is_empty l then acc + else + let x,tl = L.pop l in + fold1 f (f acc x) tl + + let fold f acc (p,n) = + fold1 f (fold1 f acc n) p + + let iter f l = fold (fun () -> f) () l + + let map f (p,n) = + let n' = L.map f n in + let p' = L.map f p in + (p',n') + + (* If we applied rev_map to the front and back list, we would still + have to reverse them again. So we might as well just use this + simple version (since our rev is O(1)) in the hopes that L + provides an efficient 'map' (and no worse the L.rev L.rev_map)*) + let rev_map f l = rev (map f l) + + let flatten ll = + let dl = fold (fun acc l -> splice l (goto_back acc)) empty (goto_front ll) in + goto_back dl + + let from_list l = L.empty, (L.from_list l) + + let to_list dl = + let dl' = goto_back dl in + fold (fun acc x -> x::acc) [] dl' + + let rec to_string to_s t = ListCommon.to_string iter pop to_s (goto_front t) + + let rec compare c x y = + let x = goto_front x in + let y = goto_front y in + match at_back x, at_back y with + | true,true -> 0 + | false,true -> 1 + | true,false -> -1 + | false,false -> + let hx,tx = pop x in + let hy,ty = pop y in + match c hx hy with + | 0 -> compare c tx ty + | v -> v + + let gen agen ?(size=50) rs = + (L.gen agen ~size:(size/2) rs), (L.gen agen ~size:(size/2) rs) + + + type 'a list_ = 'a t + type 'a cursor = 'a dlist + let to_cursor x = x + let from_cursor x = x + + let current = hd + let move_prev = prev + let move_next = next + + let list x = x + let replace_list (p1,n1) (p2,_) = + let n2 = L.append p1 n1 in + (p2,n2) + +end + diff --git a/src/list/doubleList.mli b/src/list/doubleList.mli new file mode 100644 index 0000000..ebd911d --- /dev/null +++ b/src/list/doubleList.mli @@ -0,0 +1,224 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Acyclic doubly linked lists + + This module implements acyclic doubly linked lists that support + O(1) navigation. The running time of the rest of the operations + depend on the argument [L]. All operations are explained assuming + the list is visually laid out from left to right. That is, the + front of the list is on the left and the end of the list is on the + right. +*) + +module Make(L : Lists.ListSig) : sig + type 'a t + (** The type of doubly linked lists. This type can be thought + of as a cursor pointing into the middle of a [L.t] list. + Elements to the right of [t] can be reached with [hd], [tl], + [pop], and [next]. Elements to the left of [t] can be + reached with [prev_hd], [prev_tl], [prev_pop], and + [prev]. *) + + val empty : 'a t + (** The empty list *) + + val is_empty : 'a t -> bool + (** Returns true if the list is empty. That is, there are no + elements to the left or right of [t]. Runs in the same time + and stack space as [L.is_empty]. *) + + val at_front : 'a t -> bool + (** [at_front t] Retruns true if there are no elements to the left + of [t]. Runs in the same time and stack space as [L.is_empty]. *) + + val at_back : 'a t -> bool + (** [at_front t] Retruns true if there are no elements to the + right of [t]. Runs in the same time and stack space as + [L.is_empty]. *) + + val length : 'a t -> int + (** [length t] Returns the length of the entire list. Runs in the + same time and stack space as [L.length]. *) + + val next_length : 'a t -> int + (** [next_length t] Returns the number of elements to the right of + [t]. Runs in the same time and stack space as [L.length]. *) + + val prev_length : 'a t -> int + (** [prev_length t] Returns the number of elements in front of + [t]. Runs in the same time and stack space as [L.length]. *) + + val rev : 'a t -> 'a t + (** [rev t] Reverse the list [t]. All elements that were in front + of [t] are now to the right of it and vice versa. Runs in + O(1) time and stack space. *) + + val hd : 'a t -> 'a + (** [hd t] Returns the element to the immediate right of [t]. + Runs in the same time and stack space as [L.hd]. If there are + no elements to the right of [t], it raises [Failure "hd"]. *) + + val tl : 'a t -> 'a t + (** [tl t] Return the list with the first element to the right of + [t] removed. Runs in the same time and stack space as [L.tl]. + If there are no elements to the right of [t], it raises + [Failure "tl"]. *) + + val pop : 'a t -> 'a * 'a t + (** [pop t] Equivalent to [(hd t), (tl t)] but is slightly more + efficient. Runs in the same time and stack space as [L.pop]. + If there are no elements to the right of [t], it raises + [Failure "pop"]. *) + + val last : 'a t -> 'a + (** [last t] Returns the last element the right of [t]. Runs in + the same time and stack space as [L.last]. If there are no + elements to the right of [t], it raises [Failure "last"]. *) + + val next : 'a t -> 'a t + (** [next t] Advance [t] to the next element in the list. The + element to the right of [t] is now to the left of the result. + Runs in the same time and stack space as the maximum of [L.hd] + and [L.cons]. If there are no elements to the right of [t], + it raises [Failure "next"]. *) + + val prev_hd : 'a t -> 'a + (** [prev_hd t] Returns the element to the left of [t]. Runs in + the same time and space as [L.hd]. If there are no element to + the left of [t], it raises [Failure "prev_hd"]. *) + + val prev_tl : 'a t -> 'a t + (** [prev_tl t] Return the list with the first element to the left + of [t] removed. Runs in the same time and stack space as + [L.tl]. If there are no elements to the left of [t], it + raises [Failure "prev_tl"]. *) + + val prev_pop : 'a t -> 'a * 'a t + (** [prev_pop t] Equivalent to [(prev_hd t), (prev_tl t)] but is + slightly more efficient. Runs in the same time and stack + space as [L.pop]. If there are no elements to the left of [t], + it raises [Failure "prev_pop"]. *) + + val prev : 'a t -> 'a t + (** [prev t] Advance [t] to the previous element in the list. The + element to the left of [t] is now to the right of the result. + Runs in the same time and stack space as the maximum of [L.hd] + and [L.cons]. If there are no elements to the left of [t], it + raises [Failure "prev"]. *) + + val cons : 'a -> 'a t -> 'a t + (** [cons x t] Adds [x] as the first element to the right of [t]. + Runs in the same time and stack space as [L.cons]. *) + + val prev_cons : 'a -> 'a t -> 'a t + (** [prev_cons x t] Adds [x] as the first element to the left of [t]. + Runs in the same time and stack space as [L.cons]. *) + + val snoc : 'a -> 'a t -> 'a t + (** [snoc x t] Adds [x] as the last element to the right of [t] + (i.e., the last element in the entire list). The resulting + list otherwise has the same elements to the left of it and to + the right of it as [t] (i.e., the position has not changed). + Runs in the same time and stack space as [L.snoc]. *) + + val prev_snoc : 'a -> 'a t -> 'a t + (** [snoc x t] Adds [x] as the last element to the left of t [t] + (i.e., the first element in the entire list). The resulting + list otherwise has the same elements to the left of it and to + the right of it as [t] (i.e., the position has not changed). + Runs in the same time and stack space as [L.snoc]. *) + + val append : 'a t -> 'a t -> 'a t + (** [append t1 t2] Append the list [t2] onto the back of [t1]. + The resulting list has the same position as [t1]. Runs in the + O(|t2| + LA) time where LA is the running time of [L.append]. + It uses O(1 + LS) stack space where LS is the stack space + required by [L.append]. *) + + val splice : 'a t -> 'a t -> 'a t + (** [splice t1 t2] Splices the elements of [t1] into [t2]. The + resulting list has the shape: + + prev_l2 @ prev_l1 @ next_l1 @ next_l2 + + Runs in the same time and stack space as [L.append]. + *) + + val flatten : 'a t t -> 'a t + (** [flatten l] Appends all of the elements of [l] into a new list. + Currently ineffeciently implemented and has greater than O(n) + running time. *) + + val from_list : 'a list -> 'a t + (** [from_list l] Convert the standard list [l] into a {!DList.t}. + Runs in the same time and stack space as [L.from_list]. The + resulting cursor points to the front of the list. *) + + val to_list : 'a t -> 'a list + (** [to_list t] Convert the DList [t] into a standard list. Runs + in O(|t|) time and O(1) stack space. The position of [t] does + not affect the order of the resulting list. *) + + val iter : ('a -> unit) -> 'a t -> unit + (** [iter f t] Iterates over each element in the list [t] and + applies [f] to that element. The elements to the right of [t] + are visited first in order, following by the elements to the + left of [t] in reverse order. Runs in the same time and stack + space as [L.iter]. *) + + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. The elements to the right of + [t] are visited first in order, following by the elements to + the left of [t] in reverse order. Runs in the same time and + stack space as [L.fold]. *) + + val rev_map : ('a -> 'b) -> 'a t -> 'b t + (** [rev_map f t] Creates a new list by applying [f] to each + element of [t]. The resulting list is in reverse order of [t] + and the cursor of the resulting list points to the same + location as [t] whith the next and previous elements reversed. + e.g., if [e == hd t], then [f(e) == prev_hd (rev_map f t)] + Runs in the same time and stack space as [L.map]. *) + + val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] Creates a new list by applying [f] to each element + of [t]. The resulting list is in the same order as [t] and + the cursor points to the same location as [t]. e.g., if [e == + hd t], then [f(e) == hd (map f t)]. Runs in the same time and + stack space as [L.map]. *) + + val to_string : ('a -> string) -> 'a t -> string + (** [to_string to_s t] Convert the list [t] into a string using + [to_s] to individually convert each element into a string. + Runs in O(|t|*st) where st is the running time of [to_s] and + uses O(ss) stack space where ss is the amount of stack + required by [to_s]. *) + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] + to compare individual elements. Returns 0 if [t1] and [t2] + are equal (under f). Returns [<0] if [t1] is less than [t2] + and returns [>0] otherwise. Runs in O(min(|t1|, |t2|)) time + and O(1) stack space. *) + + val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t + (** [gen f ?size rs] Generates a random list whose length is bounded + by [size]. Each element in the list is computed by calling [f + ?size rs]. Runs in time O([size] * ft) where ft is the running + time of [f] and uses O(fs) stack space where fs is the stack space + of [f]. The location of the cursor is not defined. + *) + + include ListCursor.S with type 'a list_ = 'a t and type 'a cursor = 'a t + (** Note that the type [cursor] is the same as [t]. Therefore all + {!List_Cursor.S} operations can be applied directly to values of + type DList.t *) +end diff --git a/src/list/doubleQueue.ml b/src/list/doubleQueue.ml new file mode 100644 index 0000000..d9a425c --- /dev/null +++ b/src/list/doubleQueue.ml @@ -0,0 +1,115 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +type 'a t = 'a list * 'a list + +let empty = [], [] + +let is_empty (f,r) = match f with [] -> true | _ -> false + +(* smart construct to enforce that the first list is only empty + when the entire queue is empty *) +let dqueue f r = match f with + | [] -> (List.rev r), [] + | _ -> f,r + +let cons x (f,r) = x::f, r + +let snoc x (f,r) = dqueue f (x::r) +let cons_back = snoc + +let enqueue = snoc + +let hd = function + | [],_ -> failwith "hd" + | x::_,_ -> x + +let tl = function + | [],_ -> failwith "tl" + | x::tl,r -> dqueue tl r + +let pop = function + | [],_ -> failwith "pop" + | x::tl,r -> x, (dqueue tl r) + +let dequeue = pop + +let last = function + | _, r::_ -> r + | [],[] -> failwith "last" + | hd::[], [] -> hd + | f::fs, [] -> List.hd (List.rev fs) + +let hd_back t = + try last t + with Failure "last" -> failwith "hd_back" + +let tl_back = function + | f, (r::rs) -> (f,rs) + | [], [] -> failwith "tl_back" + | hd::[], [] -> empty + | f::fs, [] -> + match List.rev fs with + | [] -> assert false + | r::rs -> [f], rs + +let pop_back = function + | f, (r::rs) -> (f,rs), r + | [], [] -> failwith "pop_back" + | hd::[], [] -> empty, hd + | f::fs, [] -> + match List.rev fs with + | [] -> assert false + | r::rs -> ([f], rs), r + + +let length (f,r) = (List.length f) + (List.length r) + +let append (f1,r1) (f2,r2) = + let r = List.rev_append f2 r1 in + let r = List.append r2 r in + f1, r + +let rev (f,r) = dqueue r f + +let iter func (f,r) = + List.iter func f; + List.iter func (List.rev r) + +let fold func acc (f,r) = + List.fold_left func (List.fold_left func acc f) (List.rev r) + +let rev_map func l = fold (fun acc x -> cons (func x) acc) empty l +let map func l = fold (fun acc x -> snoc (func x) acc) empty l + +let to_list (f,r) = + List.rev_append (List.rev f) (List.rev r) + +let from_list l = (l,[]) + +(* This is probably not the fastest implementation due to the + intermediate list reversals, however its at least O(n). Feel free + to submit patches with a faster version if you actually use this + function. +*) +let flatten (f,r) = + let f' = List.rev (List.fold_left (fold (fun acc x -> x::acc)) [] f) in + let r' = List.rev (List.fold_left (fold (fun acc x -> x::acc)) [] r) in + (f',r') + +let compare c ((f1,r1) as l1) ((f2,r2) as l2) = match r1,r2 with + | [],[] -> SList.compare c f1 f2 + | _ -> SList.compare c (to_list l1) (to_list l2) + +let to_string to_s l = ListCommon.to_string iter pop to_s l + +let gen (gena: ?size:int -> Random.State.t -> 'a) ?size rs : 'a t = + (SList.gen ?size gena rs), (SList.gen ?size gena rs) + + diff --git a/src/list/doubleQueue.mli b/src/list/doubleQueue.mli new file mode 100644 index 0000000..2ac5add --- /dev/null +++ b/src/list/doubleQueue.mli @@ -0,0 +1,160 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Double ended queues *) + +type 'a t + (** The type of double ended queues. Access to both the front and + the back of the queue take amortized O(1) time. *) + +val empty : 'a t + (** The empty queue *) + +val is_empty : 'a t -> bool + (** Returns true is the queue is empty *) + +val hd : 'a t -> 'a + (** [hd q] Return the element at the front of the queue. If the + queue is empty, it raises [Failure "hd"] *) + +val tl : 'a t -> 'a t + (** [tl t] Return the queue [t] with the element at the front of the + queue removed. Runs in O(1) time and stack space. If the queue + is empty, it raises [Failure "tl"]. *) + +val pop : 'a t -> 'a * 'a t + (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. + Runs in O(1) time and stack space. If the queue is empty, it + raises [Failure "pop"]. *) + +val cons : 'a -> 'a t -> 'a t + (** [cons x t] Adds [x] to the front of queue [t] so that a + subsequent call to [hd] returns [x]. Runs in O(1) time and + stack space. *) + +val hd_back : 'a t -> 'a + (** [hd_back q] Return the element at the back of the queue. If the + queue is empty, it raises [Failure "hd_back"]. Runs in + amortized O(1) time and O(1) stack space. *) + +val tl_back : 'a t -> 'a t + (** [tl t] Return the queue [t] with the element at the back of the + queue removed. Runs in amortized O(1) time and O(1) stack + space. If the queue is empty, it raises [Failure "tl_back"]. + *) + +val pop_back : 'a t -> 'a t * 'a + (** [pop_back t] Equivalent to [(hd_back t), (tl_back t)] but is + more efficient. Runs in amortized O(1) time and O(1) stack + space. If the queue is empty, it raises [Failure "pop_back"]. + *) + +val cons_back : 'a -> 'a t -> 'a t + (** [cons_back x t] Adds [x] to the back of queue [t] so that a + subsequent call to [hd_back] returns [x]. Runs in O(1) time and + stack space. *) + +val snoc : 'a -> 'a t -> 'a t + (** [snoc x t] is an alias for {!DoubleQueue.cons_back} [x t], + adding [x] to the back of [t]. *) + +val last : 'a t -> 'a + (** [last q] is an alias for [hd_back q] *) + +val enqueue : 'a -> 'a t -> 'a t + (** [enqueue x t] is an alias for {!DoubleQueue.cons_back} [x t], + adding [x] to the back of [t]. *) + +val dequeue : 'a t -> 'a * 'a t + (** [dequeue x t] is an alias for {!DoubleQueue.hd} [x t], removing + the first element from the front of [t]. *) + +val length : 'a t -> int + (** [length t] Returns the number of elements in the queue [t] *) + +val rev : 'a t -> 'a t + (** [rev t] Reverses the order of the queue [t]. e.g., [hd t == + hd_back (rev t)] *) + +val append : 'a t -> 'a t -> 'a t + (** [append t1 t2] Appends all of the elements in queue [t2] onto + the back of [t1]. That is, in the resulting queue, + {!DoubleQueue.hd} returns the first element of [t1] and + {!DoubleQueue.hd_back} returns the last element of [t2]. Runs + in O(n+m) time where n and m are the number of elements in [t1] + and [t2] respectively. *) + +val iter : ('a -> unit) -> 'a t -> unit + (** [iter f t] Iterates over each element in the queue [t] in order + and applies [f] to that element. Runs in O(n*ft) where ft is + the running time of [f] and uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. Runs in O(n*ft) where ft is the + running time of [f] and uses O(fs) stack space where fs is the + stack space required by [f]. *) + +val rev_map : ('a -> 'b) -> 'a t -> 'b t + (** [rev_map f t] Creates a new queue by applying [f] to each element + of [t]. The resulting queue is in reverse order of [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] Creates a new queue by applying [f] to each element of + [t]. The resulting queue is in the same order as [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O(fs) stack space where fs is + the stack space required by [f]. This function is just as + efficient as {!DoubleQueue.rev_map} (yielding a different + ordering) and more efficient than [DoubleQueue.rev + (DoubleQueue.rev_map t)]. *) + +val to_list : 'a t -> 'a list + (** [to_list t] Convert the DoubleQueue [t] into a standard list. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [t]. The resulting list has the same ordering as + [t]. That is, [DoubleQueue.hd t == List.hd (DoubleQueue.to_list + t)]. *) + +val from_list : 'a list -> 'a t + (** [from_list l] Convert the standard list l into a DoubleQueue.t. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [l]. The resulting queue has the same order as the + original list. That is [List.hd l == DoubleQueue.hd + (DoubleQueue.from_list l)]. *) + +val flatten : 'a t t -> 'a t + (** [flatten l] Appends all of the elements of [l] into a new queue. + The current implementation is not very efficient and runs in + greater than O(n) time uses a O(n) stack space. *) + +val to_string : ('a -> string) -> 'a t -> string + (** [to_string to_s t] Convert the queue [t] into a string using + [to_s] to individually convert each element into a string. Runs + in O(n*st) where st is the running time of [to_s] and uses O(ss) + stack space where ss is the amount of stack required by [to_s]. + *) + +val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** [compare f t1 t2] Compares the queues [t1] and [t2] using [f] to + compare individual elements. Returns 0 if [t1] and [t2] are + equal (under f). Returns [<0] if [t1] is less than [t2] and + returns [>0] otherwise. *) + +val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t + (** [gen f ?size rs] Generates a random queue whose length is + bounded by [size]. Each element in the queue is computed by + calling [f ?size rs]. Runs in time O([size] * ft) where ft is + the running time of [f] and uses O(fs) stack space where fs is + the stack space of [f]. *) + diff --git a/src/list/listCommon.ml b/src/list/listCommon.ml new file mode 100644 index 0000000..9df6733 --- /dev/null +++ b/src/list/listCommon.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +let to_string iter pop to_s t = + try + let buf = Buffer.create 32 in + let hd,tl = pop t in + Buffer.add_char buf '['; + Buffer.add_string buf (to_s hd); + iter (fun e -> + Buffer.add_string buf "; "; + Buffer.add_string buf (to_s e) + ) tl; + Buffer.add_char buf ']'; + Buffer.contents buf + with Failure "pop" -> "[]" diff --git a/src/list/listCursor.ml b/src/list/listCursor.ml new file mode 100644 index 0000000..53fbfe2 --- /dev/null +++ b/src/list/listCursor.ml @@ -0,0 +1,75 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type S = +sig + type 'a list_ + type 'a cursor + + val to_cursor : 'a list_ -> 'a cursor + val from_cursor : 'a cursor -> 'a list_ + val at_front : 'a cursor -> bool + val at_back : 'a cursor -> bool + val move_next : 'a cursor -> 'a cursor + val move_prev : 'a cursor -> 'a cursor + val goto_front : 'a cursor -> 'a cursor + val goto_back : 'a cursor -> 'a cursor + + val value : 'a cursor -> 'a option + + val list : 'a cursor -> 'a list_ + val replace_list : 'a list_ -> 'a cursor -> 'a cursor +end + +module Make(L : Lists.ListSig) : S with type 'a list_ = 'a L.t = struct + type 'a list_ = 'a L.t + + (* Note that this type is same as the standard list type with the + arguments of the 2nd constructor reversed. *) + type 'a path = + | Top + | Path of 'a path * 'a + + type 'a cursor = 'a path * 'a L.t + + let to_cursor t = Top, t + + let at_front = function Top,_ -> true | _ -> false + + let at_back (p,t) = L.is_empty t + + let value (_,t) = if L.is_empty t then None else Some (L.hd t) + + let list (_,t) = t + let replace_list t (p,_) = (p,t) + + let move_next (p,t) = + if L.is_empty t then failwith "move_next" + else + let x,xs = L.pop t in + Path(p,x), xs + + let move_prev (p,t) = match p with + | Top -> failwith "move_prev" + | Path(p, x) -> + p, (L.cons x t) + + let rec goto_front c = + if at_front c then c + else goto_front (move_prev c) + + let rec goto_back c = + if at_back c then c + else goto_back (move_next c) + + let rec from_cursor = function + | Top,t -> t + | c -> from_cursor (move_prev c) + +end diff --git a/src/list/listCursor.mli b/src/list/listCursor.mli new file mode 100644 index 0000000..c185fd0 --- /dev/null +++ b/src/list/listCursor.mli @@ -0,0 +1,85 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Cursor interface for Lists *) + +module type S = +sig + type 'a list_ + (** The underlying list type the cursor points to. *) + + type 'a cursor + (** The type of list cursors. A cursor can be thought of a + pointer into the middle of a list. More specifically, + cursors point to edges between list elements, not elements + directly. A cursor can be move to the left (towards the + front of the list) or to the right (towards the back of the + list) and supports updating the list at the current position + efficiently. *) + + val to_cursor : 'a list_ -> 'a cursor + (** [to_cursor t] Create a cursor that points to the beginning of + list [t]. Runs in O(1) time and space. + *) + + val from_cursor : 'a cursor -> 'a list_ + (** [from_cursor curs] Return the list that is pointed to by + [curs]. Runs in O(n) time and O(1) stack space where n is the + number of elements to the left of [curs]. + *) + + val at_front : 'a cursor -> bool + (** [at_front curs] Returns true if there are no elements to the + left of [curs]. Runs in O(1) time and stack space. + *) + + val at_back : 'a cursor -> bool + (** [at_end curs] Returns true if there are no elements to the + right of [curs]. Runs in O(1) time and stack space. *) + + val move_next : 'a cursor -> 'a cursor + (** [move_left curs] Moves the cursor one element to the left. If + there are no elements to the left of [curs] (i.e., [curs] + points to the front of the list), it raises [Failure + "move_left"]. Runs in O(1) time and stack space. + *) + + val move_prev : 'a cursor -> 'a cursor + (** [move_right curs] Moves the cursor one element to the right. + If there are no elements to the right of [curs] (i.e., [curs] + points to the end of the list), it raises [Failure + "move_right"]. Runs in O(1) time and stack space. + *) + + val goto_front : 'a cursor -> 'a cursor + (** [goto_front curs] Moves the cursor to the front of the + list. Runs in O(n) time and O(1) stack space where n is the + number of elements to the left of [curs]. + *) + + val goto_back : 'a cursor -> 'a cursor + (** [goto_back curs] Moves the cursor to the back of the list. + Runs in O(n) time and O(1) stack space where n is the number + of elements to the right of [curs]. *) + + val value : 'a cursor -> 'a option + (** If the cursor currently points to an element [x], return that + element as [Some x], otherwise return [None]. *) + + val list : 'a cursor -> 'a list_ + (** [list curs] Returns all of the elements to the right of [curs] + as a ['a list_]. Runs in O(1) time and stack space. *) + + val replace_list : 'a list_ -> 'a cursor -> 'a cursor + (** [replace_list l curs] Replaces the list of elements to the + right of [curs] with [l]. Runs in O(1) time and stack + space. *) +end + +module Make : functor (L : Lists.ListSig) -> S with type 'a list_ = 'a L.t diff --git a/src/list/lists.ml b/src/list/lists.ml new file mode 100644 index 0000000..00c8dcd --- /dev/null +++ b/src/list/lists.ml @@ -0,0 +1,39 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type ListSig = sig + type 'a t + + val empty : 'a t + val is_empty : 'a t -> bool + val length : 'a t -> int + + val rev : 'a t -> 'a t + val cons : 'a -> 'a t -> 'a t + val snoc : 'a -> 'a t -> 'a t + + val hd : 'a t -> 'a + val tl : 'a t -> 'a t + val pop : 'a t -> 'a * 'a t + val last : 'a t -> 'a + val append : 'a t -> 'a t -> 'a t + val flatten : 'a t t -> 'a t + val from_list : 'a list -> 'a t + val to_list : 'a t -> 'a list + val iter : ('a -> unit) -> 'a t -> unit + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + val rev_map : ('a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t + val to_string : ('a -> string) -> 'a t -> string + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t +end + diff --git a/src/list/lists.mli b/src/list/lists.mli new file mode 100644 index 0000000..5588d6f --- /dev/null +++ b/src/list/lists.mli @@ -0,0 +1,105 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** The signature that all lists must minimally conform to. *) + +module type ListSig = sig + type 'a t + (** The type of the list *) + + val empty : 'a t + (** The empty list *) + + val is_empty : 'a t -> bool + (** Returns true if the list is empty *) + + val length : 'a t -> int + (** Returns the length of the list *) + + val rev : 'a t -> 'a t + (** Reverse the list *) + + val cons : 'a -> 'a t -> 'a t + (** [cons x t] Add the element [x] to the front of list [t] *) + + val snoc : 'a -> 'a t -> 'a t + (** [snoc x t] Add the element [x] to the end of list [t] *) + + val hd : 'a t -> 'a + (** [hd t] Return the first element at the front of the list. All + lists in the Reins library raise [Failure "hd"] when applied + to an empty list. *) + + val tl : 'a t -> 'a t + (** [tl t] Return the list with the first element removed. All + lists in the Reins library raise [Failure "tl"] when applied + to an empty list. *) + + val pop : 'a t -> 'a * 'a t + (** Returns both the first element of the list and the remaining + tail of the list. All lists in the Reins library raise + [Failure "pop"] when applied to an empty list. *) + + val last : 'a t -> 'a + (** [last t] Returns the element at the back of the list. All + lists in the Reins library raise [Failure "last"] when applied + to an empty list. *) + + val append : 'a t -> 'a t -> 'a t + (** [append t1 t2] Append the list [t2] onto the end of list + [t1]. *) + + val flatten : 'a t t -> 'a t + (** Flatten a list of lists into a single list *) + + val from_list : 'a list -> 'a t + (** Create a list from a builtin list type *) + + val to_list : 'a t -> 'a list + (** Convert the list into a builtin list type *) + + val iter : ('a -> unit) -> 'a t -> unit + (** [iter f t] Apply [f] to each element in list [t]. *) + + val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. *) + + val rev_map : ('a -> 'b) -> 'a t -> 'b t + (** [rev_map f t] Creates a new list by applying [f] to each + element of [t]. The resulting list is in reverse order of + [t]. *) + + val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] Creates a new list by applying [f] to each element + of [t]. The resulting list is in the same order as [t]. *) + + val to_string : ('a -> string) -> 'a t -> string + (** [to_string to_s t] Convert the list [t] into a string using + [to_s] to individually convert each element into a string. + All lists in the Reins library format the list following OCaml + syntax. e.g., "[x1; x2; x3]" + *) + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] + to compare individual elements. Returns 0 if [t1] and [t2] + are equal (under f). Returns [<0] if [t1] is less than [t2] + and returns [>0] otherwise. *) + + val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t + (** [gen f ?size rs] Generates a random list whose length is bounded + by [size]. Each element in the list is computed by calling [f + ?size rs]. + *) + +end + diff --git a/src/list/sList.ml b/src/list/sList.ml new file mode 100644 index 0000000..d84d5f5 --- /dev/null +++ b/src/list/sList.ml @@ -0,0 +1,51 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +include List +type 'a t = 'a list + +let empty = [] +let is_empty = function [] -> true | _ -> false + +let pop = function + | [] -> failwith "pop" + | hd::tl -> hd,tl + +let fold = fold_left +let cons x t = x::t +let snoc x t = rev (x::(rev t)) + +let rec last = function + | [] -> failwith "last" + | x::[] -> x + | _::xs -> last xs + +let to_list x = x +let from_list x = x + +let rec compare cmp x y = match x,y with + | [],[] -> 0 + | _::_, [] -> 1 + | [], _::_ -> -1 + | hx::xs, hy::ys -> match cmp hx hy with + | 0 -> compare cmp xs ys + | c -> c + +let rec gen (f : ?size:int -> Random.State.t -> 'a) + ?(size=100) (r : Random.State.t) : 'a list = + let size = abs size in + if (Random.State.int r size) = 0 + then [] + else (f r) :: (gen ~size:(size-1) f r) + +let to_string to_s t = ListCommon.to_string iter pop to_s t + +let fold = fold_left +(*let equal x y = (compare Pervasives.compare x y) = 0*) + diff --git a/src/list/sList.mli b/src/list/sList.mli new file mode 100644 index 0000000..c660781 --- /dev/null +++ b/src/list/sList.mli @@ -0,0 +1,117 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +type 'a t = 'a list + +val empty : 'a list + (** The empty list. aka [] *) + +val is_empty : 'a list -> bool + (** Returns true if the list is empty *) + +val cons : 'a -> 'a list -> 'a list + (** [cons x t] Adds [x] onto the front of the list [t]. Runs in + O(1) time and stack space. *) + +val pop : 'a list -> 'a * 'a list + (** [pop t] equivalent to [(hd t), (tl t)] but is more efficient. + Runs in amortized O(1) time and stack space. If the list is + empty, it raises [Failure "pop"]. + *) + +val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + (** [fold f acc l] Equivalent to [fold_left f acc l] *) + +val snoc : 'a -> 'a list -> 'a list + (** [snoc x t] Adds the element [x] to the back of the list [t]. + Runs in O(n) time and O(1) stack space where n is the length of + the list. *) + +val last : 'a t -> 'a + (** [last t] Returns the element at the back of the list. If the + list is empty, it raises [Failure "last"]. Runs in O(1) stack + and O(n) time. *) + +val to_list : 'a -> 'a + (** [to_list t] Included for compatibility with the common ListSig + signature. This function does not perform any computation. + *) + +val from_list : 'a -> 'a + (** [from_list t] Included for compatibility with the common ListSig + signature. This function does not perform any computation. *) + +val to_string : ('a -> string) -> 'a list -> string + (** [to_string to_s t] Convert the list [t] into a string using + [to_s] to individually convert each element into a string. Runs + in O(n*st) where st is the running time of [to_s] and uses O(ss) + stack space where ss is the amount of stack required by [to_s]. + *) + +val compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int + (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to + compare individual elements. Returns 0 if [t1] and [t2] are + equal (under f). Returns [<0] if [t1] is less than [t2] and + returns [>0] otherwise. *) + +val gen : + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a list + (** [gen f ?size rs] Generates a random list whose length is bounded + by [size]. Each element in the list is computed by calling [f + ?size rs]. Runs in time O([size] * ft) where ft is the running + time of [f] and uses O(fs) stack space where fs is the stack space + of [f]. + *) + + +(** The following are all implemented in the standard library *) + + +val length : 'a list -> int +val hd : 'a list -> 'a +val tl : 'a list -> 'a list +val nth : 'a list -> int -> 'a +val rev : 'a list -> 'a list +val append : 'a list -> 'a list -> 'a list +val rev_append : 'a list -> 'a list -> 'a list +val concat : 'a list list -> 'a list +val flatten : 'a list list -> 'a list +val iter : ('a -> unit) -> 'a list -> unit +val map : ('a -> 'b) -> 'a list -> 'b list +val rev_map : ('a -> 'b) -> 'a list -> 'b list +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a +val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit +val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a +val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c +val for_all : ('a -> bool) -> 'a list -> bool +val exists : ('a -> bool) -> 'a list -> bool +val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +val mem : 'a -> 'a list -> bool +val memq : 'a -> 'a list -> bool +val find : ('a -> bool) -> 'a list -> 'a +val filter : ('a -> bool) -> 'a list -> 'a list +val find_all : ('a -> bool) -> 'a list -> 'a list +val partition : ('a -> bool) -> 'a list -> 'a list * 'a list +val assoc : 'a -> ('a * 'b) list -> 'b +val assq : 'a -> ('a * 'b) list -> 'b +val mem_assoc : 'a -> ('a * 'b) list -> bool +val mem_assq : 'a -> ('a * 'b) list -> bool +val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list +val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list +val split : ('a * 'b) list -> 'a list * 'b list +val combine : 'a list -> 'b list -> ('a * 'b) list +val sort : ('a -> 'a -> int) -> 'a list -> 'a list +val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list +val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list +val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list diff --git a/src/list/skewBinaryList.ml b/src/list/skewBinaryList.ml new file mode 100644 index 0000000..842b184 --- /dev/null +++ b/src/list/skewBinaryList.ml @@ -0,0 +1,227 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(* The type RList.t is based on skew binary numbers. A skew binary + number is comprised of a sequence of the digits 0,1, or 2 where + the weight of the ith digit is 2^{i+1}-1 instead of the typical + 2^i with traditional binary numbers. Furthermore, all skew + binary numbers can be written where only the lowest non-zero + digit is 2 (canonical form). + + To increment a skew binary number in canoncical form, we simply + reset the (single) 2 to 0 and increment the next digit (which + can't be a 2). If there are no 2's, we can simply increment the + lowest digit. Here are the first 10 skew binary numbers to + illustrate: + 0 + 1 + 2 + 10 + 11 + 12 + 20 + 100 # increment the 2, not the 0 + 101 + 102 + + Decrementing is simply the reverse of this operation (decrement + the 2, if it exists, otherwise decrement the lowest non-zero + digit, possibly carrying a result one plce). *) + + +(* The type elt is a complete binary tree. +*) +type 'a elt = + | Leaf of 'a + | Node of 'a * 'a elt * 'a elt + +(* A random access list is a list of complete binary trees paired + with their size. These trees each have size 2^i-1 making them + ideal for representing digits in this number system. We + represent a '2' digit by a pair of adjacent trees with the same + weight. Otherwise, each tree represents a '1' digit while '0' + digits are omitted from the list. The list is kept in increasing + order of size so that a '2' digit exists iff the first two + elements have the same height. *) +type 'a t = (int * 'a elt) list + +let empty = [] +let is_empty = function [] -> true | _ -> false + +(* The cons operation adds a new element to the list. Therefore we + must "increment" the skew binary number. To do so, we look at + the bottom two digits and compare their weights. If they have + the same weight, this is a '2' digit and therefore we reset it to + 0 and propogate the bit. We do this by creating a new tree + combining the two previous trees with an incremented weight (thus + there is no tree with the original weight, creating the 0 digit). + If the bottom digit is not a '2', then we can simply add 'x' as a + leaf to the beginning of the list, incrementing the lowest digit + (to either '1' or '2'). +*) +let cons x ts = match ts with + | (w1,t1)::(w2,t2)::ts' when w1=w2 -> + (1+w1+w2, Node(x,t1,t2)) :: ts' + | _ -> (1,Leaf x) :: ts + +let hd = function + | [] -> failwith "hd" + | (w,Leaf x) :: ts -> assert(w=1);x + | (w,Node(x,t1,t2)) :: ts -> x + +(* The tl operation must remove an element from the list and + therefore we must decrement the skew binary number. To do this + we simply remove the root of the first tree and add its children + back as a new '2' digit (which has smaller weight than any other + tree, preserving canonical form). +*) +let tl = function + | [] -> failwith "tl" + | (w,Leaf x) :: ts -> assert(w=1); ts + | (w,Node(x,t1,t2))::ts -> + (w / 2, t1) :: (w / 2, t2) :: ts + +let pop = function + | [] -> failwith "pop" + | (w,Leaf x) :: ts -> assert(w=1); x,ts + | (w,Node(x,t1,t2))::ts -> + x, ((w / 2, t1) :: (w / 2, t2) :: ts) + +(* Returns the i'th element in the complete tree 't'. Raises + Not_found if i is greater than the cardinality of the tree. *) +let rec lookup_tree i = function + | 1, Leaf x -> if i = 0 then x else raise Not_found + | _, Leaf _ -> assert false + | w, Node(x,t1,t2) -> + if i = 0 then x (* The tree is pre-ordered, so the first + element is at the root. *) + + else if i <= w/2 then lookup_tree (i-1) (w/2,t1) + (* Decrement i, since we skip over the first element *) + + else lookup_tree (i-(1+(w/2))) (w/2,t2) + (* Subtract 1+w/2 since we skip over the first element and + all of the elements in t1. *) + +(* Return the i'th element (0-indexed) in the list. We first find + the tree which contains i'th element, and then call loookup_tree + to extract the proper element from that tree. Raises Not_found + if the list does not have at least i+1 elements (+1 because of + 0-index). *) +let rec lookup i = function + | [] -> raise Not_found + | ((w,t) as elt)::ts -> + if i < w then lookup_tree i elt else lookup (i-w) ts + +(* Returns the tree 't' with the i'th element replaced by 'y'. + Raises Not_found if i is greater than the cardinality of the + tree. *) +let rec update_tree i y = function + | (1, Leaf x) -> if i = 0 then Leaf y else raise Not_found + | (_, Leaf _) -> assert false + | (w, Node(x,t1,t2)) -> + if i = 0 then Node(y,t1,t2) (* The tree is pre-ordered, so the + first element is at the root. *) + else if i <= w / 2 + then Node(x, update_tree (i-1) y (w/2,t1), t2) + (* Decrement i, since we skip over the first element *) + else Node(x,t1,update_tree (i-1-(w/2)) y (w/2,t2)) + (* Subtract 1+w/2 since we skip over the first element and + all of the elements in t1. *) + +(* Return the list with the i'th element (0-indexed) in the list + replaced by v. We first find the tree which contains i'th + element, and then call update_tree to update the proper element + from that tree. Raises Not_found if the list does not have at + least i+1 elements (+1 because of 0-index). *) +let rec update i v = function + | [] -> raise Not_found + | ((w,t) as l)::ts -> + if i < w then (w, update_tree i v l)::ts + else (w,t)::(update (i-w) v ts) + +(* fold over a single tree *) +let rec fold_elt f acc = function + | Leaf x -> f acc x + | Node(x,t1,t2) -> + fold_elt f (fold_elt f (f acc x) t1) t2 + +let fold_left f acc t = + List.fold_left (fun acc (_,e) -> fold_elt f acc e) acc t + +let fold = fold_left + +let rec iter_elt f = function + | Leaf x -> f x + | Node(x,t1,t2) -> + f x; + iter_elt f t1; + iter_elt f t2 + +let iter f t = List.iter (fun (_,e) -> iter_elt f e) t + +let length t = List.fold_left (fun acc (w,_) -> acc + w) 0 t + +let from_list lst = + List.fold_left (fun acc x -> cons x acc) empty (List.rev lst) + +let to_list t = List.rev (fold_left (fun acc x -> x::acc) [] t) + +let rev t = fold_left (fun acc x -> cons x acc) empty t + +(* This could be made more efficient if we were smarter about + keeping existing trees and performing skew binary addition. The + worst case would still be O(n), but some cases would reduce to + O(log n). TODO *) +let append t1 t2 = fold_left (fun acc x -> cons x acc) t2 (rev t1) + +(* Since this will cause all of the trees to shift by one, this + operation is the worst case scenario of append. *) +let snoc x t = append t (cons x empty) + +let rec last_tree = function + | Leaf x -> x + | Node(_,_,r) -> last_tree r + +let rec last = function + | [] -> failwith "last" + | (w,t)::[] -> last_tree t + | _::tl -> last tl + +let rev_map f t = fold_left (fun acc t -> cons (f t) acc) empty t + +let rec map_tree f = function + | Leaf x -> Leaf (f x) + | Node(x,t1,t2) -> Node(f x, map_tree f t1, map_tree f t2) + +let map f t = + (* List.map is not tail recursive, but the list we are mapping is + only (log n) long, so it will only use log n stack. *) + List.map (fun (w,t) -> w, map_tree f t) t + +(* We can't use append since it is O(n). Instead we do two linear + passes over the list of lists. First we convert the list of type + ('a t t) into a list of type ('a list list), but keep both the + individual and aggregate lists in reverse order. Then we simply + fold over this collection accumulating the result using cons. *) +let flatten t = + let rlsts = + fold_left (fun acc lst -> (fold_left (fun acc x -> x::acc) [] lst)::acc) [] t + in + List.fold_left (List.fold_left (fun acc x -> cons x acc)) empty rlsts + +(* TODO: replace with more efficient version *) +let rec compare c t1 t2 = SList.compare c (to_list t1) (to_list t2) + +let to_string to_s t = ListCommon.to_string iter pop to_s t + +let gen genA ?(size=50) rs = + let t = SList.gen genA ~size:size rs in + from_list t + diff --git a/src/list/skewBinaryList.mli b/src/list/skewBinaryList.mli new file mode 100644 index 0000000..549c5a0 --- /dev/null +++ b/src/list/skewBinaryList.mli @@ -0,0 +1,155 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Random access lists based on skew binary numbers + + This module implements random access lists with O(1) [hd] and [tl] + operations and O(log n) [lookup] and [update] operations. +*) + + +type 'a t + (** The type of random access lists *) + +val empty : 'a t + (** The empty list *) + +val is_empty : 'a t -> bool + (** Returns tree if the list is emtpy. *) + +val length : 'a t -> int + (** [length t] returns the lenth of the list [t]. Runs in O(log n) + time and O(1) stack space where n is the number of elements in + the list. + *) + +val rev : 'a t -> 'a t + (** [rev t] Reverse the list [t]. Runs in O(n) run and O(1) stack + space where n is the number of elements in the list. + *) + +val cons : 'a -> 'a t -> 'a t + (** [cons x t] Adds the element [x] to the front of the list [t]. + Runs in O(1) time and stack space. + *) + +val snoc : 'a -> 'a t -> 'a t + (** [snoc x t] Adds the element [x] to the back of the list [t]. + Runs in O(n) time and O(1) stack space where n is the length of + the list. *) + +val last : 'a t -> 'a + (** [last t] Returns the element at the back of the list. If the + list is empty, it raises [Failure "last"]. Runs in O(1) stack + and O(log n) time. *) + +val hd : 'a t -> 'a + (** [hd t] Returns the element at the front of the list [t]. Runs + in O(1) time and stack space. Raises [Failure "hd"] if the list is + empty. + *) + +val tl : 'a t -> 'a t + (** [tl t] Returns the list [t] with the first element removed. + Runs in O(1) time and stack space. Raises [Failure "tl"] if the + list is empty. *) + +val pop : 'a t -> 'a * 'a t + (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. + Runs in amortized O(1) time and stack space. If the list is + empty, it raises [Failure "pop"]. *) + +val append : 'a t -> 'a t -> 'a t + (** [append t1 t2] Appends the list [t2] onto the back of list [t1]. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [t1]. *) + +val flatten : 'a t t -> 'a t + (** [flatten t] Appends all of the elements of [t] into a new list. + Runs in O(n) time and O(1) stack space where n is the sum of + each of the lists in [t]. *) + +val from_list : 'a list -> 'a t + (** [from_list l] Convert the standard list l into a SkewBinaryList. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [l]. *) + +val to_list : 'a t -> 'a list + (** [to_list t] Convert the SkewBinaryList [t] into a standard list. + Runs in O(n) time and O(1) stack space where n is the number of + elements in [t]. *) + +val iter : ('a -> unit) -> 'a t -> unit + (** [iter f t] Iterates over each element in the list [t] in order + and applies [f] to that element. Runs in O(n*ft) where ft is + the running time of [f] and uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. Runs in O(n*ft) where ft is the + running time of [f] and uses O(fs) stack space where fs is the + stack space required by [f]. *) + +val rev_map : ('a -> 'b) -> 'a t -> 'b t + (** [rev_map f t] Creates a new list by applying [f] to each element + of [t]. The resulting list is in reverse order of [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O(fs) stack space where fs is + the stack space required by [f]. *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f t] Creates a new list by applying [f] to each element of + [t]. The resulting list is in the same order as [t]. Runs in + O(n*ft) time where n is the number of elements in [t] and ft is + the running time of [f]. It uses O((fs * log n) stack space + where fs is the stack space required by [f]. This function is + slightly more efficient than {!SkewBinaryList.rev_map} (yielding + a different ordering) and significantly more efficient (by a + constant factor) than [SkewBinaryList.rev + (SkewBinaryList.rev_map t)]. *) + +val to_string : ('a -> string) -> 'a t -> string + (** [to_string to_s t] Convert the list [t] into a string using + [to_s] to individually convert each element into a string. Runs + in O(n*st) where st is the running time of [to_s] and uses O(ss) + stack space where ss is the amount of stack required by [to_s]. + *) + +val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to + compare individual elements. Returns 0 if [t1] and [t2] are + equal (under f). Returns [<0] if [t1] is less than [t2] and + returns [>0] otherwise. *) + +val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t + (** [gen f ?size rs] Generates a random list whose length is bounded + by [size]. Each element in the list is computed by calling [f + ?size rs]. Runs in time O([size] * ft) where ft is the running + time of [f] and uses O(fs) stack space where fs is the stack space + of [f]. + *) + +val lookup : int -> 'a t -> 'a + (** [lookup i t] Returns the element at position [i] (O-indexed) in + the list [t]. Raises [Not_found] if the list contains fewer + than [i-1] elements. Runs in O(min(i,log n)) time and O(1) + stack space where n is the number of elements in [t]. + *) + + +val update : int -> 'a -> 'a t -> 'a t + (** [update i v t] Returns a new list where the element in position + [i] (0-indexed) has been replaced by [v]. Raises [Not_found] if + the list contains fewer than [i-1] elements. Runs in + O(min(i,log n)) time and O(1) stack space where n is the number + of elements in [t]. + *) + + diff --git a/src/map/OMakefile b/src/map/OMakefile new file mode 100644 index 0000000..dbf58a6 --- /dev/null +++ b/src/map/OMakefile @@ -0,0 +1,9 @@ + +OCAMLINCLUDES += ../base ../iterator + +FILES[] += + map/maps + map/aVLMap + map/splayMap + map/rBMap + map/patriciaMap diff --git a/src/map/aVLMap.ml b/src/map/aVLMap.ml new file mode 100644 index 0000000..cd2562c --- /dev/null +++ b/src/map/aVLMap.ml @@ -0,0 +1,677 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** The main functor for implementing maps. The paramater field + HeightDiff.v specifies the maximum difference between the heights + of two subtrees joined at a node. +*) +module BaseMap (HeightDiff : sig val v : int end) = struct + +(** The types of AVL trees. An element can be either stored in a Leaf + if it has no children, or in a Node if it has at least 1 child. + The constructor Node(l,v,r,h) also contains the left branch 'l' (all + elements are smaller than v), the right branch 'r' (all elements + greater than v) and the heigh of the tree at that point. +*) + type ('k,'v) tree = + | Empty + | Leaf of 'k * 'v + | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree * int + + let of_result x = x + + let empty = Empty + + let singleton k v = Leaf(k,v) + + let is_empty = function + | Empty -> true + | _ -> false + + let rec find cmp x = function + | Empty -> raise Not_found + | Leaf(k,v) -> if (cmp x k) = 0 then v else raise Not_found + | Node(l,k,v,r,_) -> match cmp x k with + | 0 -> v + | c when c < 0 -> find cmp x l + | _ -> find cmp x r + + let mem cmp x t = try ignore(find cmp x t);true with Not_found -> false + + let rec fold f acc t = match t with + | Empty -> acc + | Leaf(k,v) -> f acc k v + | Node(l,k,v,r,_) -> + fold f (f (fold f acc l) k v) r + + let rec iter f t = match t with + | Empty -> () + | Leaf(k,v) -> f k v + | Node(l,k,v,r,_) -> + iter f l; f k v; iter f r + + let rec min_key = function + | Empty -> raise Not_found + | Leaf(k,_) -> k + | Node(Empty,k,_,_,_) -> k + | Node(l,_,_,_,_) -> min_key l + + let rec max_key = function + | Empty -> raise Not_found + | Leaf(k,_) -> k + | Node(_,k,_,Empty,_) -> k + | Node(_,_,_,r,_) -> max_key r + + let rec min_keyval = function + | Empty -> raise Not_found + | Leaf(k,v) -> k,v + | Node(Empty,k,v,_,_) -> k,v + | Node(l,_,_,_,_) -> min_keyval l + + let rec max_keyval = function + | Empty -> raise Not_found + | Leaf(k,v) -> k,v + | Node(_,k,v,Empty,_) -> k,v + | Node(_,_,_,r,_) -> max_keyval r + + let height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node(_,_,_,_,h) -> h + + (** N-"smart" constructor (a la Stephen Adams). This function + chooses the right constructor based on the number of children + and ensures that the Node constructor is well formed. + *) + let node l (k,v) r = + match height l, height r with + | 0,0 -> Leaf(k,v) + | hl,hr -> Node(l,k,v,r, (max hl hr)+1) + + let pivot ll lkv c rkv rr = match c with + | Node(cl,ck,cv,cr,_) -> + node (node ll lkv cl) (ck,cv) (node cr rkv rr) + | Leaf(ck,cv) -> + node (node ll lkv Empty) (ck,cv) (node Empty rkv rr) + | Empty -> assert false + + (** This function will fix the tree if the left subtree has a height + at most HeightDiff.v +1 more than that of the right subtree. *) + let rebal_left ll lkv lr kv r = + if height ll >= height lr + then node ll lkv (node lr kv r) + else pivot ll lkv lr kv r + + (** This function will fix the tree if the right subtree has a + height at most HeightDiff.v +1 more than that of the left + subtree. *) + let rebal_right l kv rl rkv rr = + if height rr >= height rl + then node (node l kv rl) rkv rr + else pivot l kv rl rkv rr + + (** T'-"smart" constructor: fixes trees by performing at most 1 + rotation. *) + let rotate l ((k,v) as kv) r = + match l,r with + (* Height 1 tree *) + | Empty, Empty -> Leaf(k,v) + + (* Height 2 tree *) + | Empty, Leaf _ + | Leaf _, Empty + | Leaf _, Leaf _ -> Node(l,k,v,r,2) + + (* General Height 'h' *) + | Node(ll,lk,lv,lr,h), Empty -> + if h > HeightDiff.v + then rebal_left ll (lk,lv) lr kv r + else Node(l,k,v,r,h+1) + | Empty, Node(rl,rk,rv,rr,h) -> + if h > HeightDiff.v + then rebal_right l kv rl (rk,rv) rr + else Node(l,k,v,r,h+1) + + | Leaf _, Node(_,_,_,_,h) (* 1 + for Leaf _ *) + | Node(_,_,_,_,h), Leaf _ when h <= (1 + HeightDiff.v) -> + Node(l,k,v,r,h+1) + + | Leaf _, Node(rl,rk,rv,rr,h) -> rebal_right l kv rl (rk,rv) rr + | Node(ll,lk,lv,lr,h), Leaf _ -> rebal_left ll (lk,lv) lr kv r + + | Node(ll,lk,lv,lr,lh), Node(rl,rk,rv,rr,rh) -> + if lh > rh + HeightDiff.v + then rebal_left ll (lk,lv) lr kv r + else if rh > lh + HeightDiff.v + then rebal_right l kv rl (rk,rv) rr + else node l kv r + + let rec add cmp k v t = match t with + | Empty -> Leaf(k,v) + | Leaf(k',v') -> + begin match cmp k k' with + | 0 -> Leaf(k,v) (* replace existing binding *) + | c when c < 0 -> Node(Empty,k,v,t,2) + | _ -> Node(t, k,v, Empty,2) + end + | Node(l,k',v',r,h) -> + match cmp k k' with + | 0 -> Node(l,k,v,r,h) (* repalce existing binding *) + | c when c < 0 -> rotate (add cmp k v l) (k',v') r + | _ -> rotate l (k',v') (add cmp k v r) + + let rec get_and_remove_min = function + | Empty -> raise (Invalid_argument "get_and_remove_min") + | Leaf(k,v) -> (k, v), Empty + | Node(Empty,k,v,r,h) -> (k, v), r + | Node(l,k,v,r,h) -> + let kv,newl = get_and_remove_min l in + kv, rotate newl (k,v) r + + let rec remove cmp delk t = match t with + | Empty -> Empty + | Leaf(k,v) + | Node(Empty,k,v,Empty,_) -> + if (cmp delk k) = 0 then Empty else t + + | Node(l,k,v,r,_) -> match cmp delk k with + | 0 -> + if r = Empty then l + else if l = Empty then r else + let kv,newr = get_and_remove_min r in + rotate l kv newr + + | c when c < 0 -> rotate (remove cmp delk l) (k,v) r + | _ -> rotate l (k,v) (remove cmp delk r) + + (** join trees of arbitrary size *) + let rec concat3 cmp l ((k,v) as kv) r = match l,r with + | Empty, r -> add cmp k v r + | l, Empty -> add cmp k v l + | Leaf _, Leaf _ -> node l kv r + | Leaf(lk,lv), Node(rl,rk,rv,rr,h) -> + if h > (1 + HeightDiff.v) + then rotate (concat3 cmp l kv rl) (rk,rv) rr + else node l kv r + | Node(ll,lk,lv,lr,h), Leaf(rk,rv) -> + if h > (1 + HeightDiff.v) + then rotate ll (lk,lv) (concat3 cmp lr kv r) + else node l kv r + | Node(ll,lk,lv,lr,lh),Node(rl,rk,rv,rr,rh) -> + if rh > lh + HeightDiff.v + then rotate (concat3 cmp l kv rl) (rk,rv) rr + else if lh > rh + HeightDiff.v + then rotate ll (lk,lv) (concat3 cmp lr kv r) + else node l kv r + + (* equivalent to (split_lt v t), (split_gt v t) *) + let rec split cmp k t = match t with + | Empty -> Empty, Empty + | Leaf(k',v') -> begin match cmp k k' with + | 0 -> Empty,Empty + | c when c < 0 -> Empty,t + | _ -> t,Empty + end + | Node(l1,k',v',r1,_) -> + match cmp k k' with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp k l1 in + (l2,concat3 cmp r2 (k',v') r1) + | _ -> + let l2,r2 = split cmp k r1 in + (concat3 cmp l1 (k',v') l2), r2 + + let rec concat t1 t2 = match t1,t2 with + | Empty, _ -> t2 + | _, Empty -> t1 + | Leaf(lk,lv), Leaf(rk,rv) -> Node(t1,rk,rv,Empty,2) + | Leaf(lk,lv), Node(rl,rk,rv,rr,h) -> + if h > 1+HeightDiff.v + then rotate (concat t1 rl) (rk,rv) rr + else + let kv,t2' = get_and_remove_min t2 in + rotate t1 kv t2' + | Node(ll,lk,lv,lr,h), Leaf(rk,rv) -> + if h > 1+HeightDiff.v + then rotate ll (lk,lv) (concat lr t2) + else rotate t1 (rk,rv) Empty (* inline get_*_min for Leaf *) + | Node(l1,k1,v1,r1,h1), Node(l2,k2,v2,r2,h2) -> + if h2 > h1 + HeightDiff.v + then rotate (concat t1 l2) (k2,v2) r2 + else if h1 > h2 + HeightDiff.v + then rotate l1 (k1,v1) (concat r1 t2) + else + let kv,t2' = get_and_remove_min t2 in + rotate t1 kv t2' + + let add_join cmp f k v t = + try + let v' = find cmp k t in + (* don't call join if the values are physically equal *) + if v' == v + then add cmp k v t + else add cmp k (f k v v') t + with Not_found -> add cmp k v t + + let rec union cmp f t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | Leaf(k,v),r -> add_join cmp f k v r + | l,Leaf(k,v) -> add_join cmp f k v l + | t1, Node(l,k,v,r,_) -> + let l',r' = split cmp k t1 in + (** This is slightly inefficient since we could use concat3 + if k \in t1, but probably not worth the refactoring *) + let t' = concat (union cmp f l' l) (union cmp f r' r) in + try let v' = find cmp k t1 in + add cmp k (f k v v') t' + with Not_found -> add cmp k v t' + + let rec diff cmp f t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, Leaf(k,v2) -> + begin try + let v1 = find cmp k t1 in + if f k v1 v2 (* does the client consider these equal values? *) + then remove cmp k t1 (* yes, so remove the binding *) + else t1 (* no, so keep the binding *) + with Not_found -> t1 + end + | _, Node(l,k,v2,r,_) -> + let l',r' = split cmp k t1 in + try + let v1 = find cmp k t1 in + if f k v1 v2 (* does v1 = v2? *) + then concat (diff cmp f l' l) (diff cmp f r' r) + (* note k must already be in t1 since find succeeded *) + else concat3 cmp (diff cmp f l' l) (k,v1) (diff cmp f r' r) + with Not_found -> + (* k's not in t1, so the split will contain all of t1 *) + concat (diff cmp f l' l) (diff cmp f r' r) + + let rec inter cmp f t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, Leaf(k,v) -> + begin try + let v' = find cmp k t1 in + if v == v' + then t2 (* already exists with the same physical value *) + else Leaf(k, (f k v v')) (* use value from t1 *) + with Not_found -> Empty + end + + | t1, Node(l,k,v,r,_) -> + let l',r' = split cmp k t1 in + begin try + let v1 = find cmp k t1 in + let v2 = f k v v1 in + concat3 cmp (inter cmp f l' l) (k,v2) (inter cmp f r' r) + with Not_found -> + concat (inter cmp f l' l) (inter cmp f r' r) + end + + let rec mapi f = function + | Empty -> Empty + | Leaf(k,v) -> let v' = f k v in Leaf(k,v') + | Node(l,k,v,r,h) -> + let l' = mapi f l in + let v' = f k v in + let r' = mapi f r in + Node(l',k,v',r',h) + + let map f t = mapi (fun _ v -> f v) t + +(* + let choose = function + | Empty -> raise Not_found + | Leaf(k,v) -> x + | Node(_,x,_,_) -> x +*) + + let rec cardinal = function + | Empty -> 0 + | Leaf _ -> 1 + | Node(l,_,_,r,_) -> 1 + (cardinal l) + (cardinal r) + + let rec compare kcmp ecmp x y = + match (is_empty x), (is_empty y) with + | true, true -> 0 + | true, false -> -1 + | false, true -> 1 + | false, false -> + let xk,xe = min_keyval x in + let yk,ye = min_keyval y in + match kcmp xk yk with + | 0 -> begin match ecmp xe ye with + | 0 -> compare kcmp ecmp (remove kcmp xk x) (remove kcmp yk y) + | v -> v + end + | v -> v + + let compare_keys kcmp s t = compare kcmp (fun _ _ -> 0) s t + + let rec well_ordered cmp = function + | Empty -> true + | Leaf _ -> true + | Node(Empty,_,_,Empty,_) -> assert false + | Node(((Leaf(lk,_))|Node(_,lk,_,_,_) as l),k,_,Empty,_) -> + (well_ordered cmp l) && (cmp lk k < 0) + | Node(Empty,k,_,((Leaf(rk,_))|Node(_,rk,_,_,_) as r),_) -> + (well_ordered cmp r) && (cmp rk k > 0) + + | Node(((Leaf(lk,_))|Node(_,lk,_,_,_) as l) + ,k,v, + ((Leaf(rk,_))|Node(_,rk,_,_,_) as r), + _) -> + (well_ordered cmp l) && (well_ordered cmp r) && + (cmp lk k < 0) && (cmp rk k > 0) + + let well_formed_height = function + | Empty | Leaf _ -> true + | Node(l,k,v,r,h) -> + let hl = height l in + let hr = height r in + (h = (max hl hr) + 1) && + (abs (hl - hr) <= HeightDiff.v) + + let rec well_formed cmp t = + (well_ordered cmp t) && (well_formed_height t) + + type ('k,'v) path = + | Top + | PathL of ('k,'v) path * 'k * 'v * ('k,'v) tree + | PathR of ('k,'v) tree * 'k * 'v * ('k,'v) path + + type ('k,'v) curs = ('k,'v) path * ('k,'v) tree + + let to_cursor t = Top,t + + let at_top (p,t) = (p = Top) + + let at_left (p,t) = match t with + | Empty | Leaf _ -> true + | _ -> false + + let at_right (p,t) = match t with + | Empty | Leaf _ -> true + | _ -> false + + let went_left (p,t) = match p with + | PathL _ -> true + | _ -> false + + let went_right (p,t) = match p with + | PathR _ -> true + | _ -> false + + let move_up = function + | Top, _ -> failwith "move_up" + | PathL(p,k,v,r),l | PathR(l,k,v,p),r -> p, (node l (k,v) r) + + let move_down_left = function + | _,Empty + | _, Leaf _ -> failwith "move_down_left" + | p, Node(l,k,v,r,h) -> PathL(p,k,v,r),l + + let move_down_right = function + | _,Empty + | _, Leaf _ -> failwith "move_down_right" + | p,Node(l,k,v,r,h) -> PathR(l,k,v,p),r + + let rec from_cursor ((p,t) as curs) = + if at_top curs then t + else from_cursor (move_up curs) + + let has_value (p,t) = match t with Empty -> false | _ -> true + + let get_value = function + | _,Empty -> failwith "get_value" + | _,Leaf(k,v) + | _,Node(_,k,v,_,_) -> k,v + + let rec move_to_ancestor cmp x ((p,t) as curs) = match p with + | Top -> curs + | PathL(p', k, v, r) -> + if cmp x k < 0 then curs + else move_to_ancestor cmp k (move_up curs) + | PathR(_,k,v,_) -> + if cmp x k > 0 then curs + else move_to_ancestor cmp k (move_up curs) + + let rec move_to cmp x curs = + let (p,t) as curs = move_to_ancestor cmp x curs in + match t with + | Empty -> raise Not_found + | Leaf(k,v) -> if (cmp x k) = 0 then curs else raise Not_found + | Node(l,k,v,r,_) -> match cmp x k with + | 0 -> curs + | c when c < 0 -> move_to cmp x (move_down_left curs) + | _ -> move_to cmp x (move_down_right curs) + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | Leaf(k,v) -> to_s k v + | Node(Empty,k,v,Empty,_) -> to_s k v + | Node(l,k,v,Empty,_) -> Printf.sprintf "%s, %s" (h l) (to_s k v) + | Node(Empty,k,v,r,_) -> Printf.sprintf "%s, %s" (to_s k v) (h r) + | Node(l,k,v,r,_) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s k v) (h r) + in + "{" ^ (h t) ^ "}" + + let gen_ cmp + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?(size=50) rs : ('k,'v) tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else + let k = kgen ~size:size rs in + let v = egen ~size:size rs in + loop (n-1) (add cmp k v t) + in + loop num empty + +end + + +module AVL_KeyMap (HeightDiff : sig val v : int end) (C : Types.Mono.Comparable) += +struct + module BH = BaseMap(HeightDiff) + include BH +(* include Cursor.Mixin(BH)*) + + type key = C.t + type 'a key_ = key + + type 'e elt = 'e + type 'e elt_ = 'e + + type 'v t = (key,'v) tree + type ('k,'v) map = 'v t + + type 'v cursor = (C.t,'v) curs + type ('k,'v) cursor_ = 'v cursor + + type ('a,'v) result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add C.compare x t + let mem x t = mem C.compare x t + let remove x t = remove C.compare x t + let find x t = find C.compare x t + let split v t = split C.compare v t + let union f t1 t2 = union C.compare f t1 t2 + let diff f t1 t2 = diff C.compare f t1 t2 + let inter f t1 t2 = inter C.compare f t1 t2 + let well_formed t = well_formed C.compare t + let move_to_ancestor cmp x c = move_to_ancestor C.compare x c + let compare x y = compare C.compare x y + let compare_keys t1 t2 = compare_keys C.compare t1 t2 +(* let equal x y = compare x y = 0*) + + let to_string to_s t = + to_string (fun k v -> + Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) + ) t + (*include Merge_mixin.Make(B)*) + + (* need to eta expand these to properly generalize the type + variables *) + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ C.compare kgen egen ?size rs +end + +module MonoKey1 = AVL_KeyMap(struct let v = 1 end) +module MonoKey2 = AVL_KeyMap(struct let v = 2 end) +module MonoKey3 = AVL_KeyMap(struct let v = 3 end) +module MonoKeyMap = MonoKey2 + +module AVL_GenKeyMap (HeightDiff : sig val v : int end) + (C : Types.Mono.ArbitraryComparable) = +struct + include AVL_KeyMap(HeightDiff)(C) + + let gen1 (agen : (?size:int -> Random.State.t -> 'a)) ?size rs : 'a t = + gen2 C.gen agen ?size rs + +end + +module GenKey1 = AVL_GenKeyMap(struct let v = 1 end) +module GenKey2 = AVL_GenKeyMap(struct let v = 2 end) +module GenKey3 = AVL_GenKeyMap(struct let v = 3 end) +module GenKeyMap = GenKey2 + +module AVL_PMap (HeightDiff : sig val v : int end) = struct + module BH = BaseMap(HeightDiff) + include BH +(* include Cursor.Mixin(BH)*) + + type 'a key = 'a + type 'a key_ = 'a + + type 'e elt = 'e + type 'e elt_ = 'e + type ('k,'v) t = ('k,'v) tree + type ('k,'v) map = ('k,'v) t + + type ('k,'v) cursor = ('k,'v) curs + type ('k,'v) cursor_ = ('k,'v) cursor + + type ('a,'k,'v) result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add Pervasives.compare x t + let mem x t = mem Pervasives.compare x t + let remove x t = remove Pervasives.compare x t + let find x t = find Pervasives.compare x t + let split v t = split Pervasives.compare v t + let union f t1 t2 = union Pervasives.compare f t1 t2 + let diff f t1 t2 = diff Pervasives.compare f t1 t2 + let inter f t1 t2 = inter Pervasives.compare f t1 t2 + let well_formed t = well_formed Pervasives.compare t + let move_to_ancestor cmp x c = move_to_ancestor Pervasives.compare x c + + (* let equal x y = compare x y = 0*) + + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ Pervasives.compare kgen egen ?size rs + + (*include Merge_mixin.Make(B)*) + +end + +module Poly1 = AVL_PMap(struct let v = 1 end) +module Poly2 = AVL_PMap(struct let v = 2 end) +module Poly3 = AVL_PMap(struct let v = 3 end) +module PolyMap = Poly2 + +module AVL_Map + (HeightDiff : sig val v : int end) + (K : Types.Mono.Comparable) + (E : Types.Mono.Comparable) += +struct + module BH = BaseMap(HeightDiff) + include BH +(* include Cursor.Mixin(BH)*) + + type key = K.t + type 'a key_ = key + + type elt = E.t + type 'e elt_ = elt + + type t = (key,elt) tree + type ('k,'v) map = t + + type cursor = (K.t,E.t) curs + type ('k,'v) cursor_ = cursor + + type 'a result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add K.compare x t + let mem x t = mem K.compare x t + let remove x t = remove K.compare x t + let find x t = find K.compare x t + let split v t = split K.compare v t + let union f t1 t2 = union K.compare f t1 t2 + let diff f t1 t2 = diff K.compare f t1 t2 + let inter f t1 t2 = inter K.compare f t1 t2 + let well_formed t = well_formed K.compare t + let move_to_ancestor cmp x c = move_to_ancestor K.compare x c + + let compare x y = compare K.compare E.compare x y + let compare_keys t1 t2 = compare_keys K.compare t1 t2 + + let to_string t = + to_string (fun k v -> + Printf.sprintf "(%s => %s)" (K.to_string k) (E.to_string v) + ) t + (*include Merge_mixin.Make(B)*) + + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ Pervasives.compare kgen egen ?size rs + +end + +module Mono1 = AVL_Map(struct let v = 1 end) +module Mono2 = AVL_Map(struct let v = 2 end) +module Mono3 = AVL_Map(struct let v = 3 end) +module MonoMap = Mono2 + +module AVL_GenMap (HeightDiff : sig val v : int end) + (K : Types.Mono.ArbitraryComparable) + (E : Types.Mono.ArbitraryComparable) = +struct + include AVL_Map(HeightDiff)(K)(E) + + let gen ?size rs = gen_ K.compare K.gen E.gen ?size rs +end + +module Gen1 = AVL_GenMap(struct let v = 1 end) +module Gen2 = AVL_GenMap(struct let v = 2 end) +module Gen3 = AVL_GenMap(struct let v = 3 end) +module GenMap = Gen2 + diff --git a/src/map/aVLMap.mli b/src/map/aVLMap.mli new file mode 100644 index 0000000..d4c4492 --- /dev/null +++ b/src/map/aVLMap.mli @@ -0,0 +1,52 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Height balanced binary search trees implementing maps *) + +module PolyMap : Maps.PolyMapSigStd +module MonoKeyMap : Maps.MonoKeyMapSigFnStd +module GenKeyMap : Maps.GenKeyMapSigFnStd +module MonoMap : Maps.MonoMapSigFnStd +module GenMap : Maps.GenMapSigFnStd + +module AVL_PMap : + functor(HeightDiff : sig val v : int end) -> Maps.PolyMapSig + +module AVL_KeyMap : + functor(HeightDiff : sig val v : int end) -> Maps.MonoKeyMapSigFnStd + +module AVL_GenKeyMap : + functor(HeightDiff : sig val v : int end) -> Maps.GenKeyMapSigFnStd + +module AVL_Map : + functor(HeightDiff : sig val v : int end) -> Maps.MonoMapSigFnStd + +module AVL_GenMap : + functor(HeightDiff : sig val v : int end) -> Maps.GenMapSigFnStd + +module Poly1 : Maps.PolyMapSig +module Poly2 : Maps.PolyMapSig +module Poly3 : Maps.PolyMapSig + +module MonoKey1 : Maps.MonoKeyMapSigFnStd +module MonoKey2 : Maps.MonoKeyMapSigFnStd +module MonoKey3 : Maps.MonoKeyMapSigFnStd + +module GenKey1 : Maps.GenKeyMapSigFnStd +module GenKey2 : Maps.GenKeyMapSigFnStd +module GenKey3 : Maps.GenKeyMapSigFnStd + +module Mono1 : Maps.MonoMapSigFnStd +module Mono2 : Maps.MonoMapSigFnStd +module Mono3 : Maps.MonoMapSigFnStd + +module Gen1 : Maps.GenMapSigFnStd +module Gen2 : Maps.GenMapSigFnStd +module Gen3 : Maps.GenMapSigFnStd + diff --git a/src/map/maps.ml b/src/map/maps.ml new file mode 100644 index 0000000..fcec96b --- /dev/null +++ b/src/map/maps.ml @@ -0,0 +1,203 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module type Map_ = sig + type 'k key_ + type 'e elt_ + type ('k,'e) map + + (* The {bool,key}_result_ types are used for operations that may + either return just a bool (key resp.) or a bool and something + else (key and something else resp.) . Most trees conform to the + former, while splay trees use the latter (e.g. the mem function + may modify the tree) *) + type ('a,'k,'e) result_ + + val empty : ('k, 'e) map + val is_empty : ('k, 'e) map -> bool + val mem : 'k key_ -> ('k, 'e) map -> (bool,'k,'e) result_ + val add : 'k key_ -> 'e elt_ -> ('k, 'e) map -> ('k, 'e) map + val singleton : 'k key_ -> 'e elt_ -> ('k, 'e) map + val remove : 'k key_ -> ('k, 'e) map -> ('k, 'e) map + val find : 'k key_ -> ('k,'e) map -> ('e elt_,'k,'e) result_ + + val min_key : ('k, 'e) map -> ('k key_,'k,'e) result_ + val max_key : ('k, 'e) map -> ('k key_,'k,'e) result_ + + val min_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ + val max_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ + + val cardinal : ('k, 'e) map -> int + + val iter : ('k key_ -> 'e elt_ -> unit) -> ('k, 'e) map -> unit + + val fold : ('acc -> 'k key_ -> 'e elt_ -> 'acc) -> 'acc -> ('k, 'e) map + -> 'acc + + val map : ('e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map + + val mapi : ('k key_ -> 'e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map + + val union : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val inter : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val diff : ('k key_ -> 'e elt_ -> 'e elt_ -> bool) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val well_formed : ('k, 'e) map -> bool + + val of_result : ('a,'k,'e) result_ -> 'a + + type ('k, 'e) cursor_ + val to_cursor : ('k, 'e) map -> ('k, 'e) cursor_ + val from_cursor : ('k, 'e) cursor_ -> ('k, 'e) map + val at_top : ('k, 'e) cursor_ -> bool + val at_left : ('k, 'e) cursor_ -> bool + val at_right : ('k, 'e) cursor_ -> bool + val move_up : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + val move_down_left : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + val move_down_right : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + + val went_left : ('k, 'e) cursor_ -> bool + val went_right : ('k, 'e) cursor_ -> bool + + val has_value : ('k, 'e) cursor_ -> bool + val get_value : ('k, 'e) cursor_ -> 'k key_ * 'e elt_ + +end + +module type PolyMapSig = sig + type ('k,'e) t + type 'k key = 'k + type 'e elt = 'e + type ('k,'e) cursor + type ('a,'k,'v) result + + include Map_ + with type 'a key_ = 'a + and type 'e elt_ = 'e + and type ('k,'e) map = ('k,'e) t + and type ('k,'e) cursor_ = ('k, 'e) cursor + and type ('a,'k,'v) result_ = ('a,'k,'v) result + + val gen2 : + (?size:int -> Random.State.t -> 'k key_) -> + (?size:int -> Random.State.t -> 'e elt_) -> + ?size:int -> Random.State.t -> ('k, 'e) map + + val to_string : ('k -> 'e -> string) -> ('k, 'e) map -> string + + val compare : ('k -> 'k -> int) -> ('e -> 'e -> int) -> ('k,'e) t + -> ('k,'e) t -> int + + val compare_keys : ('k -> 'k -> int) -> ('k,'e) t -> ('k,'e) t -> + int + +end + +module type PolyMapSigStd = PolyMapSig with type ('a,'k,'v) result = 'a + +module type MonoKeyMapSig = sig + type 'e t + type key + type 'e elt = 'e + type 'e cursor + type ('a,'v) result + + include Map_ + with type 'k key_ = key + and type 'e elt_ = 'e + and type ('k,'e) map = 'e t + and type ('k,'e) cursor_ = 'e cursor + and type ('a,'k,'v) result_ = ('a,'v) result + + val compare_keys : 'e t -> 'e t -> int + val compare : ('e -> 'e -> int) -> 'e t -> 'e t -> int + val to_string : ('e -> string) -> 'e t -> string + + val gen2 : + (?size:int -> Random.State.t -> key) -> + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t +end + +module type MonoKeyMapSigStd = MonoKeyMapSig with type ('a,'v) result = 'a + +module type MonoKeyMapSigFnStd = + functor(C : Types.Mono.Comparable) -> + MonoKeyMapSigStd with type key = C.t + +module type GenKeyMapSig = sig + include MonoKeyMapSig + val gen1 : (?size:int -> Random.State.t -> 'e) -> ?size:int -> + Random.State.t -> 'e t +end + +module type GenKeyMapSigStd = GenKeyMapSig with type ('a,'v) result = 'a + +module type GenKeyMapSigFnStd = + functor(C : Types.Mono.ArbitraryComparable) -> + GenKeyMapSigStd with type key = C.t + +module type MonoMapSig = sig + type t + type key + type elt + type cursor + type 'a result + + include Map_ + with type 'k key_ = key + and type 'e elt_ = elt + and type ('k,'e) map = t + and type ('k,'e) cursor_ = cursor + and type ('a,'k,'v) result_ = 'a result + + val compare_keys : t -> t -> int + val compare : t -> t -> int + val to_string : t -> string + + val gen2 : + (?size:int -> Random.State.t -> key) -> + (?size:int -> Random.State.t -> elt) -> + ?size:int -> Random.State.t -> t + +end + +module type MonoMapSigFn = + functor(K : Types.Mono.Comparable) -> + functor(V : Types.Mono.Comparable) -> + MonoMapSig with type key = K.t and type elt = V.t + +module type MonoMapSigFnStd = + functor(K : Types.Mono.Comparable) -> + functor(V : Types.Mono.Comparable) -> + MonoMapSig with type key = K.t and type elt = V.t + and type 'a result = 'a + +module type GenMapSig = sig + include MonoMapSig + val gen : ?size:int -> Random.State.t -> t +end + +module type GenMapSigFn = + functor(K : Types.Mono.ArbitraryComparable) -> + functor(V : Types.Mono.ArbitraryComparable) -> + GenMapSig with type key = K.t and type elt = V.t + +module type GenMapSigFnStd = + functor(K : Types.Mono.ArbitraryComparable) -> + functor(V : Types.Mono.ArbitraryComparable) -> + GenMapSig with type key = K.t and type elt = V.t + and type 'a result = 'a diff --git a/src/map/maps.mli b/src/map/maps.mli new file mode 100644 index 0000000..f4fa2d0 --- /dev/null +++ b/src/map/maps.mli @@ -0,0 +1,203 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Signature for Map ADTs *) + +module type Map_ = sig + type 'k key_ + type 'e elt_ + type ('k,'e) map + + (* The {bool,key}_result_ types are used for operations that may + either return just a bool (key resp.) or a bool and something + else (key and something else resp.) . Most trees conform to the + former, while splay trees use the latter (e.g. the mem function + may modify the tree) *) + type ('a,'k,'e) result_ + + val empty : ('k, 'e) map + val is_empty : ('k, 'e) map -> bool + val mem : 'k key_ -> ('k, 'e) map -> (bool,'k,'e) result_ + val add : 'k key_ -> 'e elt_ -> ('k, 'e) map -> ('k, 'e) map + val singleton : 'k key_ -> 'e elt_ -> ('k, 'e) map + val remove : 'k key_ -> ('k, 'e) map -> ('k, 'e) map + val find : 'k key_ -> ('k,'e) map -> ('e elt_,'k,'e) result_ + + val min_key : ('k, 'e) map -> ('k key_,'k,'e) result_ + val max_key : ('k, 'e) map -> ('k key_,'k,'e) result_ + + val min_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ + val max_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ + + val cardinal : ('k, 'e) map -> int + + val iter : ('k key_ -> 'e elt_ -> unit) -> ('k, 'e) map -> unit + + val fold : ('acc -> 'k key_ -> 'e elt_ -> 'acc) -> 'acc -> ('k, 'e) map + -> 'acc + + val map : ('e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map + + val mapi : ('k key_ -> 'e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map + + val union : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val inter : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val diff : ('k key_ -> 'e elt_ -> 'e elt_ -> bool) + -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map + + val well_formed : ('k, 'e) map -> bool + + val of_result : ('a,'k,'e) result_ -> 'a + + type ('k, 'e) cursor_ + val to_cursor : ('k, 'e) map -> ('k, 'e) cursor_ + val from_cursor : ('k, 'e) cursor_ -> ('k, 'e) map + val at_top : ('k, 'e) cursor_ -> bool + val at_left : ('k, 'e) cursor_ -> bool + val at_right : ('k, 'e) cursor_ -> bool + val move_up : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + val move_down_left : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + val move_down_right : ('k, 'e) cursor_ -> ('k, 'e) cursor_ + + val went_left : ('k, 'e) cursor_ -> bool + val went_right : ('k, 'e) cursor_ -> bool + + val has_value : ('k, 'e) cursor_ -> bool + val get_value : ('k, 'e) cursor_ -> 'k key_ * 'e elt_ + +end + +module type PolyMapSig = sig + type ('k,'e) t + type 'k key = 'k + type 'e elt = 'e + type ('k,'e) cursor + type ('a,'k,'v) result + + include Map_ + with type 'a key_ = 'a + and type 'e elt_ = 'e + and type ('k,'e) map = ('k,'e) t + and type ('k,'e) cursor_ = ('k, 'e) cursor + and type ('a,'k,'v) result_ = ('a,'k,'v) result + + val gen2 : + (?size:int -> Random.State.t -> 'k key_) -> + (?size:int -> Random.State.t -> 'e elt_) -> + ?size:int -> Random.State.t -> ('k, 'e) map + + val to_string : ('k -> 'e -> string) -> ('k, 'e) map -> string + + val compare : ('k -> 'k -> int) -> ('e -> 'e -> int) -> ('k,'e) t + -> ('k,'e) t -> int + + val compare_keys : ('k -> 'k -> int) -> ('k,'e) t -> ('k,'e) t -> + int + +end + +module type PolyMapSigStd = PolyMapSig with type ('a,'k,'v) result = 'a + +module type MonoKeyMapSig = sig + type 'e t + type key + type 'e elt = 'e + type 'e cursor + type ('a,'v) result + + include Map_ + with type 'k key_ = key + and type 'e elt_ = 'e + and type ('k,'e) map = 'e t + and type ('k,'e) cursor_ = 'e cursor + and type ('a,'k,'v) result_ = ('a,'v) result + + val compare_keys : 'e t -> 'e t -> int + val compare : ('e -> 'e -> int) -> 'e t -> 'e t -> int + val to_string : ('e -> string) -> 'e t -> string + + val gen2 : + (?size:int -> Random.State.t -> key) -> + (?size:int -> Random.State.t -> 'a) -> + ?size:int -> Random.State.t -> 'a t +end + +module type MonoKeyMapSigStd = MonoKeyMapSig with type ('a,'v) result = 'a + +module type MonoKeyMapSigFnStd = + functor(C : Types.Mono.Comparable) -> + MonoKeyMapSigStd with type key = C.t + +module type GenKeyMapSig = sig + include MonoKeyMapSig + val gen1 : (?size:int -> Random.State.t -> 'e) -> ?size:int -> + Random.State.t -> 'e t +end + +module type GenKeyMapSigStd = GenKeyMapSig with type ('a,'v) result = 'a + +module type GenKeyMapSigFnStd = + functor(C : Types.Mono.ArbitraryComparable) -> + GenKeyMapSigStd with type key = C.t + +module type MonoMapSig = sig + type t + type key + type elt + type cursor + type 'a result + + include Map_ + with type 'k key_ = key + and type 'e elt_ = elt + and type ('k,'e) map = t + and type ('k,'e) cursor_ = cursor + and type ('a,'k,'v) result_ = 'a result + + val compare_keys : t -> t -> int + val compare : t -> t -> int + val to_string : t -> string + + val gen2 : + (?size:int -> Random.State.t -> key) -> + (?size:int -> Random.State.t -> elt) -> + ?size:int -> Random.State.t -> t + +end + +module type MonoMapSigFn = + functor(K : Types.Mono.Comparable) -> + functor(V : Types.Mono.Comparable) -> + MonoMapSig with type key = K.t and type elt = V.t + +module type MonoMapSigFnStd = + functor(K : Types.Mono.Comparable) -> + functor(V : Types.Mono.Comparable) -> + MonoMapSig with type key = K.t and type elt = V.t + and type 'a result = 'a + +module type GenMapSig = sig + include MonoMapSig + val gen : ?size:int -> Random.State.t -> t +end + +module type GenMapSigFn = + functor(K : Types.Mono.ArbitraryComparable) -> + functor(V : Types.Mono.ArbitraryComparable) -> + GenMapSig with type key = K.t and type elt = V.t + +module type GenMapSigFnStd = + functor(K : Types.Mono.ArbitraryComparable) -> + functor(V : Types.Mono.ArbitraryComparable) -> + GenMapSig with type key = K.t and type elt = V.t + and type 'a result = 'a diff --git a/src/map/patriciaMap.ml b/src/map/patriciaMap.ml new file mode 100644 index 0000000..c783c5b --- /dev/null +++ b/src/map/patriciaMap.ml @@ -0,0 +1,390 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module Map_ = struct + + type key = int + type 'a key_ = key + + type 'a tree = + | Empty + | Leaf of int * 'a + | Branch of int * int * 'a tree * 'a tree (* (prefix * branchbit * l * r) *) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let singleton k v = Leaf(k,v) + + let zero_bit k m = (k land m) = 0 + + let mask k m = (k lor (m-1)) land (lnot m) + + let match_prefix k p m = (mask k m) = p + + let lowest_bit x = x land (-x) + + let highest_bit x m = + let x' = x land (lnot (m-1)) in + let rec highb x = + let m = lowest_bit x in + if x = m then m else highb (x-m) + in highb x' + + let branching_bit p0 m0 p1 m1 = + highest_bit (p0 lxor p1) (max 1 (2*(max m0 m1))) + + let rec find x = function + | Empty -> raise Not_found + | Leaf(k,v) -> if x = k then v else raise Not_found + | Branch(p,m,t0,t1) -> + if not (match_prefix x p m) then raise Not_found + else if zero_bit x m then find x t0 + else find x t1 + + let mem x t = try ignore(find x t);true with Not_found -> false + + let branch p m t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | _ -> Branch(p,m,t1,t2) + + let get_branch_bit = function + | Empty | Leaf _ -> 0 + | Branch(_,b,_,_) -> b + + let join p0 t0 p1 t1 = + let m = branching_bit p0 (get_branch_bit t0) p1 (get_branch_bit t1) in + if zero_bit p0 m then Branch(mask p0 m, m, t0, t1) + else Branch(mask p0 m, m, t1, t0) + + let add k v t = + let rec ins = function + | Empty -> Leaf(k,v) + | Leaf(k',v') as t -> + if k = k' then Leaf(k,v) (* repalce binding *) + else join k (Leaf(k,v)) k' t + | Branch(p,m,t0,t1) as t -> + if match_prefix k p m then + if zero_bit k m then Branch(p,m,ins t0, t1) + else Branch(p,m,t0,ins t1) + else join k (Leaf(k,v)) p t + in ins t + + let rec merge f s t = match s,t with + | Empty,t | t,Empty -> t + | Leaf(k,v), t | t, Leaf(k,v) -> + begin try + let v' = find k t in + if v == v' then add k v t + else add k (f k v v') t + with Not_found -> add k v t + end + | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m then (* same prefix, just recurse *) + Branch(p,m,merge f s0 t0, merge f s1 t1) + + else if m > n && match_prefix q p m then (* q contains p*) + if zero_bit q m + then Branch(p,m,merge f s0 t,s1) + else Branch(p,m,s0,merge f s1 t) + else if m < n && match_prefix p q n then (* p contains q*) + if zero_bit p n + then Branch(q,n,merge f s t0,t1) + else Branch(q,n,t0,merge f s t1) + else (* different prefixes *) + join p s q t + + let rec remove x t = match t with + | Empty -> Empty + | Leaf(k,v) -> if x = k then Empty else t + | Branch (p,m,t0,t1) -> + if match_prefix x p m then + if zero_bit x m + then branch p m (remove x t0) t1 + else branch p m t0 (remove x t1) + else t + + let rec min_key = function + | Empty -> raise Not_found + | Leaf(k,_) -> k + | Branch(_,_,t0,_) -> min_key t0 + + let rec max_key = function + | Empty -> raise Not_found + | Leaf(k,_) -> k + | Branch(_,_,_,t1) -> max_key t1 + + let rec min_keyval = function + | Empty -> raise Not_found + | Leaf(k,v) -> k,v + | Branch(_,_,t0,_) -> min_keyval t0 + + let rec max_keyval = function + | Empty -> raise Not_found + | Leaf(k,v) -> k,v + | Branch(_,_,_,t1) -> max_keyval t1 + + let rec cardinal = function + | Empty -> 0 + | Leaf _ -> 1 + | Branch (_,_,t0,t1) -> (cardinal t0) + (cardinal t1) + + let rec iter f = function + | Empty -> () + | Leaf(k,v) -> f k v + | Branch(_,_,t0,t1) -> iter f t0; iter f t1 + + let rec fold f acc t = match t with + | Empty -> acc + | Leaf(k,v) -> f acc k v + | Branch (_,_,t0,t1) -> fold f (fold f acc t0) t1 + + let rec no_empty_under_branch = function + | Empty -> true + | Leaf _ -> true + | Branch(_,_,Empty,_) + | Branch(_,_,_,Empty) -> false + | Branch(_,_,t0,t1) -> + (no_empty_under_branch t0) && (no_empty_under_branch t1) + + let well_formed t = + no_empty_under_branch t + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | Leaf(k,v) -> Printf.sprintf "(%d => %s)" k (to_s v) + | Branch(_,_,subt,Empty) -> h subt + | Branch(_,_,Empty,subt) -> h subt + | Branch(_,_,t0,t1) -> Printf.sprintf "%s, %s" (h t0) (h t1) + in "{" ^ (h t) ^ "}" + + let rec compare cmp s t = match s,t with + | Empty, Empty -> 0 + | Empty, _ -> -1 + | _, Empty -> 1 + + | Leaf(lk,lv), Leaf(rk,rv) -> + (** pervasives is ok since keys always have type int *) + let res = Pervasives.compare lk rk in + if res = 0 then cmp lv rv + else res + | Leaf _, Branch _ -> -1 + | Branch _, Leaf _ -> 1 + + | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> + if p < q then -1 + else if p > q then 1 + else if m < n then -1 + else if m > n then 1 + else match compare cmp s0 t0 with + | 0 -> compare cmp s1 t1 + | c -> c + + let compare_keys s t = compare (fun _ _ -> 0) s t + + let rec equal elt_eq s t = match s,t with + | Empty, Empty -> true + | Empty, _ | _, Empty -> false + + | Leaf(lk,lv), Leaf(rk,rv) -> (lk = rk) && (elt_eq lv rv) + + | Leaf _, Branch _ | Branch _, Leaf _ -> false + + | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> + (p=q) && (m=n) && equal elt_eq s0 t0 && equal elt_eq s1 t1 + + let union = merge + + (** if k is not in t then return s. Otherwise if f returns true + when applied to the k and the respective values, return s with k + removed. Otherwise return s unchanged. *) + let remove_if f k v s t = + begin try + let v' = find k t in + if f k v v' (* are they "equal" in the user's eyes? *) + then remove k s (* yes, remove the leaf *) + else s (* no keep the leaf *) + with Not_found -> s + end + + let never_merge k v v = assert false + + let rec diff f s t = match s,t with + | Empty,t -> Empty + | s,Empty -> s + | Leaf(k,v), t -> remove_if f k v s t + | s, Leaf(k,v) -> remove_if f k v s s + | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m (* same prefix, just recurse *) + then merge never_merge (diff f s0 t0) (diff f s1 t1) + + else if m > n && match_prefix q p m then (* q contains p*) + if zero_bit q m + then merge never_merge (diff f s0 t) s1 + else merge never_merge s0 (diff f s1 t) + + else if m < n && match_prefix p q n then (* p contains q*) + if zero_bit p n + then diff f s t0 + else diff f s t1 + + else (* different prefixes *) + s + + let rec inter f s t = match s,t with + | Empty,_ -> Empty | _,Empty -> Empty + + | Leaf(k,v), t + | t, Leaf(k,v) -> + begin try + let v' = find k t in + Leaf(k,f k v v') + with Not_found -> Empty + end + + | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m (* same prefix, just recurse *) + then merge never_merge (inter f s0 t0) (inter f s1 t1) + + else if m > n && match_prefix q p m then (* q contains p *) + if zero_bit q m + then inter f s0 t + else inter f s1 t + + else if m < n && match_prefix p q n then (* p contains q *) + if zero_bit p n + then inter f s t0 + else inter f s t1 + + else (* different prefixes *) + Empty + + let rec mapi f = function + | Empty -> Empty + | Leaf(k,v) -> Leaf(k, f k v) + | Branch(p,m,l,r) -> Branch(p,m,mapi f l, mapi f r) + + let map f t = mapi (fun _ v -> f v) t + + let gen2 + (kgen : (?size:int -> Random.State.t -> int)) + (vgen : (?size:int -> Random.State.t -> 'v)) + ?(size=50) rs : 'v tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else + let k = kgen ~size:size rs in + let v = vgen ~size:size rs in + loop (n-1) (add k v t) + in + loop num empty + + let gen1 (vgen : (?size:int -> Random.State.t -> 'v)) + ?size rs : 'v tree = + gen2 Types.Int.gen vgen ?size rs + + type 'a path = + | Top + | PathL of 'a path * 'a tree + | PathR of 'a tree * 'a path + + type 'a curs = 'a path * 'a tree + + let to_cursor t = Top,t + + let at_top = function + | Top,_ -> true + | _ -> false + + let at_right = function + | _, Empty + | _,Leaf _ -> true + | _ -> false + + let at_left = at_right + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let move_up = function + | Top, _ -> failwith "move_up" + | PathL(p,r),l -> p, (merge (fun k v1 v2 -> v1) l r) + (* we use the join function to choose the binding which + was modified in by values in the subtree of the cursor *) + | PathR(l,p),r -> p, (merge (fun k v1 v2 -> v2) l r) + + let move_down_right (p,t) = match t with + | Empty | Leaf _ -> failwith "move_down_right" + | Branch(_,_,_,r) -> PathR(t,p),r + + let move_down_left (p,t) = match t with + | Empty | Leaf _ -> failwith "move_down_left" + | Branch(_,_,l,_) -> PathL(p,t),l + + let has_value = function _,Leaf _ -> true | _ -> false + + let get_value = function + | _,Leaf(k,v) -> k,v + | _,_ -> failwith "get_value" + + let rec from_cursor curs = + if at_top curs then snd curs + else from_cursor (move_up curs) + + let of_result x = x +end + + +module MonoKeyMap = struct + include Map_ + + type ('k,'v) map = 'v tree + type 'a t = 'a tree + + type 'e elt = 'e + type 'e elt_ = 'e + + type 'v cursor = 'v curs + type ('k,'v) cursor_ = 'v cursor + + type ('a,'e) result = 'a + type ('a,'k,'e) result_ = 'a + +end + +module GenKeyMap = MonoKeyMap + +module MonoMap(C : Types.Mono.Comparable) = struct + + include Map_ + + type ('k,'v) map = C.t tree + + type t = C.t tree + type elt = C.t + type 'e elt_ = C.t + + type cursor = C.t curs + type ('k,'v) cursor_ = cursor + + type 'a result = 'a + type ('a,'k,'e) result_ = 'a + + let compare x y = compare C.compare x y + let to_string t = to_string C.to_string t +end + +module GenMap(C : Types.Mono.ArbitraryComparable) = struct + include MonoMap(C) + + let gen ?size rs = gen1 C.gen ?size rs +end diff --git a/src/map/patriciaMap.mli b/src/map/patriciaMap.mli new file mode 100644 index 0000000..14b8565 --- /dev/null +++ b/src/map/patriciaMap.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Efficient maps over integers *) + +module MonoKeyMap : + Maps.MonoKeyMapSig with type key = int + and type 'e elt = 'e + +module GenKeyMap : + Maps.GenKeyMapSig with type key = int + and type 'e elt = 'e + +module MonoMap : + functor(C : Types.Mono.Comparable) -> + Maps.MonoMapSig with type key = int + and type elt = C.t + +module GenMap : + functor(C : Types.Mono.ArbitraryComparable) -> + Maps.GenMapSig with type key = int + and type elt = C.t diff --git a/src/map/rBMap.ml b/src/map/rBMap.ml new file mode 100644 index 0000000..fa2392c --- /dev/null +++ b/src/map/rBMap.ml @@ -0,0 +1,674 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module BaseMap = struct + (* Red/Black Trees follow: + 1) all nodes are Red or Black + 2) The root is black + 3) Empty Trees (i.e. leafs) are black + 4) Both children of a red node are black + 5) Every path from a leaf to the root has the same "black height" + *) + + (* save a cell by encoding the color in the constructor *) + type ('a,'b) tree = + | Empty + | RNode of ('a,'b) tree * 'a * 'b * ('a,'b) tree + | BNode of ('a,'b) tree * 'a * 'b * ('a,'b) tree + + let of_result x = x + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let singleton k v = BNode(Empty,k,v,Empty) + + let is_black = function + | Empty -> true + | BNode _ -> true + | RNode _ -> false + + let rec black_height t = + let rec bh acc = function + | Empty -> 1+acc + | RNode(l,_,_,r) -> bh acc l + | BNode(l,_,_,r) -> bh (acc+1) l + in bh 0 t + + (* true if the top of sub is lt x *) + let sub_lt cmp x sub = match sub with + | RNode(_,k,_,_) + | BNode(_,k,_,_) -> cmp k x < 0 + | _ -> assert false + + let sub_gt cmp x sub = match sub with + | RNode(_,k,_,_) + | BNode(_,k,_,_) -> cmp k x > 0 + | _ -> assert false + + let rec well_ordered cmp = function + | Empty -> true + | RNode(Empty,_,_,Empty) | BNode(Empty,_,_,Empty) -> true + + | BNode(Empty,k,_,r) + | RNode(Empty,k,_,r) -> sub_gt cmp k r && well_ordered cmp r + | BNode(l,k,_,Empty) + | RNode(l,k,_,Empty) -> sub_lt cmp k l && well_ordered cmp l + + | RNode(l,e,_,r) | BNode(l,e,_,r) -> + sub_lt cmp e l && sub_gt cmp e r && + well_ordered cmp l && well_ordered cmp r + + let rec check_red_children = function + | Empty -> true + | BNode(l,_,_,r) -> check_red_children l && check_red_children r + | RNode(l,_,_,r) -> is_black l && is_black r && + check_red_children l && check_red_children r + + let rec check_black_height = function + | Empty -> true + | RNode(l,_,_,r) | BNode(l,_,_,r) -> + if ((black_height l) = (black_height r)) + then (check_black_height l) && (check_black_height r) + else failwith "black height is off" + + let well_formed cmp t = + well_ordered cmp t && + is_black t && (* prop 2 *) + check_red_children t && (* prop 4 *) + check_black_height t (* prop 5 *) + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | RNode(Empty,k,v,Empty) | BNode(Empty,k,v,Empty) -> to_s k v + | RNode(l,k,v,Empty) | BNode(l,k,v,Empty) -> + Printf.sprintf "%s, %s" (h l) (to_s k v) + | RNode(Empty,k,v,r) | BNode(Empty,k,v,r) -> + Printf.sprintf "%s, %s" (to_s k v) (h r) + | RNode(l,k,v,r) | BNode(l,k,v,r) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s k v) (h r) + in "{" ^ (h t) ^ "}" + + let rec min_keyval t = match t with + | Empty -> raise Not_found + | RNode(Empty,k,v,_) | BNode(Empty,k,v,_) -> k,v + | RNode(l,_,_,_) | BNode(l,_,_,_) -> min_keyval l + + let rec max_keyval t = match t with + | Empty -> raise Not_found + | RNode(_,k,v,Empty) | BNode(_,k,v,Empty) -> k,v + | RNode(_,_,_,r) | BNode(_,_,_,r) -> max_keyval r + + let min_key t = fst (min_keyval t) + let max_key t = fst (max_keyval t) + + let rec find cmp x t = match t with + | Empty -> raise Not_found + | RNode(l,k,v,r) | BNode(l,k,v,r) -> match cmp x k with + | 0 -> v + | c when c < 0 -> find cmp x l + | _ -> find cmp x r + + let mem cmp x t = try ignore(find cmp x t);true with Not_found -> false + + (* Okasaki's rebalancing constructor *) + let bal_l l (k,v) r = match l with + | RNode(RNode(t1,k1,v1,t2),k2,v2,t3) + | RNode(t1,k1,v1,RNode(t2,k2,v2,t3)) -> + RNode(BNode(t1,k1,v1,t2),k2,v2,BNode(t3,k,v,r)) + | _ -> BNode(l,k,v,r) + + let bal_r l (k,v) r = match r with + | RNode(RNode(t2,k2,v2,t3),k3,v3,t4) + | RNode(t2,k2,v2,RNode(t3,k3,v3,t4)) -> + RNode(BNode(l,k,v,t2),k2,v2,BNode(t3,k3,v3,t4)) + | _ -> BNode(l,k,v,r) + + let rec ins cmp x y t = match t with + | Empty -> RNode(Empty,x,y,Empty) + | RNode(l,k,v,r) -> begin match cmp x k with + | 0 -> t + (* impossible to violate black height property with a + red node here, so no need to rebalance *) + | c when c < 0 -> RNode(ins cmp x y l,k,v,r) + | _ -> RNode(l,k,v,ins cmp x y r) + end + | BNode(l,k,v,r) -> begin match cmp x k with + | 0 -> t + | c when c < 0 -> bal_l (ins cmp x y l) (k,v) r + | _ -> bal_r l (k,v) (ins cmp x y r) + end + + let blackify = function + | RNode(l,k,v,r) -> BNode(l,k,v,r) + | t -> t + + let add cmp x y t = blackify (ins cmp x y t) + + let redify = function + | BNode(l,k,v,r) -> RNode(l,k,v,r) + | _ -> assert false + + let balance l (k,v) r = match l,k,v,r with + (* TODO: investigate this first constructor proposed by Kahrs. + Is it better to move Red nodes up?*) + | RNode(a,xk,xv,b),yk,yv,RNode(c,zk,zv,d) + | RNode(RNode(a,xk,xv,b),yk,yv,c),zk,zv,d + | RNode(a,xk,xv,RNode(b,yk,yv,c)),zk,zv,d + | a,xk,xv,RNode(b,yk,yv,RNode(c,zk,zv,d)) + | a,xk,xv,RNode(RNode(b,yk,yv,c),zk,zv,d) -> + RNode(BNode(a,xk,xv,b),yk,yv,BNode(c,zk,zv,d)) + + | a,k,v,b -> BNode(a,k,v,b) + + let balleft l ((k,v) as elt) r = match l with + | RNode(ll,lk,lv,lr) -> RNode(BNode(ll,lk,lv,lr),k,v,r) + | _ -> match r with + | BNode(rl,rk,rv,rr) -> balance l elt (RNode(rl,rk,rv,rr)) + | RNode(BNode(a,yk,yv,b),zk,zv,c) -> + RNode(BNode(l,k,v,a), yk, yv, (balance b (zk,zv) (redify c))) + | _ -> assert false + + let balright l ((k,v) as elt) r = match r with + | RNode(b,yk,yv,c) -> RNode(l,k,v,BNode(b,yk,yv,c)) + | _ -> match l with + | BNode(a,xk,xy,b) -> balance (RNode(a,xk,xy,b)) elt r + | RNode(a,xk,xv,BNode(b,yk,yv,c)) -> + RNode(balance (redify a) (xk,xv) b, yk, yv, (BNode(c,k,v,l))) + | _ -> assert false + + let rec app l r = match l,r with + | Empty,_ -> r + | _,Empty -> l + | RNode(a,xk,xv,b), RNode(c,yk,yv,d) -> begin match app b c with + | RNode(b',zk,zv,c') -> RNode(RNode(a,xk,xv,b'),zk,zv,RNode(c',yk,yv,d)) + | bc -> RNode(a,xk,xv,RNode(bc,yk,yv,d)) + end + | BNode(a,xk,xv,b), BNode(c,yk,yv,d) -> begin match app b c with + | RNode(b',zk,zv,c') -> RNode(BNode(a,xk,xv,b'),zk,zv,BNode(c',yk,yv,d)) + | bc -> balleft a (xk,xv) (BNode(bc, yk, yv, d)) + end + | a, RNode(b,xk,xv,c) -> RNode(app a b, xk,xv, c) + | RNode(a,xk,xv,b), c -> RNode(a,xk,xv,app b c) + + (* based on Stefan Kahrs work on RB trees *) + let rec del cmp x t = match t with + | Empty -> Empty + | BNode(l,k,v,r) | RNode(l,k,v,r) -> match cmp x k with + | 0 -> app l r + | c when c < 0 -> del_left cmp x l (k,v) r + | _ -> del_right cmp x l (k,v) r + and del_left cmp x l ((k,v) as elt) r = match l with + | BNode _ -> balleft (del cmp x l) elt r + | _ -> RNode(del cmp x l, k,v, r) + and del_right cmp x l ((k,v) as elt) r = match r with + | BNode _ -> balright l elt (del cmp x r) + | _ -> RNode(l,k,v,del cmp x r) + + let remove cmp x t = blackify (del cmp x t) + + (* join trees of arbitrary size *) + (* This is still really inefficient since it keeps calling + black_height which O(log n) raising this to O(n log n). Should + only call these once in union/diff/inter and then keep track of + local differences. *) + let rec concat3h cmp l (k,v) r hl hr = + match hl - hr with + | 0 -> begin match l,r with + | BNode _, BNode _ -> RNode(l,k,v,r) + | _ -> BNode(l,k,v,r) + end + + | -1 -> (* r has at exactly 1 extra black node *) + begin match l,r with + | _, Empty -> assert false (* r must have at least 2 black nodes *) + + | RNode(ll,lk,lv,lr),_ -> + (* if l is red, just color it black to match r *) + BNode(BNode(ll,lk,lv,lr),k,v,r) + + | _,RNode(rl,rk,rv,rr) -> + (* rl and rr must be black by (4) *) + (* recurse to force l=blk rl=blk *) + balance (concat3h cmp l (k,v) rl hl hr) (rk,rv) rr + + | _,BNode(rl,rk,rv,rr) -> + begin match rl,rr with + | (BNode _|Empty), (BNode _|Empty) -> + (*both black, so color their parent red to drop BH, + then use bnode as parent to restore height *) + BNode(l,k,v,RNode(rl,rk,rv,rr)) + + | RNode _, RNode _ -> + (* push black down to rr and connect rl with l *) + RNode(BNode(l,k,v,rl),rk,rv, blackify(rr)) + + | (BNode _|Empty), RNode _ -> + (* RNode(l,v,rl) will have same height as rr *) + BNode(RNode(l,k,v,rl),rk,rv,rr) + + | RNode(rll,rlk,rlv,rlr), (BNode _|Empty) -> + (* rll and rlr are black, and all of l,rll,rlr,rr have same BH *) + RNode(BNode(l,k,v,rll), rlk, rlv, BNode(rlr,rk, rv,rr)); + end + end + | 1 -> (* l has at exactly 1 extra black node *) + begin match l,r with + | Empty,_ -> assert false (* l must have at least 2 black nodes *) + + | _,RNode(rl,rk,rv,rr) -> + (* if r is red, just color it black to match l *) + BNode(l,k,v,BNode(rl,rk,rv,rr)) + + | RNode(ll,lk,lv,lr),_ -> + (* ll and lr must be black by (4) *) + (* recurse to force l=blk rl=blk *) + balance ll (lk,lv) (concat3h cmp lr (k,v) r hl hr) + + | BNode(ll,lk,lv,lr),_ -> + begin match ll,lr with + | (BNode _|Empty), (BNode _|Empty) -> + (*both black, so color their parent red to drop BH, + then use bnode as parent to restore height *) + BNode(RNode(ll,lk,lv,lr),k,v,r) + + | RNode _, RNode _ -> + (* push black down to ll and connect lr with r *) + RNode(blackify(ll),lk,lv,BNode(lr,k,v,r)) + + | (BNode _|Empty), RNode(lrl,lrk,lrv,lrr) -> + (* lrl and lrr are black, and all of l,rll,rlr,rr have same BH *) + RNode(BNode(ll,lk,lv,lrl), lrk, lrv, BNode(lrr,k,v,r)) + + | RNode _, (BNode _|Empty) -> + (* RNode(lr,v,r) will have same height as ll *) + BNode(ll,lk,lv,RNode(lr,k,v,r)) + end + end + | c when c < -1 -> (* r has at least 2 more black nodes *) + begin match r with + | Empty -> assert false + | RNode(rl,rk,rv,rr) -> + let t1 = concat3h cmp l (k,v) rl hl hr in + let hl = black_height t1 in + let t2 = concat3h cmp t1 (rk,rv) rr hl hr in + t2 + | BNode(rl,rk,rv,rr) -> + let t1 = concat3h cmp l (k,v) rl hl (hr-1) in + let hl = black_height t1 in + let t2 = concat3h cmp t1 (rk,rv) rr hl (hr-1)in + + t2 + end + | _ -> match l with (* l has at least 2 more black nodes *) + | Empty -> assert false + | RNode(ll,lk,lv,lr) -> + let t1 = concat3h cmp lr (k,v) r hl hr in + let hr = black_height t1 in + let t' = concat3h cmp ll (lk,lv) t1 hl hr in + t' + | BNode(ll,lk,lv,lr) -> + let t1 = concat3h cmp lr (k,v) r (hl-1) hr in + let hr = black_height t1 in + let t' = concat3h cmp ll (lk,lv) t1 (hl-1) hr in + t' + + and concat3 cmp l v r = + let hl = black_height l in + let hr = black_height r in + concat3h cmp l v r hl hr + + let rec split cmp s t = match t with + | Empty -> Empty, Empty + | BNode(l1,k,v,r1) + | RNode(l1,k,v,r1) -> + match cmp s k with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp s l1 in + let t' = concat3 cmp r2 (k,v) r1 in + (l2,t') + | _ -> + let l2,r2 = split cmp s r1 in + let t' = concat3 cmp l1 (k,v) l2 in + t', r2 + + (* Inefficient, easy version for now *) + let get_and_remove_min cmp t = + let (k,v as kv) = min_keyval t in + kv, (remove cmp k t) + + (* Inefficient, easy version for now *) + let concat cmp t1 t2 = + if is_empty t2 + then t1 + else + let rm,t2 = get_and_remove_min cmp t2 in + concat3 cmp t1 rm t2 + + let union cmp f t1 t2 = + let rec u t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | t1, (BNode(l,k,v,r) | RNode(l,k,v,r)) -> + let l',r' = split cmp k t1 in + let t' = concat cmp (u l' l) (u r' r) in + try let v' = find cmp k t1 in + add cmp k (f k v v') t' + with Not_found -> add cmp k v t' + in blackify (u t1 t2) + + let rec diff cmp f t1 t2 = + let rec helper t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, (BNode(l,k,v,r)|RNode(l,k,v,r)) -> + let l',r' = split cmp k t1 in + concat cmp (helper l' l) (helper r' r) + in + blackify (helper t1 t2) + + let rec inter cmp f t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, (BNode(l,k,v,r)|RNode(l,k,v,r)) -> + let l',r' = split cmp k t1 in + let t = + begin try + let v1 = find cmp k t1 in + let v2 = f k v v1 in + concat3 cmp (inter cmp f l' l) (k,v2) (inter cmp f r' r) + with Not_found ->concat cmp (inter cmp f l' l) (inter cmp f r' r) + end + in blackify t + + let rec mapi f = function + | Empty -> Empty + | RNode(l,k,v,r) -> RNode(mapi f l, k, f k v, mapi f r) + | BNode(l,k,v,r) -> BNode(mapi f l, k, f k v, mapi f r) + + let map f t = mapi (fun _ v -> f v) t + + let rec cardinal = function + | Empty -> 0 + | BNode(l,_,_,r) | RNode(l,_,_,r) -> 1 + (cardinal l) + (cardinal r) + + let rec iter f = function + | Empty -> () + | RNode(l,k,v,r) | BNode(l,k,v,r) -> + iter f l; f k v; iter f r + + let rec fold f acc t = match t with + | Empty -> acc + | RNode(l,k,v,r) | BNode(l,k,v,r) -> + fold f (f (fold f acc l) k v) r + + type ('a,'b) path = + | Top + | PathL of ('a,'b) path * 'a * 'b * ('a,'b) tree * bool (* is_black *) + | PathR of ('a,'b) tree * 'a * 'b * ('a,'b) path * bool (* is_black *) + + type ('a,'b) curs = ('a,'b) path * ('a,'b) tree + + let to_cursor c = Top, c + + let has_value = function + | _,Empty -> false + | _ -> true + + let get_value = function + | _,Empty -> failwith "get_value" + | _,RNode(_,k,v,_) + | _,BNode(_,k,v,_) -> k,v + + let at_top = function (Top,_) -> true | _ -> false + + let at_left (_,t) = match t with + | Empty -> true + | _ -> false + + let at_right (_,t) = match t with + | Empty -> true + | _ -> false + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let try_color blk t = + if blk then blackify t + else match t with + (* try to color t red *) + | Empty -> t (* can't *) + | RNode _ -> t (* already *) + | BNode(l', k', v', r') -> + if is_black l' && is_black r' + then RNode(l',k', v',r') (* can change to red and still satisfy (4) *) + else t (* have to leave it black *) + + let move_up cmp = function + | Top, _ -> failwith "move_up" + | PathL(p,k,v,r,blk),l + | PathR(l,k,v,p,blk),r -> + let t = concat3 cmp l (k,v) r in + (* We try and keep the same color as the original tree if + possible so that we don't do any unnecessary rotations + when rebuilding the tree. Besides being more efficient, + this is also required to make traversals work properly + (otherwise the tree might rotate in the middle of the + traversal, giving incorrect results *) + let t = try_color blk t in + p, t + + let move_down_left = function + | _,Empty -> failwith "move_down_left" + | p, RNode(l,k,v,r) -> PathL(p,k,v,r,false),l + | p, BNode(l,k,v,r) -> PathL(p,k,v,r,true),l + + let move_down_right = function + | _,Empty -> failwith "move_down_right" + | p,RNode(l,k,v,r) -> PathR(l,k,v,p,false),r + | p,BNode(l,k,v,r) -> PathR(l,k,v,p,true),r + + let rec from_cursor cmp curs = + if at_top curs then blackify (snd curs) + else from_cursor cmp (move_up cmp curs) + + (** Step the cursor one position "in-order". Does not keep any + state *) + let rec step_io = function + | Top, Empty -> raise Exit + | PathL(p,k,v,r,_),Empty -> (k,v),(p,r) + | p, RNode(l,k,v,r) -> step_io (PathL(p,k,v,r,false),l) + | p, BNode(l,k,v,r) -> step_io (PathL(p,k,v,r,true),l) + | PathR _, Empty -> assert false + + let can_step = function Top, Empty -> false | _ -> true + + let compare kcmp vcmp t1 t2 = + let rec helper c1 c2 = + match (can_step c1), (can_step c2) with + | false, false -> 0 + | true, false -> -1 + | false, true -> 1 + | true, true -> + let (k1,v1),c1 = step_io c1 in + let (k2,v2),c2 = step_io c2 in + match kcmp k1 k2 with + | 0 -> + let c = vcmp v1 v2 in + if c = 0 then helper c1 c2 + else c + | c -> c + in + helper (to_cursor t1) (to_cursor t2) + + let compare_keys kcmp t1 t2 = compare kcmp (fun _ _ -> 0) t1 t2 + + let gen_ cmp + (kgen:?size:int -> Random.State.t -> 'a) + (vgen:?size:int -> Random.State.t -> 'b) ?(size=50) rs : ('a,'b) tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else + let k = kgen ~size:size rs in + let v = vgen ~size:size rs in + loop (n-1) (add cmp k v t) + in + loop num empty + +end + +module PolyMap = struct + include BaseMap + + type 'a key = 'a + type 'a key_ = 'a + + type 'e elt = 'e + type 'e elt_ = 'e + type ('k,'v) t = ('k,'v) tree + type ('k,'v) map = ('k,'v) t + + type ('k,'v) cursor = ('k,'v) curs + type ('k,'v) cursor_ = ('k,'v) cursor + + type ('a,'k,'v) result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add Pervasives.compare x t + let mem x t = mem Pervasives.compare x t + let remove x t = remove Pervasives.compare x t + let find x t = find Pervasives.compare x t + + let union f t1 t2 = union Pervasives.compare f t1 t2 + + let diff f t1 t2 = diff Pervasives.compare f t1 t2 + let inter f t1 t2 = inter Pervasives.compare f t1 t2 + let well_formed t = well_formed Pervasives.compare t + + let from_cursor c = from_cursor Pervasives.compare c + let move_up c = move_up Pervasives.compare c + + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ Pervasives.compare kgen egen ?size rs +end + +module MonoKeyMap(C : Types.Mono.Comparable) = struct + include BaseMap + + type key = C.t + type 'a key_ = C.t + + type 'e elt = 'e + type 'e elt_ = 'e + + type 'v t = (C.t,'v) tree + type ('k,'v) map = 'v t + + type 'v cursor = (C.t,'v) curs + type ('k,'v) cursor_ = 'v cursor + + type ('a,'v) result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add C.compare x t + let mem x t = mem C.compare x t + let remove x t = remove C.compare x t + let find x t = find C.compare x t + + let union f t1 t2 = union C.compare f t1 t2 + + let diff f t1 t2 = diff C.compare f t1 t2 + let inter f t1 t2 = inter C.compare f t1 t2 + let well_formed t = well_formed C.compare t + + let from_cursor c = from_cursor C.compare c + let move_up c = move_up C.compare c + + let compare vcmp t1 t2 = compare C.compare vcmp t1 t2 + let compare_keys t1 t2 = compare_keys C.compare t1 t2 + + let to_string to_s t = + to_string (fun k v -> + Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) + ) t + + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ C.compare kgen egen ?size rs +end + +module GenKeyMap(C : Types.Mono.ArbitraryComparable) = struct + include MonoKeyMap(C) + + let gen1(egen: ?size:int -> Random.State.t -> 'v) ?size rs : 'v t = + gen2 C.gen egen ?size rs +end + +module MonoMap (K : Types.Mono.Comparable) (V : Types.Mono.Comparable) = struct + include BaseMap + + type key = K.t + type 'a key_ = K.t + + type elt = V.t + type 'e elt_ = elt + + type t = (K.t,V.t) tree + type ('k,'v) map = t + + type cursor = (K.t,V.t) curs + type ('k,'v) cursor_ = cursor + + type 'a result = 'a + type ('a,'k,'v) result_ = 'a + + let add x t = add K.compare x t + let mem x t = mem K.compare x t + let remove x t = remove K.compare x t + let find x t = find K.compare x t + + let union f t1 t2 = union K.compare f t1 t2 + + let diff f t1 t2 = diff K.compare f t1 t2 + let inter f t1 t2 = inter K.compare f t1 t2 + let well_formed t = well_formed K.compare t + + let from_cursor c = from_cursor K.compare c + let move_up c = move_up K.compare c + + let compare t1 t2 = compare K.compare V.compare t1 t2 + let compare_keys t1 t2 = compare_keys K.compare t1 t2 + + let to_string t = + to_string (fun k v -> + Printf.sprintf "(%s => %s)" (K.to_string k) (V.to_string v) + ) t + + let gen2 + (kgen: ?size:int -> Random.State.t -> 'k) + (egen: ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen_ K.compare kgen egen ?size rs +end + +module GenMap + (K : Types.Mono.ArbitraryComparable) + (V : Types.Mono.ArbitraryComparable) = struct + include MonoMap(K)(V) + + let gen ?size rs = gen2 K.gen V.gen ?size rs +end diff --git a/src/map/rBMap.mli b/src/map/rBMap.mli new file mode 100644 index 0000000..8208810 --- /dev/null +++ b/src/map/rBMap.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Balanaced binary search tree with small memory footprint *) + +module PolyMap : Maps.PolyMapSig + +module MonoKeyMap : Maps.MonoKeyMapSigFnStd + +module GenKeyMap : Maps.GenKeyMapSigFnStd + +module MonoMap : Maps.MonoMapSigFnStd + +module GenMap : Maps.GenMapSigFnStd diff --git a/src/map/splayMap.ml b/src/map/splayMap.ml new file mode 100644 index 0000000..bd2de5c --- /dev/null +++ b/src/map/splayMap.ml @@ -0,0 +1,489 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module BaseMap = struct + + type ('k,'v) tree = + | Empty + | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree + + let of_result (x,_) = x + + type ('k,'v) path = + | Top + | PathL of ('k,'v) path * ('k,'v) tree + | PathR of ('k,'v) path * ('k,'v) tree + + type ('k,'v) curs = ('k,'v) path * ('k,'v) tree + + let empty = Empty + let is_empty = function Empty -> true | _ -> false + + let singleton k v = Node(Empty,k,v,Empty) + + let node l k v r = Node(l,k,v,r) + + let to_cursor t = (Top,t) + + let rec from_cursor (p,t) = match p with + | Top -> t + | PathL(p',Node(_,k,v,r)) -> from_cursor (p', Node(t,k,v,r)) + | PathR(p',Node(l,k,v,_)) -> from_cursor (p', Node(l,k,v,t)) + | _ -> assert false + + let at_top (p,t) = (p = Top) + let has_left (p,t) = match t with + | Node(Empty,_,_,_) -> false + | Node _ -> true + | _ -> false + + let has_right (p,t) = match t with + | Node(_,_,_,Empty) -> false + | Node _ -> true + | _ -> false + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let move_up (p,t) = match p with + | Top -> failwith "move_up" + | PathL(p',Node(_,k,v,r)) -> p', Node(t,k,v,r) + | PathR(p',Node(l,k,v,_)) -> p', Node(l,k,v,t) + | _ -> assert false (* parent can't be emptytree *) + + let move_down_left (p,t) = match t with + | Empty -> failwith "move_down_left" + | Node(l,k,v,r) -> PathL(p,t),l + + let move_down_right (p,t) = match t with + | Empty -> failwith "move_down_right" + | Node(l,k,v,r) -> PathR(p,t),r + + let rec move_to_ancestor cmp x ((p,t) as curs) = match p with + | Top -> curs + | PathL(p', Node(_,k,v,_)) -> + if cmp x k < 0 then curs + else move_to_ancestor cmp x (move_up curs) + | PathR(p', Node(_,k,_,_)) -> + if cmp x k > 0 then curs + else move_to_ancestor cmp x (move_up curs) + | _ -> assert false + + let rec splay curs = match curs with + | Top,_ -> curs + | _, Empty -> splay (move_up curs) + + (* no grand-parent, so just zig one level *) + | PathL(Top,Node(_,k,v,r)), Node(ll,lk,lv,lr) -> + Top,Node(ll,lk,lv,Node(lr,k,v,r)) + + | PathR(Top,Node(l,k,v,_)),Node(rl,rk,rv,rr) -> + Top,Node(Node(l,k,v,rl),rk,rv,rr) + + (* has grand-parent *) + (* zig-zig *) + | PathL(PathL(gp_p,Node(_,k,v,r)),Node(_,lk,lv,lr)), Node(lll,llk,llv,llr) -> + let br = Node(lr,k,v,r) in + let mr = Node(llr,lk,lv,br) in + splay (gp_p, Node(lll,llk,llv,mr)) + + (* zig-zig *) + | PathR(PathR(gp_p,Node(l,k,v,_)),Node(ll,lk,lv,_)), Node(rrl,rrk,rrv,rrr) -> + let bl = Node(l,k,v,ll) in + let ml = Node(bl,lk,lv,rrl) in + splay (gp_p,Node(ml,rrk,rrv,rrr)) + + (* zig-zag *) + | PathL(PathR(gp_p,Node(l,k,v,_)),Node(_,rk,rv,rr)), Node(rll,rlk,rlv,rlr) -> + let newl = Node(l,k,v,rll) in + let newr = Node(rlr,rk,rv,rr) in + splay (gp_p,Node(newl, rlk, rlv, newr)) + + (* zig-zag *) + | PathR(PathL(gp_p,Node(_,k,v,r)),Node(ll,lk,lv,_)), Node(lrl,lrk,lrv,lrr) -> + let newl = Node(ll,lk,lv,lrl) in + let newr = Node(lrr,k,v,r) in + splay(gp_p, Node(newl, lrk, lrv, newr)) + + (* all of remaining cases are impossible. e.g., the grandparent + tree being Empty *) + | _ -> assert false + + let rec add_at cmp k v (p,t) = match t with + | Empty -> p,Node(Empty,k,v,Empty) + | Node(l,k',v',r) -> match cmp k k' with + | 0 -> p, Node(l,k,v,r) (* replace binding *) + | c when c < 0 -> add_at cmp k v (PathL(p,t),l) + | _ -> add_at cmp k v (PathR(p,t),r) + + let add cmp k v t = + let curs = add_at cmp k v (to_cursor t) in + from_cursor (splay curs) + + let rec closest_to cmp x ((p,t) as curs) = match t with + | Empty -> if at_top curs then curs else move_up curs + | Node(l,k,v,r) -> match cmp x k with + | 0 -> curs + | c when c < 0 -> closest_to cmp x (PathL(p,t),l) + | _ -> closest_to cmp x (PathR(p,t),r) + + let top_node = function + | Empty -> raise (Invalid_argument "splay:top_node") + | Node(_,k,v,_) -> k,v + + let rec goto_min ((p,t) as curs) = match t with + | Empty -> curs + | Node(Empty,_,_,_) -> curs + | Node(l,_,_,_) -> goto_min ((PathL(p,t)),l) + + let rec goto_max ((p,t) as curs) = match t with + | Empty -> curs + | Node(_,_,_,Empty) -> curs + | Node(_,_,_,r) -> goto_max ((PathR(p,t)),r) + + let min_keyval t = + if is_empty t then raise Not_found + else + let c = goto_min (to_cursor t) in + let t = from_cursor (splay c) in + top_node t, t + + let max_keyval t = + if is_empty t then raise Not_found + else + let c = goto_max (to_cursor t) in + let t = from_cursor (splay c) in + top_node t, t + + let min_key t = let (k,_),t = min_keyval t in k,t + let max_key t = let (k,_),t = max_keyval t in k,t + + let mem cmp x t = + let curs = closest_to cmp x (to_cursor t) in + let t = from_cursor (splay curs) in + match t with + | Empty -> false,t + | Node(_,k,_,_) -> if cmp x k = 0 + then true,t + else false,t + + let find cmp x t = + let ((p,t') as curs) = closest_to cmp x (to_cursor t) in + match t' with + | Empty -> raise Not_found + | Node(l,k,v,r) -> + if cmp x k = 0 + then v, (from_cursor (splay curs)) + else raise Not_found + + (* TODO: fix this to be better than O(n) stack *) + let rec iter f = function + | Empty -> () + | Node(l,k,v,r) -> iter f l; f k v; iter f r + + let rec mapi f = function + | Empty -> Empty + | Node(l,k,v,r) ->Node(mapi f l, k, f k v, mapi f r) + + let map f t = mapi (fun _ v -> f v) t + + let rec get_and_remove_min = function + | Empty -> raise (Invalid_argument "remove_min") + | Node(Empty,k,v,r) -> k,v,r + | Node(l,k,v,r) -> + let k',v',newl = get_and_remove_min l in + k',v', Node(newl,k,v,r) + + let remove cmp x t = + let (p,t) = closest_to cmp x (to_cursor t) in + let t = match t with + | Empty -> t + | Node(Empty,k,v,r) -> if (cmp x k) = 0 then r else t + | Node(l,k,v,Empty) -> if (cmp x k) = 0 then l else t + | Node(l,k,v,r) -> + if (cmp x k) = 0 then + let k',v',newl = get_and_remove_min l in + Node(newl,k',v',r) + else t + in + from_cursor (splay (p,t)) + + let rec compare_ kcmp vcmp t1 t2 = match t1,t2 with + | Empty, Empty -> 0 + | Empty, Node _ -> -1 + | Node _, Empty -> 1 + | _ -> + (* This actually may be one of the most efficient ways to + implement this since we will always be removing near the + top thanks to the splay property. *) + let xk,xv,t1' = get_and_remove_min t1 in + let yk,yv,t2' = get_and_remove_min t2 in + match kcmp xk yk with + | 0 -> begin match vcmp xv yv with + | 0 -> compare_ kcmp vcmp t1' t2' + | v -> v + end + | v -> v + + let compare_keys kcmp t1 t2 = compare_ kcmp (fun _ _ -> 0) t1 t2 + + let rec split cmp kelt t = match t with + | Empty -> Empty, Empty + | Node(l1,k,v,r1) -> + match cmp kelt k with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp kelt l1 in + l2,Node(r2,k,v,r1) + | _ -> + let l2,r2 = split cmp kelt r1 in + Node(l1,k,v,l2), r2 + + let rec union cmp f t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | t1, Node(l,k,v,r) -> + let l',r' = split cmp k t1 in + let v' = + try + let v',_ = find cmp k t1 in + f k v v' + with Not_found -> v + in + Node((union cmp f l' l),k,v',(union cmp f r' r)) + + let rec concat t1 t2 = match t1,t2 with + | Empty, _ -> t2 + | _, Empty -> t1 + | Node(l1,k1,v1,r1), Node(l2,k2,v2,r2) -> + let k',v',t2' = get_and_remove_min t2 in + Node(t1,k',v',t2') + + let rec diff cmp f t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, Node(l,k,v,r) -> + let l',r' = split cmp k t1 in + concat (diff cmp f l' l) (diff cmp f r' r) + + let rec inter cmp f t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, Node(l,k,v,r) -> + let l',r' = split cmp k t1 in + try + let v',_ = find cmp k t1 in + let uv = f k v v' in + Node((inter cmp f l' l),k,uv,(inter cmp f r' r)) + with Not_found -> + concat (inter cmp f l' l) (inter cmp f r' r) + + let at_right = function + | _,Empty -> true + | _,Node _ -> false + + let at_left = at_right + + let has_value = function _,Node _ -> true | _ -> false + let get_value = function + | _,Empty -> failwith "get_value" + | _,Node(_,k,v,_) -> k,v + + let rec cardinal = function + | Empty -> 0 + | Node(l,_,_,r) -> 1 + (cardinal l) + (cardinal r) + + (* TODO: fix this to be better than O(n) stack *) + let rec fold f acc t = match t with + | Empty -> acc + | Node(l,k,v,r) -> + fold f (f (fold f acc l) k v) r + + let rec well_ordered cmp = function + | Empty -> true + | Node(Empty,_,_,Empty) -> true + | Node(Node(_,lk,lv,_) as l,k,v,Empty) -> + ((cmp lk k) < 0) && well_ordered cmp l + | Node(Empty,k,v,(Node(_,rk,rv,_) as r)) -> + ((cmp rk k) > 0) && well_ordered cmp r + | Node(Node(_,lk,_,_) as l,k,_,(Node(_,rk,_,_) as r)) -> + ((cmp lk k) < 0) &&((cmp rk k) > 0) && + well_ordered cmp l && well_ordered cmp r + + let well_formed t = well_ordered t + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | Node(Empty,k,v,Empty) -> to_s k v + | Node(l,k,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s k v) + | Node(Empty,k,v,r) -> Printf.sprintf "%s, %s" (to_s k v) (h r) + | Node(l,k,v,r) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s k v) (h r) + in "{" ^ (h t) ^ "}" + + let gen2 cmp + (kgen : ?size:int -> Random.State.t -> 'k) + (vgen : ?size:int -> Random.State.t -> 'v) + ?(size=50) rs : ('k,'v) tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else + let k = kgen ~size:size rs in + let v = vgen ~size:size rs in + let t = from_cursor (add_at cmp k v (to_cursor t)) in + loop (n-1) t + in + loop num empty + +end + + +(* CR SW: Is it possible to write a functor that builds a Poly from a BaseMap? *) +module PolyMap = struct + include BaseMap + + type 'a key = 'a + type 'a key_ = 'a + + type 'e elt = 'e + type 'e elt_ = 'e + type ('k,'v) t = ('k,'v) tree + type ('k,'v) map = ('k,'v) t + + type ('k,'v) cursor = ('k,'v) curs + type ('k,'v) cursor_ = ('k,'v) cursor + + type ('a,'k,'v) result = 'a * ('k,'v) tree + type ('a,'k,'v) result_ = ('a,'k,'v) result + + let compare = compare_ + let mem k t = mem Pervasives.compare k t + let add k v t = add Pervasives.compare k v t + let remove k t = remove Pervasives.compare k t + let find k t = find Pervasives.compare k t + + let union f t1 t2 = union Pervasives.compare f t1 t2 + let inter f t1 t2 = inter Pervasives.compare f t1 t2 + let diff f t1 t2 = diff Pervasives.compare f t1 t2 + + let well_formed t = well_formed Pervasives.compare t + + let gen2 + (kgen : ?size:int -> Random.State.t -> 'k) + (vgen : ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen2 Pervasives.compare kgen vgen ?size rs + +end + +module MonoKeyMap(C : Mono.Comparable) = struct + include BaseMap + + type key = C.t + type 'a key_ = key + + type 'e elt = 'e + type 'e elt_ = 'e + + type 'v t = (C.t,'v) tree + type ('k,'v) map = 'v t + + type 'v cursor = (C.t,'v) curs + type ('k,'v) cursor_ = 'v cursor + + type ('a,'v) result = 'a * 'v t + type ('a,'k,'v) result_ = ('a,'v) result + + let compare t1 t2 = compare_ C.compare t1 t2 + let compare_keys t1 t2 = compare_keys C.compare t1 t2 + let mem k t = mem C.compare k t + let add k v t = add C.compare k v t + let remove k t = remove C.compare k t + let find k t = find C.compare k t + + let union f t1 t2 = union C.compare f t1 t2 + let inter f t1 t2 = inter C.compare f t1 t2 + let diff f t1 t2 = diff C.compare f t1 t2 + + let well_formed t = well_formed C.compare t + + let to_string to_s t = + let f k v = Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) in + to_string f t + + let gen2 + (kgen : ?size:int -> Random.State.t -> 'k) + (vgen : ?size:int -> Random.State.t -> 'v) + ?size rs : ('k,'v) tree = + gen2 C.compare kgen vgen ?size rs + +end + +module GenKeyMap (C : Mono.ArbitraryComparable) = struct + include MonoKeyMap(C) + + let gen1 (vgen : ?size:int -> Random.State.t -> 'v) ?size rs : 'v t = + gen2 C.gen vgen ?size rs +end + +module MonoMap (K : Mono.Comparable) (V : Mono.Comparable) = struct + include BaseMap + + type key = K.t + type 'a key_ = key + + type elt = V.t + type 'e elt_ = elt + + type t = (key,elt) tree + type ('k,'v) map = t + + type cursor = (key,elt) curs + type ('k,'v) cursor_ = cursor + + type 'a result = 'a * t + type ('a,'k,'v) result_ = 'a result + + let compare t1 t2 = compare_ K.compare V.compare t1 t2 + let compare_keys t1 t2 = compare_keys K.compare t1 t2 + let mem k t = mem K.compare k t + let add k v t = add K.compare k v t + let remove k t = remove K.compare k t + let find k t = find K.compare k t + + let union f t1 t2 = union K.compare f t1 t2 + let inter f t1 t2 = inter K.compare f t1 t2 + let diff f t1 t2 = diff K.compare f t1 t2 + + let well_formed t = well_formed K.compare t + + let to_string t = + let f k v = Printf.sprintf "(%s => %s)" (K.to_string k) (V.to_string v) in + to_string f t + + let gen2 + (kgen : ?size:int -> Random.State.t -> key) + (vgen : ?size:int -> Random.State.t -> elt) + ?size rs : t = + gen2 K.compare kgen vgen ?size rs +end + +module GenMap + (K : Types.Mono.ArbitraryComparable) + (V : Types.Mono.ArbitraryComparable) = +struct + include MonoMap(K)(V) + + let gen ?size rs = gen2 K.gen V.gen ?size rs +end + + diff --git a/src/map/splayMap.mli b/src/map/splayMap.mli new file mode 100644 index 0000000..f42436e --- /dev/null +++ b/src/map/splayMap.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Maps with excellent non-uniform access performance *) + +module rec PolyMap : + Maps.PolyMapSig with type ('a,'k,'v) result = 'a * ('k,'v) PolyMap.t + +module rec MonoKeyMap : + functor(C : Types.Mono.Comparable) -> + Maps.MonoKeyMapSig with type key = C.t + and type ('a,'v) result = 'a * 'v MonoKeyMap(C).t + +module rec GenKeyMap : + functor(C : Types.Mono.ArbitraryComparable) -> + Maps.GenKeyMapSig with type key = C.t + and type ('a,'v) result = 'a * 'v GenKeyMap(C).t + +module rec MonoMap : + functor(K : Types.Mono.Comparable) -> + functor(V : Types.Mono.Comparable) -> + Maps.MonoMapSig with type key = K.t + and type elt = V.t + and type 'a result = 'a * MonoMap(K)(V).t + +module rec GenMap : + functor(K : Types.Mono.ArbitraryComparable) -> + functor(V : Types.Mono.ArbitraryComparable) -> + Maps.GenMapSig with type key = K.t + and type elt = V.t + and type 'a result = 'a * GenMap(K)(V).t diff --git a/src/oracle/OMakefile b/src/oracle/OMakefile new file mode 100644 index 0000000..b9c6d5d --- /dev/null +++ b/src/oracle/OMakefile @@ -0,0 +1,14 @@ + +OCAMLINCLUDES[] += ../base ../list ../set ../map ../heap + +FILES[] += + oracle/oracle + oracle/oracleSet + oracle/oracleList + oracle/dug + oracle/dugADT + oracle/dugProfile + oracle/dugExtractor + oracle/dugGenerator + oracle/randomBag + oracle/replayList diff --git a/src/oracle/dug.ml b/src/oracle/dug.ml new file mode 100644 index 0000000..9affca4 --- /dev/null +++ b/src/oracle/dug.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + + +module Id = Types.Int64 + +type ('a,'b,'c) kind = + | Generator of 'a + | Mutator of 'b + | Observer of 'c + +type ('a,'b,'c) edge = { + target : Id.t; + op : ('a,'b,'c) kind; + pos : int; + } + +type ('a,'b,'c) t = { + mutable current_id : Id.t; + nodes : (Id.t,('a,'b,'c) kind) Hashtbl.t; + edges : (Id.t,('a,'b,'c) edge) Hashtbl.t; + } + +let fresh_id t = + t.current_id <- Id.succ t.current_id; + t.current_id + +let create () = + {current_id = Int64.zero; + nodes = Hashtbl.create 127; + edges = Hashtbl.create 229} + +let clear t = + t.current_id <- Int64.zero; + Hashtbl.clear t.nodes; + Hashtbl.clear t.edges + +let size t = t.current_id + +let is_mutator = function + | Mutator _ -> true + | Generator _ + | Observer _ -> false + +let is_generator = function + | Generator _ -> true + | Mutator _ + | Observer _ -> false + +let is_observer = function + | Observer _ -> true + | Generator _ + | Mutator _ -> false + +let _ = + Random.self_init () diff --git a/src/oracle/dug.mli b/src/oracle/dug.mli new file mode 100644 index 0000000..a96fefd --- /dev/null +++ b/src/oracle/dug.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Datatype Usage Graphs *) + +module Id : Types.Integral + +type ('gen,'mut,'obs) kind = + | Generator of 'gen + | Mutator of 'mut + | Observer of 'obs + +type ('gen,'mut,'obs) edge = { + target : Id.t; + op : ('gen,'mut,'obs) kind; + pos : int; + } + +type ('gen,'mut,'obs) t = { + mutable current_id : Id.t; + nodes : (Id.t,('gen,'mut,'obs) kind) Hashtbl.t; + edges : (Id.t,('gen,'mut,'obs) edge) Hashtbl.t; + } + +val create : unit -> ('gen,'mut,'obs) t + +val clear : ('gen,'mut,'obs) t -> unit + +val size : ('eng,'mut,'obs) t -> Id.t + +val fresh_id : ('gen,'mut,'obs) t -> Id.t + +val is_mutator : ('gen,'mut,'obs) kind -> bool +val is_generator : ('gen,'mut,'obs) kind -> bool +val is_observer : ('gen,'mut,'obs) kind -> bool + diff --git a/src/oracle/dugADT.ml b/src/oracle/dugADT.ml new file mode 100644 index 0000000..02bc197 --- /dev/null +++ b/src/oracle/dugADT.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module type S = sig + + type ('v,'t) generator + (** functions that return a container and none of its arguments + are containers *) + + type ('v,'t) mutator + (** functions that return a container and at least one arg is a + container *) + + type ('v,'t) observer + (** functions that do not return a container, but takes one as + an argument *) + + type ('v,'t) op + (** One of {generator,mutator,observer} *) + + val op_to_string : ('v,'t) op -> string + + val coerce_gen : ('v,'t) generator -> ('v,'t) op + val coerce_mut : ('v,'t) mutator -> ('v,'t) op + val coerce_obs : ('v,'t) observer -> ('v,'t) op + + val classify : ('v,'t) op -> + (('v,'t) generator,('v,'t) mutator,('v,'t) observer) Dug.kind + val strip : ('v,'t) op -> (unit,unit) op + + val op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list + val create_op : + (unit,unit) op -> Dug.Id.t + -> (unit -> 'a) -> (int -> Dug.Id.t) -> ('a,Dug.Id.t) op + +end + diff --git a/src/oracle/dugADT.mli b/src/oracle/dugADT.mli new file mode 100644 index 0000000..93454be --- /dev/null +++ b/src/oracle/dugADT.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Abstract signature for ADTs => DUG extraction *) + +module type S = sig + + type ('v,'t) generator + (** functions that return a container and none of its arguments + are containers *) + + type ('v,'t) mutator + (** functions that return a container and at least one arg is a + container *) + + type ('v,'t) observer + (** functions that do not return a container, but takes one as + an argument *) + + type ('v,'t) op + (** One of {generator,mutator,observer} *) + + val op_to_string : ('v,'t) op -> string + + val coerce_gen : ('v,'t) generator -> ('v,'t) op + val coerce_mut : ('v,'t) mutator -> ('v,'t) op + val coerce_obs : ('v,'t) observer -> ('v,'t) op + + val classify : ('v,'t) op -> + (('v,'t) generator,('v,'t) mutator,('v,'t) observer) Dug.kind + val strip : ('v,'t) op -> (unit,unit) op + + val op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list + val create_op : + (unit,unit) op -> Dug.Id.t + -> (unit -> 'a) -> (int -> Dug.Id.t) -> ('a,Dug.Id.t) op + +end + +(* +module type S = + sig + type 'a generator + type 'a mutator + type 'a observer + type 'a op + val op_to_string : 'a op -> string + val coerce_gen : 'a generator -> 'a op + val coerce_mut : 'a mutator -> 'a op + val coerce_obs : 'a observer -> 'a op + val classify : 'a op -> ('a generator, 'a mutator, 'a observer) Dug.kind + val strip : 'a op -> unit op + val op_dependencies : Dug.Id.t op -> Dug.Id.t list + val create_op : unit op -> Dug.Id.t -> (int -> Dug.Id.t) -> Dug.Id.t op + + end +*) +(* + module Impl : sig + val benchmark : (Dug.Id.t generator, Dug.Id.t mutator, Dug.Id.t observer) Dug.t + -> float + val get_dug : unit -> (unit generator, unit mutator, unit observer) Dug.t + val clear_profile : unit -> unit + end +*) diff --git a/src/oracle/dugExtractor.ml b/src/oracle/dugExtractor.ml new file mode 100644 index 0000000..6489e93 --- /dev/null +++ b/src/oracle/dugExtractor.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Dug + +type 'a wrap = { + data : 'a; + id : Id.t; + } + +let mutate t op f wrap = + let data = f wrap.data in + let id = fresh_id t in + let kop = Mutator (op id) in + let e = {target = id;op = kop; pos = 0} in + Hashtbl.add t.nodes id kop; + Hashtbl.add t.edges wrap.id e; + {data=data; id=id} + +let mutate2 t op f w1 w2 = + let id = fresh_id t in + let kop = Mutator (op id) in + let e1 = {target = id; op = kop; pos = 0} in + let e2 = {e1 with pos = 1} in + Hashtbl.add t.nodes id kop; + Hashtbl.add t.edges w1.id e1; + Hashtbl.add t.edges w2.id e2; + {data = f w1.data w2.data; id=id} + +let observe t op f w = + let kop = Observer op in + let id' = fresh_id t in + let e = {target = id'; op = kop; pos = 0} in + Hashtbl.add t.nodes id' kop; + Hashtbl.add t.edges w.id e; + f w.data + +let observe2 t op f w1 w2 = + let kop = Observer op in + let id' = fresh_id t in + let e1 = {target = id'; op = kop; pos = 0} in + let e2 = {e1 with pos = 1} in + Hashtbl.add t.nodes id' kop; + Hashtbl.add t.edges w1.id e1; + Hashtbl.add t.edges w2.id e2; + f w1.data w2.data + +let generate t op data = + let id = fresh_id t in + Hashtbl.add t.nodes id (Generator (op id)); + {data = data; id=id} + + + + diff --git a/src/oracle/dugExtractor.mli b/src/oracle/dugExtractor.mli new file mode 100644 index 0000000..3a8374d --- /dev/null +++ b/src/oracle/dugExtractor.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Helper module for extracting a DUG from a specific program execution *) + +type 'a wrap = private { data : 'a; id : Dug.Id.t; } + +val mutate : ('gen,'mut,'obs) Dug.t -> + (Dug.Id.t -> 'mut) -> ('a -> 'a) -> 'a wrap -> 'a wrap + +val mutate2 : ('gen,'mut,'obs) Dug.t -> + (Dug.Id.t -> 'mut) -> ('a -> 'a -> 'a) -> 'a wrap -> 'a wrap -> 'a wrap + +val observe : ('gen,'mut,'obs) Dug.t -> + 'obs -> ('a -> 'b) -> 'a wrap -> 'b + +val observe2 : ('gen,'mut,'obs) Dug.t -> + 'obs -> ('a -> 'a -> 'b) -> 'a wrap -> 'a wrap -> 'b + +val generate : ('gen,'mut,'obs) Dug.t -> + (Dug.Id.t -> 'gen) -> 'a -> 'a wrap + diff --git a/src/oracle/dugGenerator.ml b/src/oracle/dugGenerator.ml new file mode 100644 index 0000000..ed53faf --- /dev/null +++ b/src/oracle/dugGenerator.ml @@ -0,0 +1,220 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +module Make(DS : DugADT.S)(A : Types.Mono.ArbitraryComparable) = struct + + module DP = DugProfile.Make(DS) + + type t = { + dug : ((A.t,Dug.Id.t) DS.generator, + (A.t,Dug.Id.t) DS.mutator, + (A.t,Dug.Id.t) DS.observer) Dug.t; + frontier : (Dug.Id.t * (unit,unit) DS.op list) RandomBag.t; + planned_size : Dug.Id.t; + profile : DP.t; + max_id : Dug.Id.t; + } + + let frontier_min = 2 + let frontier_max = 10000 + + let rec factf n = if n <= 1. then 1. else n *. (factf (n -. 1.)) + + (* The regular poisson function *) + let poisson' lambda k = + (exp ~-.lambda) *. (lambda ** (float k)) /. (factf (float k)) + + (* simple brute force inversion of the poisson function. *) + let rec find_poisson l guess p cump = + let cump' = cump +. (poisson' l guess) in + if cump' > p then guess + else find_poisson l (guess+1) p cump' + + (* Randomally select an integer K whose valule is taken from the + poisson distribution with mean l. That is, P(K=x) = + poisson(l,x). *) + let poisson l = + let p = Random.float 1.0 in + match classify_float l with + | FP_nan + | FP_infinite -> 0 + | _ -> find_poisson l 0 p 0. + + let fresh_id t = Dug.fresh_id t.dug + + let expected_mutations t = + let p = t.profile in + (1. -. p.DP.mortality) *. p.DP.pmf /. (1. -. p.DP.pmf) + + let chance p = (Random.float 1.0) < p + + let num_mutations t = + let p = t.profile in + if chance p.DP.mortality + then 0 + else 1 + (poisson (p.DP.pmf /. (1. -. p.DP.pmf))) + + let rec loop n f acc = + if n <= 0 then acc + else loop (n-1) f (f acc) + + (* Combine two lists of length m and n respectively by choosing an + element from lst1 with probability m/(m+n) and from lst2 with + probability n/(m+n) *) + let mix_lists lst1 lst2 = + let rec helper lst1 len1 lst2 len2 acc = match len1,len2 with + | 0,0 -> acc + | 0,_ -> List.rev_append lst2 acc + | _,0 -> List.rev_append lst1 acc + | _ -> + let tot = len1 + len2 in + (* random will be 0..tot-1, so >= len1 is *) + if (Random.int tot) < len1 + then match lst1 with [] -> assert false + | hd::tl -> helper tl (len1-1) lst2 len2 (hd::acc) + else match lst2 with [] -> assert false + | hd::tl -> helper lst1 len1 tl (len2-1) (hd::acc) + in + helper lst1 (List.length lst1) lst2 (List.length lst2) [] + + let num_observations num_muts t = + num_muts *. (t.profile.DP.obs_mut_ratio) + + let exec_plan num coerce cdf = + loop num (fun acc -> (coerce (DP.random_op cdf))::acc) [] + + let tot_muts = ref 0 + let mut_times = ref 0 + let max_muts = ref 0 + + let tot_obs = ref 0 + let obs_times = ref 0 + (* + let _ = at_exit + (fun () -> + Printf.printf "avg mutations: %f (%d)\n" + ((float !tot_muts) /. (float !mut_times)) !max_muts; + + Printf.printf "avg observers: %f\n" + ((float !tot_obs) /. (float !obs_times)) + ) + *) + + let plan t : (unit,unit) DS.op list = + let p = t.profile in + let num_muts = num_mutations t in + let muts = exec_plan num_muts DS.coerce_mut p.DP.mut_cdf in + incr mut_times; + tot_muts := !tot_muts + num_muts; + max_muts := max !max_muts num_muts; + + let numf_obs = num_observations (*(expected_mutations t)*) (float num_muts) t in + + let num_p_obs = poisson (numf_obs *. p.DP.pof) in + let pers_obs = exec_plan num_p_obs DS.coerce_obs p.DP.obs_cdf in + + let num_e_obs = poisson (numf_obs *. (1. -. p.DP.pof)) in + let emph_obs = exec_plan num_e_obs DS.coerce_obs p.DP.obs_cdf in + incr obs_times; + tot_obs := !tot_obs + num_p_obs + num_e_obs; + +(* Printf.printf "muts: %d(exp: %f) obs: %f\n" + num_muts (expected_mutations t) numf_obs;*) + match muts with + | [] -> emph_obs @ pers_obs + (* force the persistent operations, to be persisten by + placing a mutation first *) + | hd::tl -> emph_obs @ (hd :: (mix_lists tl pers_obs)) + + let update_frontier id future frontier = match future with + | [] -> frontier + | _ -> RandomBag.add (id,future) frontier + + let create_node id op future t = + Hashtbl.replace t.dug.Dug.nodes id (DS.classify op); + let frontier = update_frontier id future t.frontier in + {t with frontier = frontier} + + let rs = Random.State.make_self_init() + + let expand_frontier t = +(* Printf.printf "expand!!!!!!!!!!!!!!!!!!!!!\n";*) + let id = fresh_id t in + let gen = DP.random_op t.profile.DP.gen_cdf in + let d_op = DS.coerce_gen gen in + let op = DS.create_op d_op id (fun () -> A.gen rs) (fun _ -> assert false) in + create_node id op (plan t) t + + let shrink_frontier t = +(* Printf.printf "shrink---------------------\n";*) + let n = RandomBag.choose t.frontier in + {t with frontier = RandomBag.remove n t.frontier} + + let create_random_node t = + let ((pred_id,future) as idf) = RandomBag.choose t.frontier in + let t = {t with frontier = RandomBag.remove idf t.frontier} in + let next_op = List.hd future in + let id = fresh_id t in + (* create a temp table to store what objects where taken from + the frontier and placed in which position. We do this so we can + later add then to the edge table of the dug. We can't do it + here, since we need a (Id.t op), not a (unit op) [which next_op + is] *) + let tbl = Hashtbl.create 11 in + let get_pos i = + let arg_id = if i = 0 then pred_id else fst(RandomBag.choose t.frontier) in + Hashtbl.add tbl i arg_id; + arg_id + in + let op = DS.create_op next_op id (fun () -> A.gen rs) get_pos in + let () = Hashtbl.iter + (fun pos src_id -> + let e = {Dug.target = id; op = DS.classify op; pos = pos} in + Hashtbl.add t.dug.Dug.edges src_id e; + ) tbl + in + (* Don't plan a future for an observer node *) + let new_plan = if Dug.is_observer (DS.classify op) then [] else plan t in + let t = create_node id op new_plan t in + let frontier = update_frontier pred_id (List.tl future) t.frontier in + {t with frontier = frontier} + +(* TODO: alternatively, produce all of the generator nodes first, then + build up dug until the sum of the futures + current size is the + target size, then just run out the futures. +*) + let rec generate_nodes t = + let front_size = (RandomBag.length t.frontier) in + if Dug.Id.compare t.dug.Dug.current_id t.max_id >= 0 then t + else if front_size < frontier_min then + generate_nodes (expand_frontier t) + else if front_size > frontier_max then + generate_nodes (shrink_frontier t) + else if chance t.profile.DP.gen_ratio then + generate_nodes (expand_frontier t) (* add a gen *) + else + generate_nodes (create_random_node t) (* add a mut or obs *) + + let generate p size = + let t = + {frontier = RandomBag.empty; + dug = Dug.create (); + profile = p; + max_id = Dug.Id.of_int size; + planned_size = Dug.Id.zero; + } + in + let t = generate_nodes t in + Printf.eprintf "%d nodes left in frontier\n" + (RandomBag.length t.frontier); + t.dug + +end + diff --git a/src/oracle/dugGenerator.mli b/src/oracle/dugGenerator.mli new file mode 100644 index 0000000..39340d1 --- /dev/null +++ b/src/oracle/dugGenerator.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Module to generate a random dug from a profile *) + +module Make : + functor (DS : DugADT.S) -> + functor(A : Types.Mono.ArbitraryComparable) -> +sig + val generate : DugProfile.Make(DS).t -> int + -> ((A.t,Dug.Id.t) DS.generator, + (A.t,Dug.Id.t) DS.mutator, + (A.t,Dug.Id.t) DS.observer) Dug.t +end diff --git a/src/oracle/dugProfile.ml b/src/oracle/dugProfile.ml new file mode 100644 index 0000000..efd8f67 --- /dev/null +++ b/src/oracle/dugProfile.ml @@ -0,0 +1,214 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open Dug + +module Make(DS : DugADT.S) = struct + + type t = { + gen_cdf : ((unit,unit) DS.generator * float) list; + mut_cdf : ((unit,unit) DS.mutator * float) list; + obs_cdf : ((unit,unit) DS.observer * float) list; + gen_ratio : float; + obs_mut_ratio : float; + mortality : float; + pmf : float; + pof : float; + } + + let random_op cdf = + let prob = Random.float 1.0 in + let rec helper = function + | [] -> assert false + | (op,_)::[] -> op + | (op,c)::tl -> if c >= prob then op else helper tl + in + let res = helper cdf in +(* Printf.eprintf "random: %f -> %d\n" prob (pv_tag res);*) + res + + let to_string t = + let gen_s x = DS.op_to_string (DS.coerce_gen x) in + let mut_s x = DS.op_to_string (DS.coerce_mut x) in + let obs_s x = DS.op_to_string (DS.coerce_obs x) in + let buf = Buffer.create 127 in + let f to_s (op,weight) = + Buffer.add_string buf (sprintf " %s %f\n" (to_s op) weight) + in + Buffer.add_string buf "{\n"; + Buffer.add_string buf " gen cdf:\n"; + List.iter (f gen_s) t.gen_cdf; + Buffer.add_string buf " mut cdf:\n"; + List.iter (f mut_s) t.mut_cdf; + Buffer.add_string buf " obs cdf:\n"; + List.iter (f obs_s) t.obs_cdf; + Buffer.add_string buf + (sprintf " gen_ratio: %f\n obs/mut: %f\n mort: %f\n pmf: %f\n pof: %f\n}" + t.gen_ratio t.obs_mut_ratio t.mortality t.pmf t.pof); + Buffer.contents buf + + type ('a,'b,'c) profile_data = { + gen_nodes : ('a,Int64.t) Hashtbl.t; + mut_nodes : ('b,Int64.t) Hashtbl.t; + obs_nodes : ('c,Int64.t) Hashtbl.t; + gen_weights : ('a,Int64.t) Hashtbl.t; + mut_weights : ('b,Int64.t) Hashtbl.t; + obs_weights : ('c,Int64.t) Hashtbl.t; + (* nodes that are never mutated (only non-observer nodes apply) *) + mutable mortality_count : Int64.t; + mutable pmf_count : Int64.t; + mutable pof_count : Int64.t; + } + + let empty_profile () = { + gen_nodes = Hashtbl.create 127; + mut_nodes = Hashtbl.create 127; + obs_nodes = Hashtbl.create 127; + gen_weights = Hashtbl.create 127; + mut_weights = Hashtbl.create 127; + obs_weights = Hashtbl.create 127; + mortality_count = Int64.zero; + pmf_count = Int64.zero; + pof_count = Int64.zero; + } + + let incr_tbl tbl op = + let old = + try match Hashtbl.find_all tbl op with + | [] -> Int64.zero + | [x] -> x + | _ -> assert false + with Not_found -> Int64.zero + in + Hashtbl.replace tbl op (Int64.succ old) + + let rec after_true f = function + | [] -> [] + | hd::tl -> if f hd then tl else after_true f tl + + let count_persistent f edges = + let after_mut = after_true (fun x -> is_mutator x.op) edges in + List.fold_left (fun acc x -> if f x.op then Int64.succ acc else acc) + Int64.zero after_mut + + let rec update_weights t pd edges = match edges with + | [] -> () + | e::tl -> + begin match e.op with + | Generator _ -> assert false + | Mutator op -> + let op = match DS.classify (DS.strip (DS.coerce_mut op)) with + | Mutator o -> o | _ -> assert false + in incr_tbl pd.mut_weights op + | Observer op -> + let op = match DS.classify (DS.strip (DS.coerce_obs op)) with + | Observer o -> o | _ -> assert false + in incr_tbl pd.obs_weights op + end; + update_weights t pd tl + + let rec profile_node t pd id = + if Id.compare id t.current_id > 0 then () + else + let kind = Hashtbl.find t.nodes id in + let edges = Hashtbl.find_all t.edges id in + let edges = List.rev edges (* fifo order the edges *) in + let update_mortality () = + if not (List.exists (fun x -> is_mutator x.op) edges) + then pd.mortality_count <- Int64.succ pd.mortality_count + in + let update_persistents () = + let ocount = count_persistent is_observer edges in + let mcount = count_persistent is_mutator edges in + pd.pof_count <- Int64.add pd.pof_count ocount; + pd.pmf_count <- Int64.add pd.pmf_count mcount + in + update_weights t pd edges; + update_persistents (); + + (* TODO: clean this up! *) + begin match kind with + | Generator op -> + let op = match DS.classify (DS.strip (DS.coerce_gen op)) with + | Generator o -> o | _ -> assert false + in + incr_tbl pd.gen_weights op; + update_mortality (); + incr_tbl pd.gen_nodes op; + + | Mutator op -> + let op = match DS.classify (DS.strip (DS.coerce_mut op)) with + | Mutator o -> o | _ -> assert false + in + update_mortality (); + incr_tbl pd.mut_nodes op; + | Observer op -> + let op = match DS.classify (DS.strip (DS.coerce_obs op)) with + | Observer o -> o | _ -> assert false + in + assert (List.length edges = 0); + incr_tbl pd.obs_nodes op; + end; + profile_node t pd (Dug.Id.succ id) + + let sum_tbl tbl = + Hashtbl.fold (fun k v acc -> Int64.add v acc) tbl Int64.zero + + let build_weights totf tbl = + let tbl' = Hashtbl.create (Hashtbl.length tbl) in + Hashtbl.iter (fun k v -> Hashtbl.add tbl' k ((Int64.to_float v) /. totf)) tbl; + Hashtbl.find tbl' + + let build_cdf pdf tbl = + let lst = Hashtbl.fold (fun op _ acc -> op::acc) tbl [] in + (* forace a deterministic (but arbitrary) ordering *) + let lst = List.sort Pervasives.compare lst in + let _,l = List.fold_left + (fun (c,acc) op -> + let c' = c +. (pdf op) in + c', ((op,c') :: acc) + ) (0.0,[]) lst + in List.rev l + + let build_profile pd = + (* let tot_gen_weights = Int64.to_float (sum_tbl pd.gen_weights) in*) + let tot_mut_weights = Int64.to_float (sum_tbl pd.mut_weights) in + let tot_obs_weights = Int64.to_float (sum_tbl pd.obs_weights) in + let tot_gen_nodes = Int64.to_float (sum_tbl pd.gen_nodes) in + let tot_mut_nodes = Int64.to_float (sum_tbl pd.mut_nodes) in + let tot_obs_nodes = Int64.to_float (sum_tbl pd.obs_nodes) in + let gen_f = build_weights tot_gen_nodes pd.gen_nodes in + let mut_f = build_weights tot_mut_nodes pd.mut_nodes in + let obs_f = build_weights tot_obs_nodes pd.obs_nodes in + { + gen_cdf = build_cdf gen_f pd.gen_nodes; + mut_cdf = build_cdf mut_f pd.mut_nodes; + obs_cdf = build_cdf obs_f pd.obs_nodes; + + gen_ratio = + tot_gen_nodes /. (tot_gen_nodes +. tot_mut_nodes +. tot_obs_nodes); + + obs_mut_ratio = tot_obs_nodes /. tot_mut_nodes; + + mortality = + (Int64.to_float pd.mortality_count) /. + (tot_gen_nodes +. tot_mut_nodes); + + pmf = (Int64.to_float pd.pmf_count) /. tot_mut_weights; + + pof = (Int64.to_float pd.pof_count) /. tot_obs_weights; + } + + let profile t = + let pd = empty_profile () in + profile_node t pd Dug.Id.one; + build_profile pd + +end diff --git a/src/oracle/dugProfile.mli b/src/oracle/dugProfile.mli new file mode 100644 index 0000000..2b5d078 --- /dev/null +++ b/src/oracle/dugProfile.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Charactericists of a DUG *) + +module Make : functor(DS : DugADT.S) -> sig + + type t = private { + (* CDF for the different node types (not operation weights) + i.e., union counts as 1, not 2 + *) + gen_cdf : ((unit,unit) DS.generator * float) list; + mut_cdf : ((unit,unit) DS.mutator * float) list; + obs_cdf : ((unit,unit) DS.observer * float) list; + + (* ratio of generator nodes to total nodes *) + gen_ratio : float; + + (* ratio of observations / mutations *) + obs_mut_ratio : float; + + (* fraction of version nodes (gen or mut) that are never + mutated *) + mortality : float; + + (* fraction of mutations that are persisent *) + pmf : float; + + (* fraction of observations that are persisent *) + pof : float; + } + + val random_op : ('a * float) list -> 'a + + val to_string : t -> string + + val profile : + (('a,'b) DS.generator, ('a,'b) DS.mutator, ('a,'b) DS.observer) Dug.t + -> t +end diff --git a/src/oracle/oracle.ml b/src/oracle/oracle.ml new file mode 100644 index 0000000..a807463 --- /dev/null +++ b/src/oracle/oracle.ml @@ -0,0 +1,40 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +module type RestrictedSet = Sets.GenSetSig with type 'a result = 'a + +module type ProfiledSet = sig + include RestrictedSet + include DugADT.S +end + + +module type OSet = sig + include DugADT.S + + module Extractor : functor(A : Types.Mono.ArbitraryComparable) -> Sets.GenSetSig + + module BenchMark : functor(S : Sets.GenSetSig) -> sig + val benchmark : + ((S.elt,Dug.Id.t) generator, + (S.elt,Dug.Id.t) mutator, + (S.elt,Dug.Id.t) observer) Dug.t + -> float + end +end + +(* +module ExtractSet(A : MonoTypes.ArbitraryComparable) = +struct + module M = OracleSet.Make(A) + include M.Extractor +end + +*) diff --git a/src/oracle/oracle.mli b/src/oracle/oracle.mli new file mode 100644 index 0000000..cd040fb --- /dev/null +++ b/src/oracle/oracle.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +(** Frontend to automatic benchmarking of data structures (work in progress) *) + +module type RestrictedSet = Sets.GenSetSig with type 'a result = 'a + +module type ProfiledSet = sig + include RestrictedSet + include DugADT.S +end + +(* +module Set : + functor(S : RestrictedSet) -> + functor(A : Types.ArbitraryComparable with type t = S.elt) -> + ProfiledSet with type elt = A.t +*) diff --git a/src/oracle/oracleList.ml b/src/oracle/oracleList.ml new file mode 100644 index 0000000..d76bac2 --- /dev/null +++ b/src/oracle/oracleList.ml @@ -0,0 +1,167 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +type ('v,'t) generator = [ + | `Empty of 't + | `Gen of 't + | `From_list of 't * 'v list +] + +type ('v,'t) mutator = [ + | `Rev of 't * 't + | `Cons of 't * 'v * 't + | `Snoc of 't * 'v * 't + | `Tl of 't * 't + | `Append of 't * 't * 't + | `Rev_map of 't * 't + | `Map of 't * 't +] + +type ('v,'t) observer = [ + | `Is_empty of 't + | `Length of 't + | `Hd of 't + | `To_string of 't + | `To_list of 't + | `Compare of 't * 't + | `Iter of 't + | `Fold of 't +] + +(* + val pop : 'a t -> 'a * 'a t + val flatten : 'a t t -> 'a t + + val rev_map : ('a -> 'b) -> 'a t -> 'b t + val map : ('a -> 'b) -> 'a t -> 'b t +*) + + +type ('v,'t) op = [ + | ('v,'t) generator + | ('v,'t) mutator + | ('v,'t) observer +] + +let coerce_gen x = (x :> ('v,'t) op) +let coerce_mut x = (x :> ('v,'t) op) +let coerce_obs x = (x :> ('v,'t) op) + +let classify = function + | #generator as o -> Dug.Generator o + | #mutator as o -> Dug.Mutator o + | #observer as o -> Dug.Observer o + +let op_to_string : ('v,'t) op -> string = function + | `Empty _ -> "empty" + | `Gen _ -> "gen" + | `From_list _ -> "from_list" + | `Rev _ -> "rev" + | `Cons _ -> "cons" + | `Snoc _ -> "snoc" + | `Tl _ -> "tl" + | `Append _ -> "append" + | `Is_empty _ -> "is_empty" + | `Length _ -> "length" + | `Hd _ -> "hd" + | `To_string _ -> "to_string" + | `To_list _ -> "to_list" + | `Compare _ -> "compare" + | `Iter _ -> "iter" + | `Fold _ -> "fold" + | `Rev_map _ -> "rev_map" + | `Map _ -> "map" + +let op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list = function + | `Empty _ + | `Gen _ + | `From_list _ -> [] + | `Rev(_,t) + | `Cons(_,_,t) + | `Snoc(_,_,t) + | `Tl(_,t) + | `Is_empty t + | `Length t + | `Hd t + | `Rev_map(_,t) + | `Map(_,t) + | `Iter t + | `Fold t + | `To_list t + | `To_string t -> [t] + | `Append(_,t1,t2) + | `Compare(t1,t2) -> [t1;t2] + +let create_op uop id elt_f t_f = match uop with + | `Empty _ -> `Empty (id) + | `Gen _ -> `Gen(id) + | `From_list _ -> assert false + | `Rev _ -> `Rev(id,t_f 0) + | `Cons _ -> `Cons(id,elt_f(),t_f 0) + | `Snoc _ -> `Snoc(id,elt_f(),t_f 0) + | `Tl _ -> `Tl(id,t_f 0) + | `Append _ -> `Append(id,t_f 0, t_f 1) + | `Is_empty _ -> `Is_empty(t_f 0) + | `Length _ -> `Length(t_f 0) + | `Hd _ -> `Hd(t_f 0) + | `Iter _ -> `Iter(t_f 0) + | `Fold _ -> `Fold(t_f 0) + | `To_list _ -> `To_list(t_f 0) + | `To_string _ -> `To_string(t_f 0) + | `Compare _ -> `Compare(t_f 0,t_f 1) + | `Rev_map _ -> `Rev_map(id,t_f 0) + | `Map _ -> `Map(id,t_f 0) + +let strip op = assert false (*create_op op () (fun () -> ()) (fun _ -> ())*) + +(* +module Extractor(A : MonoTypes.ArbitraryComparable) = struct + let graph = Dug.create () + let clear_profile () = Dug.clear graph + let get_dug () = graph + module L = SList + + type 'a t = 'a L.t Dug_extractor.wrap + + module DE = Dug_extractor + + let empty = DE.generate graph (`Empty ()) L.empty + let gen rs = DE.generate graph (`Empty ()) L.empty (*FIXME*) + + let is_empty t = DE.observe graph (`Is_empty ()) L.is_empty t + let length t = DE.observe graph (`Length ()) L.length t + let hd t = DE.observe graph (`Hd ()) L.hd t + + (** TODO *) + let from_list l = empty + let flatten t = empty + let pop t = assert false + + let iter f t = DE.observe graph (`Iter ()) (L.iter f) t + let fold f acc t = DE.observe graph (`Fold ()) (L.fold f acc) t + let to_list t = DE.observe graph (`To_list ()) L.to_list t + let to_string t = DE.observe graph (`To_string ()) L.to_string t + let compare f t1 t2 = DE.observe2 graph (`Compare((),())) (L.compare f) t1 t2 + + let rev t = DE.mutate graph (`Rev((),())) L.rev t + let cons x t= DE.mutate graph (`Cons((),(),())) (L.cons x) t + let snoc x t = DE.mutate graph (`Snoc((),(),())) (L.snoc x) t + let tl t = DE.mutate graph (`Tl((),())) L.tl t + let append t1 t2 = DE.mutate2 graph (`Append((),(),())) L.append t1 t2 + + let rev_map f t = DE.mutate graph (`Rev_map((),())) (L.rev_map f) t + let map f t = DE.mutate graph (`Map((),())) (L.map f) t + +end + + +module Benchmark = struct +end +*) diff --git a/src/oracle/oracleList.mli b/src/oracle/oracleList.mli new file mode 100644 index 0000000..22fa564 --- /dev/null +++ b/src/oracle/oracleList.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** List ADT which captures a DUG as a side effect *) + +include DugADT.S +(* +module Extractor : functor(A : Types.ArbitraryComparable) -> +sig + + include Lists.S + + val get_dug : unit -> + ((unit,unit) generator, + (unit,unit) mutator, + (unit,unit) observer) Dug.t + + val clear_profile : unit -> unit +end + + +module Benchmark : functor(L : Lists.S) -> +sig + val benchmark : + (('a,Dug.Id.t) generator, + ('a,Dug.Id.t) mutator, + ('a,Dug.Id.t) observer) Dug.t + -> float +end +*) diff --git a/src/oracle/oracleSet.ml b/src/oracle/oracleSet.ml new file mode 100644 index 0000000..bab1227 --- /dev/null +++ b/src/oracle/oracleSet.ml @@ -0,0 +1,336 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types +open Dug + +type nodeid = Dug.Id.t + +type ('v,'t) generator = [ +| `Empty of 't +| `Singleton of 't * 'v +| `Gen1 of 't +| `Gen of 't +| `From_cursor of 't +] + +type ('v,'t) mutator = [ +| `Add of 't * 'v * 't +| `Remove of 't * 'v * 't +| `Union of 't * 't * 't +| `Inter of 't * 't * 't +| `Diff of 't * 't * 't +] + +type ('v,'t) observer = [ + | `Min_elt of 't + | `Max_elt of 't + | `Choose of 't + | `Is_empty of 't + | `Mem of 'v * 't + | `Equal of 't * 't + | `Well_formed of 't + | `Cardinal of 't + | `Compare of 't * 't + | `To_string of 't + | `Fold of 't + | `Iter of 't +] + +(* the type of all set operations *) +type ('v,'t) op = [ + ('v,'t) generator + | ('v,'t) mutator + | ('v,'t) observer +] + +let op_to_string = function + | `Min_elt _ -> "min_elt" + | `Max_elt _ -> "max_elt" + | `Choose _ -> "choose" + | `Is_empty _ -> "is_empty" + | `Mem _ -> "mem" + | `Equal _ -> "equal" + | `Well_formed _ -> "well_formed" + | `Cardinal _ -> "cardinal" + | `Compare _ -> "compare" + | `Empty _ -> "empty" + | `Singleton _ -> "singleton" + | `Add _ -> "add" + | `Remove _ -> "remove" + | `Union _ -> "union" + | `Inter _ -> "inter" + | `Diff _ -> "diff" + | `Gen1 _ -> "gen1" + | `Gen _ -> "gen" + | `From_cursor _ -> "from_cursor" + | `To_string _ -> "to_string" + | `Iter _ -> "iter" + | `Fold _ -> "fold" + +let classify = function + | #generator as o -> Dug.Generator o + | #mutator as o -> Dug.Mutator o + | #observer as o -> Dug.Observer o + +let op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list = function + | #generator -> [] + + | `Min_elt t + | `Max_elt t + | `Choose t + | `Is_empty t + | `Mem(_,t) + | `Well_formed t + | `Cardinal t + | `Add(_,_,t) + | `Remove(_,_,t) + | `Iter t + | `Fold t + | `To_string t -> [t] + + | `Equal(t1,t2) + | `Compare(t1,t2) + | `Union(_,t1,t2) + | `Inter(_,t1,t2) + | `Diff(_,t1,t2) -> [t1;t2] + +let coerce_gen x = (x :> ('a,'b) op) +let coerce_mut x = (x :> ('a,'b) op) +let coerce_obs x = (x :> ('a,'b) op) + +let create_op uop id elt_f t_f = + match uop with + | `Min_elt _ -> `Min_elt (t_f 0) + | `Max_elt _ -> `Max_elt (t_f 0) + | `Choose _ -> `Choose (t_f 0) + | `Is_empty _ -> `Is_empty (t_f 0) + | `Mem _ -> `Mem(elt_f (), t_f 0) + | `Equal _ -> `Equal(t_f 0,t_f 1) + | `Well_formed _ -> `Well_formed(t_f 0) + | `Cardinal _ -> `Cardinal(t_f 0) + | `Compare _ -> `Compare(t_f 0,t_f 1) + | `Empty _ -> `Empty(id) + | `Singleton _ -> `Singleton(id,elt_f ()) + | `Add _ -> `Add(id,elt_f (),t_f 0) + | `Remove _ -> `Remove(id,elt_f (), t_f 0) + | `Union _ -> `Union(id,t_f 0,t_f 1) + | `Inter _ -> `Inter(id,t_f 0,t_f 1) + | `Diff _ -> `Diff(id,t_f 0,t_f 1) + | `Gen1 _ -> `Gen1(id) + | `Gen _ -> `Gen(id) + | `From_cursor _ -> `From_cursor(id) + | `Iter _ -> `Iter(t_f 0) + | `Fold _ -> `Fold(t_f 0) + | `To_string _ -> `To_string(t_f 0) + +let strip (op : ('a,'b) op) : (unit,unit) op = + create_op op () (fun () -> ()) (fun _ -> ()) + + +(**********************************************************) + + +module Extractor(A : Mono.ArbitraryComparable) : sig + include Sets.GenSetSig with type 'a result = 'a + and type elt = A.t + val get_dug : unit -> + ((elt,Dug.Id.t) generator, + (elt,Dug.Id.t) mutator, + (elt,Dug.Id.t) observer) Dug.t + val clear_profile : unit -> unit +end = struct + module S = AVLSet.MonoSet(A) + + let graph = Dug.create () + + let clear_profile () = Dug.clear graph + + type 'a result = 'a S.result + type t = S.t DugExtractor.wrap + type 'a set = t + type cursor = S.cursor + type 'a cursor_ = 'a S.cursor_ + type elt = S.elt + type 'a elt_ = 'a S.elt_ + type ('a,'b) result_ = ('a,'b) S.result_ + + (* since we are storing the element and set types as a side effect + of these operations, OCaml is unable to generalize the + polymorphic form of these types, so we need to provide explicit + specializations (we don't actually use the parameter anyway) *) + type uelt = unit S.elt_ + type uset = unit S.set + type 'a ures = ('a,unit) S.result_ + type ut = uset DugExtractor.wrap + + module DE = DugExtractor + + let empty : t = DE.generate graph (fun t -> `Empty t) S.empty + let singleton (x:uelt) : ut = + DE.generate graph (fun t -> `Singleton(t,x)) (S.singleton x) + + let is_empty t = DE.observe graph (`Is_empty t.DE.id) S.is_empty t + + let mem (x:uelt) (t:ut) : bool ures = + DE.observe graph (`Mem(x,t.DE.id)) (S.mem x) t + + let add (x:uelt) (t:ut) : ut = + DE.mutate graph (fun r -> `Add(r,x,t.DE.id)) (S.add x) t + + let remove (x:uelt) (t:ut) : ut = + DE.mutate graph (fun r -> `Remove(r,x,t.DE.id)) (S.remove x) t + + let min_elt t = DE.observe graph (`Min_elt t.DE.id) S.min_elt t + + let max_elt t = DE.observe graph (`Max_elt t.DE.id) S.max_elt t + + let choose t = DE.observe graph (`Choose t.DE.id) S.choose t + + let cardinal t = DE.observe graph (`Cardinal t.DE.id) S.cardinal t + + let compare t1 t2 = DE.observe2 graph (`Compare(t1.DE.id,t2.DE.id)) S.compare t1 t2 + + let equal t1 t2 = DE.observe2 graph (`Equal(t1.DE.id, t2.DE.id)) S.equal t1 t2 + + let iter f t = DE.observe graph (`Iter t.DE.id) (S.iter f) t + let fold f acc t = DE.observe graph (`Fold t.DE.id) (S.fold f acc) t + + let union t1 t2 = DE.mutate2 graph (fun r -> `Union(r,t1.DE.id,t2.DE.id)) S.union t1 t2 + let inter t1 t2 = DE.mutate2 graph (fun r -> `Inter(r,t1.DE.id,t2.DE.id)) S.inter t1 t2 + let diff t1 t2 = DE.mutate2 graph (fun r -> `Diff (r,t1.DE.id,t2.DE.id)) S.diff t1 t2 + + (* OCaml can't generalize the return type of f ('a elt_) even though + 'a isn't used. It doesn't seem to notice if I annotate it and + explicitly instantiate the variable either... so we'll just always + generate an empty container for now. (at least until I address + adding HOF's to this framework in a more general way) + *) + let gen1 f ?size rs : unit S.set DE.wrap = empty + (*DE.generate graph (`Gen1(f,rs)) (S.gen1 f ?size rs)*) + + let gen ?size rs : unit S.set DE.wrap = empty + (*DE.generate graph (`Gen1(f,rs)) (S.gen1 f ?size rs)*) + + let well_formed t = + DE.observe graph (`Well_formed t.DE.id) S.well_formed t + + let of_result = S.of_result + + let to_cursor t = S.to_cursor t.DE.data + + (* + let from_cursor (c : unit S.cursor_) : unit S.set DE.wrap = + DE.generate graph (fun i -> `From_cursor(i,c)) (S.from_cursor c) + *) + let from_cursor c = empty + (* these don't invole type t at all *) + let at_top = S.at_top + let at_left = S.at_left + let at_right = S.at_right + let move_up = S.move_up + let move_down_left = S.move_down_left + let move_down_right = S.move_down_right + let went_left = S.went_left + let went_right = S.went_right + let has_value = S.has_value + let get_value = S.get_value + + let to_string t = DE.observe graph ( `To_string t.DE.id) S.to_string t + + let get_dug () : + ((S.elt,Dug.Id.t) generator, + (S.elt,Dug.Id.t) mutator, + (S.elt,Dug.Id.t) observer) Dug.t + = graph + +end + + +(**********************************************************) + + +module Benchmark(S : Sets.GenSetSig with type 'a result = 'a) = struct + + module VarMap = Map.Make(Dug.Id) + + type env = S.t VarMap.t + + let empty_env = VarMap.empty + + let eval_rs = Random.State.make_self_init () + let eval_t env op = + let id,t = match op with + | `Empty id -> id,S.empty + | `Singleton(id,x) -> id,S.singleton x + | `Add(id,x,t) -> id,S.add x (VarMap.find t env) + | `Remove(id,x,t) -> id,S.remove x (VarMap.find t env) + | `Union(id,t1,t2) -> id,S.union (VarMap.find t1 env) (VarMap.find t2 env) + | `Inter(id,t1,t2) -> id,S.inter (VarMap.find t1 env) (VarMap.find t2 env) + | `Diff(id,t1,t2) -> id,S.diff (VarMap.find t1 env) (VarMap.find t2 env) + | `Gen1(id) -> id, S.empty (*(S.gen1 A.gen eval_rs)*) + | `Gen(id) -> id, (S.gen eval_rs) + | `From_cursor(id) -> id,S.empty + in + VarMap.add id t env + + let rec eval_obs env = function + | `Min_elt t -> ignore(S.min_elt (VarMap.find t env)) + | `Max_elt t -> ignore(S.max_elt (VarMap.find t env)) + | `Choose t -> ignore(S.choose (VarMap.find t env)) + | `Is_empty t -> ignore(S.is_empty (VarMap.find t env)) + | `Mem(x,t) -> ignore(S.mem x (VarMap.find t env)) + | `Equal(t1,t2) -> ignore(S.equal (VarMap.find t1 env) (VarMap.find t2 env)) + | `Well_formed t -> ignore(S.well_formed (VarMap.find t env)) + | `Cardinal t -> ignore(S.cardinal (VarMap.find t env)) + | `Compare(t1,t2) -> ignore(S.compare (VarMap.find t1 env) (VarMap.find t2 env)) + | `To_string t -> ignore(S.to_string (VarMap.find t env)) + | `Iter t -> ignore(S.iter (fun _ -> ()) (VarMap.find t env)) + | `Fold t -> ignore(S.fold (fun _ _ -> ()) () (VarMap.find t env)) + + let eval_op env op = match op with + | #generator as o -> eval_t env o + | #mutator as o -> eval_t env o + | #observer as o -> eval_obs env o; env + + let dug_to_list dug = + let rec helper id acc = + if Dug.Id.compare id Dug.Id.zero <= 0 then acc + else + let op = match Hashtbl.find dug.nodes id with + | Generator o -> coerce_gen o + | Mutator o -> coerce_mut o + | Observer o -> coerce_obs o + in helper (Dug.Id.pred id) (op :: acc) + in helper dug.current_id [] + + let benchmark dug = + let lst = dug_to_list dug in + let start = Unix.gettimeofday () in + let _ = List.fold_left eval_op empty_env lst in + let fin = Unix.gettimeofday() in + fin -. start + +end + +(* + module type ResS = Sets.GenSet with type 'a result = 'a + + module Make_Is_Set + (S : ResS) + (A : ArbitraryComparable with type t = S.elt) + : ResS + = Make(S)(A) + + + Dug_set: + module Profile(A) + module Benchmark(HOSet)(A) + +*) diff --git a/src/oracle/oracleSet.mli b/src/oracle/oracleSet.mli new file mode 100644 index 0000000..2ab9862 --- /dev/null +++ b/src/oracle/oracleSet.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Set ADT which captures a DUG as a side effect *) + +include DugADT.S + +module Extractor : functor(A : Types.Mono.ArbitraryComparable) -> +sig + + include Sets.GenSetSig with type 'a result = 'a + and type elt = A.t + + val get_dug : unit -> + ((elt,Dug.Id.t) generator, + (elt,Dug.Id.t) mutator, + (elt,Dug.Id.t) observer) Dug.t + + val clear_profile : unit -> unit +end + + +module Benchmark : + functor(S : Sets.GenSetSig with type 'a result = 'a) -> +sig + val benchmark : + ((S.elt,Dug.Id.t) generator, + (S.elt,Dug.Id.t) mutator, + (S.elt,Dug.Id.t) observer) Dug.t + -> float +end diff --git a/src/oracle/randomBag.ml b/src/oracle/randomBag.ml new file mode 100644 index 0000000..0c9b9c3 --- /dev/null +++ b/src/oracle/randomBag.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +include SkewBinaryList + +module RCurs = ListCursor.Make(SkewBinaryList) + +let add = cons + +let remove x t = + let rec helper c = + if RCurs.at_back c then failwith "remove"; + match RCurs.value c with + | None -> helper (RCurs.move_next c) + | Some y -> + if x = y then + let l = RCurs.list c in + let c = RCurs.replace_list (SkewBinaryList.tl l) c in + RCurs.from_cursor c + else helper (RCurs.move_next c) + in + helper (RCurs.to_cursor t) + + +let choose t = + if is_empty t then failwith "choose"; + let l = SkewBinaryList.length t in + let idx = Random.int l in + lookup idx t diff --git a/src/oracle/replayList.ml b/src/oracle/replayList.ml new file mode 100644 index 0000000..ca57db2 --- /dev/null +++ b/src/oracle/replayList.ml @@ -0,0 +1,133 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +type ('arg,'list,'listlist,'slist) op = [ + | `Is_empty of 'list + + | `Length of 'list + + | `Rev of 'list + + | `Cons of 'arg * 'list + + | `Snoc of 'arg * 'list + + | `Hd of 'list + + | `Tl of 'list + + | `Pop of 'list + + | `Append of 'list * 'list + + | `Flatten of 'listlist + + | `From_list of 'slist + + | `To_list of 'list + + | `Iter of 'list + + | `Fold of 'list + + | `Rev_map of 'list + + | `Map of 'list + + | `To_string of ('arg -> string) * 'list + + | `Compare of ('arg -> 'arg -> int) * 'list * 'list + + | `Gen of (?size:int -> Random.State.t -> 'arg) * int option * Random.State.t + ] + + +module Replay(L : Lists.ListSig) = struct + let eval = function + | `Is_empty t -> ignore(L.is_empty t) + | `Length t -> ignore(L.length t) + | `Rev t -> ignore(L.rev t) + | `Cons(x,t) -> ignore(L.cons x t) + | `Snoc(x,t) -> ignore(L.snoc x t) + | `Hd t -> ignore(L.hd t) + | `Tl t -> ignore(L.tl t) + | `Pop t -> ignore(L.pop t) + | `Append(t1, t2) -> ignore(L.append t1 t2) + | `Flatten t -> ignore(L.flatten t) + | `From_list l -> ignore(L.from_list l) + | `To_list t -> ignore(L.to_list t) + | `Iter t -> ignore(L.iter (fun _ -> ()) t) + | `Fold t -> ignore(L.fold (fun () _ -> ()) () t) + | `Rev_map t -> ignore(L.rev_map (fun x -> x) t) + | `Map t -> ignore(L.map (fun x -> x) t) + | `To_string(to_s, t) -> ignore(L.to_string to_s t) + | `Compare(f, t1, t2) -> ignore(L.compare f t1 t2) + | `Gen(f, size, rs) -> ignore(L.gen f ~size:size rs) +end + +let replay history = match history with + | [] -> () + | _ -> + let lst = List.rev history in + let module RL = Replay(SList) in + List.iter RL.eval lst + + + +module Make(L : Lists.ListSig)(A : sig type t end) = struct + + let __history : (A.t,A.t L.t, A.t L.t L.t, A.t list) op list ref = ref [] + + let __save x = + __history := x :: !__history + +(* let _ = at_exit (fun () -> replay !__history)*) + + type t = A.t L.t + + let empty = L.empty + + let is_empty (t:t) = __save (`Is_empty t);L.is_empty t + + let length (t:t) = __save (`Length t); L.length t + + let rev (t:t) = __save (`Rev t);L.rev t + + let cons x (t:t) = __save (`Cons(x,t)); L.cons x t + + let snoc x (t:t) = __save (`Snoc(x,t)); L.snoc x t + + let hd (t:t) = __save (`Hd t); L.hd t + + let tl (t:t) = __save (`Tl t); L.tl t + + let pop (t:t) = __save (`Pop t); L.pop t + + let append (t1:t) (t2:t) = __save (`Append(t1,t2)); L.append t1 t2 + + let flatten (t:t L.t) = __save (`Flatten t); L.flatten t + + let from_list (l:A.t list) = __save (`From_list l); L.from_list l + + let to_list (t:t) = __save (`To_list t); L.to_list t + + let iter f (t:t) = __save (`Iter t); L.iter f t + + let fold f acc (t:t) = __save (`Fold t); L.fold f acc t + + let rev_map f (t:t) = __save (`Rev_map t); L.rev_map f t + + let map (f:A.t->'a) (t:t) = __save (`Map t); L.map f t + + let to_string to_s (t:t) = __save (`To_string(to_s,t)); L.to_string to_s t + + let compare (f:A.t->A.t->int) t1 t2 = __save (`Compare(f,t1,t2)); L.compare f t1 t2 + + let gen f ?size rs : t = __save (`Gen(f,size,Random.State.copy rs)); L.gen f ?size rs +end diff --git a/src/set/OMakefile b/src/set/OMakefile new file mode 100644 index 0000000..d06001a --- /dev/null +++ b/src/set/OMakefile @@ -0,0 +1,9 @@ + +OCAMLINCLUDES += ../base ../iterator + +FILES[] += + set/sets + set/aVLSet + set/splaySet + set/rBSet + set/patriciaSet diff --git a/src/set/aVLSet.ml b/src/set/aVLSet.ml new file mode 100644 index 0000000..17db9f6 --- /dev/null +++ b/src/set/aVLSet.ml @@ -0,0 +1,505 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +(** The main functor for implementing sets. The paramater field + HeightDiff.v specifies the maximum difference between the heights + of two subtrees joined at a node. +*) +module BaseSet (HeightDiff : sig val v : int end) = struct + +(** The types of AVL trees. An element can be either stored in a Leaf + if it has no children, or in a Node if it has at least 1 child. + The constructor Node(l,v,r,h) also contains the left branch 'l' (all + elements are smaller than v), the right branch 'r' (all elements + greater than v) and the heigh of the tree at that point. +*) + type 'a tree = + | Empty + | Leaf of 'a + | Node of 'a tree * 'a * 'a tree * int + + let of_result x = x + + let empty = Empty + + let singleton x = Leaf x + + let is_empty = function + | Empty -> true + | _ -> false + + let rec mem cmp x = function + | Empty -> false + | Leaf y -> (cmp x y) = 0 + | Node(l,y,r,_) -> match cmp x y with + | 0 -> true + | c when c < 0 -> mem cmp x l + | _ -> mem cmp x r + + let rec fold f acc t = match t with + | Empty -> acc + | Leaf x -> f acc x + | Node(l,v,r,_) -> + fold f (f (fold f acc l) v) r + + let rec iter f t = match t with + | Empty -> () + | Leaf x -> f x + | Node(l,v,r,_) -> + iter f l; f v; iter f r + + let rec min_elt = function + | Empty -> raise Not_found + | Leaf x -> x + | Node(Empty,v,_,_) -> v + | Node(l,_,_,_) -> min_elt l + + let rec max_elt = function + | Empty -> raise Not_found + | Leaf x -> x + | Node(_,v,Empty,_) -> v + | Node(_,_,r,_) -> max_elt r + + let height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node(_,_,_,h) -> h + + (** N-"smart" constructor (a la Stephen Adams). This function + chooses the right constructor based on the number of children + and ensures that the Node constructor is well formed. + *) + let node l v r = + match height l, height r with + | 0,0 -> Leaf v + | hl,hr -> Node(l,v,r, (max hl hr)+1) + + let pivot ll lv c rv rr = match c with + | Node(cl,cv,cr,_) -> + node (node ll lv cl) cv (node cr rv rr) + | Leaf cv -> + node (node ll lv Empty) cv (node Empty rv rr) + | Empty -> assert false + + (** This function will fix the tree if the left subtree has a height + at most HeightDiff.v +1 more than that of the right subtree. *) + let rebal_left ll lv lr v r = + if height ll >= height lr + then node ll lv (node lr v r) + else pivot ll lv lr v r + + (** This function will fix the tree if the right subtree has a + height at most HeightDiff.v +1 more than that of the left + subtree. *) + let rebal_right l v rl rv rr = + if height rr >= height rl + then node (node l v rl) rv rr + else pivot l v rl rv rr + + (** T'-"smart" constructor: fixes trees by performing at most 1 + rotation. *) + let rotate l v r = + match l,r with + (* Height 1 tree *) + | Empty, Empty -> Leaf v + + (* Height 2 tree *) + | Empty, Leaf _ + | Leaf _, Empty + | Leaf _, Leaf _ -> Node(l,v,r,2) + + (* General Height 'h' *) + | Node(ll,lv,lr,h), Empty -> + if h > HeightDiff.v + then rebal_left ll lv lr v r + else Node(l,v,r,h+1) + | Empty, Node(rl,rv,rr,h) -> + if h > HeightDiff.v + then rebal_right l v rl rv rr + else Node(l,v,r,h+1) + + | Leaf _, Node(_,_,_,h) (* 1 + for Leaf _ *) + | Node(_,_,_,h), Leaf _ when h <= (1 + HeightDiff.v) -> + Node(l,v,r,h+1) + + | Leaf _, Node(rl,rv,rr,h) -> rebal_right l v rl rv rr + | Node(ll,lv,lr,h), Leaf _ -> rebal_left ll lv lr v r + + | Node(ll,lv,lr,lh), Node(rl,rv,rr,rh) -> + if lh > rh + HeightDiff.v + then rebal_left ll lv lr v r + else if rh > lh + HeightDiff.v + then rebal_right l v rl rv rr + else node l v r + + let rec add cmp newe t = match t with + | Empty -> Leaf newe + | Leaf elt -> + begin match cmp newe elt with + | 0 -> t + | c when c < 0 -> Node(Empty,newe,t,2) + | _ -> Node(t, newe, Empty,2) + end + | Node(l,elt,r,_) -> + match cmp newe elt with + | 0 -> t + | c when c < 0 -> rotate (add cmp newe l) elt r + | _ -> rotate l elt (add cmp newe r) + + let rec get_and_remove_min = function + | Empty -> raise (Invalid_argument "get_and_remove_min") + | Leaf elt -> elt, Empty + | Node(Empty,elt,r,h) -> elt, r + | Node(l,elt,r,h) -> + let d,newl = get_and_remove_min l in + d, rotate newl elt r + + let rec get_and_remove_max = function + | Empty -> raise (Invalid_argument "get_and_remove_max") + | Leaf elt -> elt, Empty + | Node(l,elt,Empty,h) -> elt, l + | Node(l,elt,r,h) -> + let d,newr = get_and_remove_max r in + d, rotate l elt newr + + let rec remove cmp dele t = match t with + | Empty -> Empty + | Leaf elt + | Node(Empty,elt,Empty,_) -> + if (cmp dele elt) = 0 then Empty else Leaf elt + + | Node(l,elt,r,_) -> match cmp dele elt with + | 0 -> + if r = Empty then l + else if l = Empty then r else + let d,newr = get_and_remove_min r in + rotate l d newr + + | c when c < 0 -> rotate (remove cmp dele l) elt r + | _ -> rotate l elt (remove cmp dele r) + + (** join trees of arbitrary size *) + let rec concat3 cmp l v r = match l,r with + | Empty, r -> add cmp v r + | l, Empty -> add cmp v l + | Leaf x, Leaf y -> node l v r + | Leaf x, Node(l2,v2,r2,h) -> + if h > (1 + HeightDiff.v) + then rotate (concat3 cmp l v l2) v2 r2 + else node l v r + | Node(l1,v1,r1,h), Leaf x -> + if h > (1 + HeightDiff.v) + then rotate l1 v1 (concat3 cmp r1 v r) + else node l v r + | Node(l1,v1,r1,h1),Node(l2,v2,r2,h2) -> + if h2 > h1 + HeightDiff.v + then rotate (concat3 cmp l v l2) v2 r2 + else if h1 > h2 + HeightDiff.v + then rotate l1 v1 (concat3 cmp r1 v r) + else node l v r + + (* equivalent to (split_lt v t), (split_gt v t) *) + let rec split cmp v t = match t with + | Empty -> Empty, Empty + | Leaf elt -> begin match cmp v elt with + | 0 -> Empty,Empty + | c when c < 0 -> Empty,t + | _ -> t,Empty + end + | Node(l1,elt,r1,_) -> + match cmp v elt with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp v l1 in + (l2,concat3 cmp r2 elt r1) + | _ -> + let l2,r2 = split cmp v r1 in + (concat3 cmp l1 elt l2), r2 + + let rec union cmp t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | Leaf x,r -> add cmp x r + | l,Leaf x -> add cmp x l + | t1, Node(l,v,r,_) -> + let l',r' = split cmp v t1 in + concat3 cmp (union cmp l' l) v (union cmp r' r) + + let rec concat t1 t2 = match t1,t2 with + | Empty, _ -> t2 + | _, Empty -> t1 + | Leaf x, Leaf y -> Node(t1,y,Empty,2) + | Leaf x, Node(l2,v2,r2,h) -> + if h > 1+HeightDiff.v + then rotate (concat t1 l2) v2 r2 + else + let m,t2' = get_and_remove_min t2 in + rotate t1 m t2' + | Node(l1,v1,r1,h), Leaf x -> + if h > 1+HeightDiff.v + then rotate l1 v1 (concat r1 t2) + else rotate t1 x Empty (* inline get_*_min for Leaf *) + | Node(l1,v1,r1,h1), Node(l2,v2,r2,h2) -> + if h2 > h1 + HeightDiff.v + then rotate (concat t1 l2) v2 r2 + else if h1 > h2 + HeightDiff.v + then rotate l1 v1 (concat r1 t2) + else + let m,t2' = get_and_remove_min t2 in + rotate t1 m t2' + + let rec diff cmp t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, Leaf y -> remove cmp y t1 + | _, Node(l,v,r,_) -> + let l',r' = split cmp v t1 in + concat (diff cmp l' l) (diff cmp r' r) + + let rec inter cmp t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, Leaf x -> if mem cmp x t1 then t2 else Empty + | t1, Node(l,v,r,_) -> + let l',r' = split cmp v t1 in + if mem cmp v t1 + then concat3 cmp (inter cmp l' l) v (inter cmp r' r) + else concat (inter cmp l' l) (inter cmp r' r) + + let choose = function + | Empty -> raise Not_found + | Leaf x -> x + | Node(_,x,_,_) -> x + + let rec cardinal = function + | Empty -> 0 + | Leaf _ -> 1 + | Node(l,_,r,_) -> 1 + (cardinal l) + (cardinal r) + + let rec cmp c x y = + match (is_empty x), (is_empty y) with + | true, true -> 0 + | true, false -> -1 + | false, true -> 1 + | false, false -> + let xm = min_elt x in + let ym = min_elt y in + match c xm ym with + | 0 -> cmp c (remove c xm x) (remove c ym y) + | v -> v + + let rec well_ordered cmp = function + | Empty -> true + | Leaf _ -> true + | Node(Empty,_,Empty,_) -> true + | Node(((Leaf x)|Node(_,x,_,_) as l),elt,Empty,_) -> + (well_ordered cmp l) && (cmp x elt < 0) + | Node(Empty,elt,((Leaf x)|Node(_,x,_,_) as r),_) -> + (well_ordered cmp r) && (cmp x elt > 0) + + | Node(((Leaf lx)|Node(_,lx,_,_) as l) + ,elt, + ((Leaf rx)|Node(_,rx,_,_) as r), + _) -> + (well_ordered cmp l) && (well_ordered cmp r) && + (cmp lx elt < 0) && (cmp rx elt > 0) + + let well_formed_height = function + | Empty | Leaf _ -> true + | Node(l,v,r,h) -> + let hl = height l in + let hr = height r in + (h = (max hl hr) + 1) && + (abs (hl - hr) <= HeightDiff.v) + + let rec well_formed cmp t = (well_ordered cmp t) && (well_formed_height t) + + type 'a path = + | Top + | PathL of 'a path * 'a * 'a tree + | PathR of 'a tree * 'a * 'a path + + type 'a curs = 'a path * 'a tree + + let to_cursor t = Top,t + + let at_top (p,t) = (p = Top) + + let at_left (p,t) = match t with + | Empty | Leaf _ -> true + | _ -> false + + let at_right (p,t) = match t with + | Empty | Leaf _ -> true + | _ -> false + + let went_left (p,t) = match p with + | PathL _ -> true + | _ -> false + + let went_right (p,t) = match p with + | PathR _ -> true + | _ -> false + + let move_up = function + | Top, _ -> failwith "move_up" + | PathL(p,x,r),l | PathR(l,x,p),r -> p, (node l x r) + + let move_down_left = function + | _,Empty + | _, Leaf _ -> failwith "move_down_left" + | p, Node(l,v,r,h) -> PathL(p,v,r),l + + let move_down_right = function + | _,Empty + | _, Leaf _ -> failwith "move_down_right" + | p,Node(l,v,r,h) -> PathR(l,v,p),r + + let rec from_cursor ((p,t) as curs) = + if at_top curs then t + else from_cursor (move_up curs) + + let has_value (p,t) = match t with Empty -> false | _ -> true + + let get_value = function + | _,Empty -> failwith "get_value" + | _,Leaf x + | _,Node(_,x,_,_) -> x + + let rec move_to_ancestor cmp x ((p,t) as curs) = match p with + | Top -> curs + | PathL(p', v, r) -> + if cmp x v < 0 then curs + else move_to_ancestor cmp x (move_up curs) + | PathR(_,v,_) -> + if cmp x v > 0 then curs + else move_to_ancestor cmp x (move_up curs) + + let rec move_to cmp x curs = + let (p,t) as curs = move_to_ancestor cmp x curs in + match t with + | Empty -> raise Not_found + | Leaf v -> if (cmp x v) = 0 then curs else raise Not_found + | Node(l,v,r,_) -> match cmp x v with + | 0 -> curs + | c when c < 0 -> move_to cmp x (move_down_left curs) + | _ -> move_to cmp x (move_down_right curs) + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | Leaf x -> to_s x + | Node(Empty,v,Empty,_) -> to_s v + | Node(l,v,Empty,_) -> Printf.sprintf "%s, %s" (h l) (to_s v) + | Node(Empty,v,r,_) -> Printf.sprintf "%s, %s" (to_s v) (h r) + | Node(l,v,r,_) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s v) (h r) + in + "{" ^ (h t) ^ "}" + + let gen_ cmp (agen: ?size:int -> Random.State.t -> 'a) ?(size=50) rs : 'a tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (add cmp (agen ~size:size rs) t) + in + loop num empty + +end + +module AVL_PolySet (HeightDiff : sig val v : int end) = +struct + module BH = BaseSet(HeightDiff) + include BH +(* include Cursor.Mixin(BH)*) + + type 'a t = 'a tree + type 'a set = 'a t + type 'a elt_ = 'a + + type 'a cursor = 'a curs + type 'a cursor_ = 'a cursor + type ('a,'b) result = 'a + type ('a,'b) result_ = 'a + + let add x t = add Pervasives.compare x t + let mem x t = mem Pervasives.compare x t + let remove x t = remove Pervasives.compare x t + let split v t = split Pervasives.compare v t + let union t1 t2 = union Pervasives.compare t1 t2 + let diff t1 t2 = diff Pervasives.compare t1 t2 + let inter t1 t2 = inter Pervasives.compare t1 t2 + let well_formed t = well_formed Pervasives.compare t + let move_to_ancestor cmp x c = move_to_ancestor Pervasives.compare x c + let compare x y = cmp Pervasives.compare x y + let equal x y = compare x y = 0 + + let gen1 agen ?size rs = gen_ Pervasives.compare agen ?size rs + (*include Merge_mixin.Make(B)*) + +end + +module PolySet1 = AVL_PolySet(struct let v = 1 end) +module PolySet2 = AVL_PolySet(struct let v = 2 end) +module PolySet3 = AVL_PolySet(struct let v = 3 end) +module PolySet = PolySet2 + +module AVL_MonoSet (HeightDiff : sig val v : int end) (C : Mono.Comparable) = +struct + module BH = BaseSet(HeightDiff) + include BH +(* include Cursor.Mixin(BH)*) + + type elt = C.t + type t = C.t tree + type cursor = C.t curs + + type 'a elt_ = elt + type 'a set = t + type 'a cursor_ = cursor + type 'a result = 'a + type ('a,'b) result_ = 'a + + let add x t = add C.compare x t + let mem x t = mem C.compare x t + let remove x t = remove C.compare x t + let split v t = split C.compare v t + let union t1 t2 = union C.compare t1 t2 + let diff t1 t2 = diff C.compare t1 t2 + let inter t1 t2 = inter C.compare t1 t2 + let well_formed t = well_formed C.compare t + let move_to_ancestor cmp x c = move_to_ancestor C.compare x c + let compare x y = cmp C.compare x y + let equal x y = compare x y = 0 + + let to_string t = to_string C.to_string t + (*include Merge_mixin.Make(B)*) + + let gen1 agen ?size rs = gen_ C.compare agen ?size rs +end + +module MonoSet1 = AVL_MonoSet(struct let v = 1 end) +module MonoSet2 = AVL_MonoSet(struct let v = 2 end) +module MonoSet3 = AVL_MonoSet(struct let v = 3 end) +module MonoSet = MonoSet2 + +module AVL_GenSet (HeightDiff : sig val v : int end) + (C : Types.Mono.ArbitraryComparable) = +struct + include AVL_MonoSet(HeightDiff)(C) + + let gen ?size rs = gen1 C.gen ?size rs +end + +module GenSet1 = AVL_GenSet(struct let v = 1 end) +module GenSet2 = AVL_GenSet(struct let v = 2 end) +module GenSet3 = AVL_GenSet(struct let v = 3 end) + +module GenSet = GenSet2 diff --git a/src/set/aVLSet.mli b/src/set/aVLSet.mli new file mode 100644 index 0000000..e339329 --- /dev/null +++ b/src/set/aVLSet.mli @@ -0,0 +1,121 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Height balanced binary search trees implementing sets + + AVL trees are balanced binary search trees with O(log n) lookup, + add, and remove operations. The set operations [union], [inter], + and [diff] all take O(n) time. However, some inputs to these + functions will take significantly less time to process (e.g. when + one tree is significantly smaller than the other, or when the + trees have large number consecutive elements that do not overlap). +*) + +(** This module provides an implementation of AVL trees with a + polymorphic element type. The implementation uses the standard + library's polymorphic [compare] function internally and may not be + as efficient as the {!AVLSet.MonoSet} module which allows the use + of a more efficient comparison function. +*) +module PolySet : Sets.PolySetSigStd + +(** This functor provides an implementation of AVL trees that are + parameterized by a specific monomorphic element type. +*) +module MonoSet : Sets.MonoSetSigFnStd + +(** This functor is similar to the {!AVLSet.MonoSet} functor except + it is parameterized by a module that also supports the [gen] + operation. Therefore, the resulting module is also able to + generate number sets. +*) +module GenSet : Sets.GenSetSigFnStd + + +(** All of the module below are variations of the above modules that + allow client code to control the performance of the AVL tree. + Note that in most cases, the modules defined above will perform + the best. *) + +(** This functor is similar to the {!AVLSet.PolySet} module above, + except it allows the user to specify the maximum difference + between the heights of two subtrees at a node with [HeightDiff.v]. + The choice of this value affects the amount of effort spent + rebalancing the tree after it has been modified in exchange for + the cost of locating a particular element in the tree. The + modules {!AVLSet.PolySet1}, {!AVLSet.PolySet2}, and + {!AVLSet.PolySet3} below instantiate this functor with the values + 1, 2, and 3 respectively. Those modules are also defined in the + same compilation unit as the implementation code, so the value of + HeightDiff.v is inlined, increasing performance. +*) +module AVL_PolySet: + functor(HeightDiff : sig val v : int end) -> + Sets.PolySetSigStd + +(** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 1 *) +module PolySet1 : Sets.PolySetSigStd + +(** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 2 *) +module PolySet2 : Sets.PolySetSigStd + +(** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 3 *) +module PolySet3 : Sets.PolySetSigStd + +(** This functor is similar to the {!AVLSet.MonoSet} module above, + except it allows the user to specify the maximum difference + between the heights of two subtrees at a node with [HeightDiff.v]. + The choice of this value affects the amount of effort spent + rebalancing the tree after it has been modified in exchange for + the cost of locating a particular element in the tree. The + modules {!AVLSet.MonoSet1}, {!AVLSet.MonoSet2}, and + {!AVLSet.MonoSet3} below instantiate this functor with the values + 1, 2, and 3 respectively. Those modules are also defined in the + same compilation unit as the implementation code, so the value of + HeightDiff.v is inlined, increasing performance. +*) +module AVL_MonoSet: + functor(HeightDiff : sig val v : int end) -> + Sets.MonoSetSigFnStd + +(** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 1 *) +module MonoSet1: Sets.MonoSetSigFnStd + +(** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 2 *) +module MonoSet2: Sets.MonoSetSigFnStd + +(** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 3 *) +module MonoSet3: Sets.MonoSetSigFnStd + + +(** This functor is similar to the {!AVLSet.GenSet} module above, + except it allows the user to specify the maximum difference + between the heights of two subtrees at a node with [HeightDiff.v]. + The choice of this value affects the amount of effort spent + rebalancing the tree after it has been modified in exchange for + the cost of locating a particular element in the tree. The + modules {!AVLSet.GenSet1}, {!AVLSet.GenSet2}, and + {!AVLSet.GenSet3} below instantiate this functor with the values + 1, 2, and 3 respectively. Those modules are also defined in the + same compilation unit as the implementation code, so the value of + HeightDiff.v is inlined, increasing performance. +*) +module AVL_GenSet : + functor(HeightDiff : sig val v : int end) -> + Sets.GenSetSigFnStd + +(** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 1 *) +module GenSet1 : Sets.GenSetSigFnStd + +(** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 2 *) +module GenSet2 : Sets.GenSetSigFnStd + +(** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 3 *) +module GenSet3 : Sets.GenSetSigFnStd + diff --git a/src/set/patriciaSet.ml b/src/set/patriciaSet.ml new file mode 100644 index 0000000..22a04fb --- /dev/null +++ b/src/set/patriciaSet.ml @@ -0,0 +1,288 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module MonoSet = struct + + type elt = int + + type t = + | Empty + | Leaf of int + | Branch of int * int * t * t (* (prefix * branchbit * l * r) *) + + type 'a elt_ = elt + type 'a set = t + + type 'a result = 'a + type ('a,'b) result_ = 'a + + let of_result x = x + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let singleton x = Leaf x + + let zero_bit k m = (k land m) = 0 + + let mask k m = (k lor (m-1)) land (lnot m) + + let match_prefix k p m = (mask k m) = p + + let lowest_bit x = x land (-x) + + let highest_bit x m = + let x' = x land (lnot (m-1)) in + let rec highb x = + let m = lowest_bit x in + if x = m then m else highb (x-m) + in highb x' + + let branching_bit p0 m0 p1 m1 = + highest_bit (p0 lxor p1) (max 1 (2*(max m0 m1))) + + let rec mem x = function + | Empty -> false + | Leaf k -> x = k + | Branch(p,m,t0,t1) -> + if not (match_prefix x p m) then false + else if zero_bit x m then mem x t0 + else mem x t1 + + let branch p m t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | _ -> Branch(p,m,t1,t2) + + let get_branch_bit = function + | Empty | Leaf _ -> 0 + | Branch(_,b,_,_) -> b + + let join p0 t0 p1 t1 = + let m = branching_bit p0 (get_branch_bit t0) p1 (get_branch_bit t1) in + if zero_bit p0 m then Branch(mask p0 m, m, t0, t1) + else Branch(mask p0 m, m, t1, t0) + + let add x t = + let rec ins = function + | Empty -> Leaf x + | (Leaf y) as t -> + if x = y then t + else join x (Leaf x) y t + | Branch(p,m,t0,t1) as t -> + if match_prefix x p m then + if zero_bit x m then Branch(p,m,ins t0, t1) + else Branch(p,m,t0,ins t1) + else join x (Leaf x) p t + in ins t + + let rec merge s t = match s,t with + | Empty,t | t,Empty -> t + | Leaf(x), t | t, Leaf x -> add x t + | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m then (* same prefix, just recurse *) + Branch(p,m,merge s0 t0, merge s1 t1) + + else if m > n && match_prefix q p m then (* q contains p*) + if zero_bit q m + then Branch(p,m,merge s0 t,s1) + else Branch(p,m,s0,merge s1 t) + else if m < n && match_prefix p q n then (* p contains q*) + if zero_bit p n + then Branch(q,n,merge s t0,t1) + else Branch(q,n,t0,merge s t1) + else (* different prefixes *) + join p s q t + + let rec remove x t = match t with + | Empty -> Empty + | Leaf y -> if x = y then Empty else t + | Branch (p,m,t0,t1) -> + if match_prefix x p m then + if zero_bit x m + then branch p m (remove x t0) t1 + else branch p m t0 (remove x t1) + else t + + let rec min_elt = function + | Empty -> raise Not_found + | Leaf x -> x + | Branch(_,_,t0,_) -> min_elt t0 + + let rec max_elt = function + | Empty -> raise Not_found + | Leaf x -> x + | Branch(_,_,_,t1) -> max_elt t1 + + let rec cardinal = function + | Empty -> 0 + | Leaf _ -> 1 + | Branch (_,_,t0,t1) -> (cardinal t0) + (cardinal t1) + + let rec choose = function + | Empty -> raise Not_found + | Leaf k -> k + | Branch (_, _,t0,_) -> choose t0 + + let rec iter f = function + | Empty -> () + | Leaf x -> f x + | Branch(_,_,t0,t1) -> iter f t0; iter f t1 + + let rec fold f acc t = match t with + | Empty -> acc + | Leaf x -> f acc x + | Branch (_,_,t0,t1) -> fold f (fold f acc t0) t1 + + let rec no_empty_under_branch = function + | Empty -> true + | Leaf _ -> true + | Branch(_,_,Empty,_) + | Branch(_,_,_,Empty) -> false + | Branch(_,_,t0,t1) -> + (no_empty_under_branch t0) && (no_empty_under_branch t1) + + let well_formed t = + no_empty_under_branch t + + let to_string t = + let rec h = function + | Empty -> "" + | Leaf x -> string_of_int x + | Branch(_,_,Empty,Empty) -> "" + | Branch(_,_,subt,Empty) + | Branch(_,_,Empty,subt) -> h subt + | Branch(_,_,t0,t1) -> Printf.sprintf "%s, %s" (h t0) (h t1) + in "{" ^ (h t) ^ "}" + + let rec compare s t = match s,t with + | Empty, Empty -> 0 + | Empty, _ -> -1 + | _, Empty -> 1 + + | Leaf x, Leaf y -> Pervasives.compare x y + | Leaf _, Branch _ -> -1 + | Branch _, Leaf _ -> 1 + + | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> + if p < q then -1 + else if p > q then 1 + else if m < n then -1 + else if m > n then 1 + else match compare s0 t0 with + | 0 -> compare s1 t1 + | c -> c + + let equal s t = compare s t = 0 + + let union = merge + + let rec diff s t = match s,t with + | Empty,t -> Empty + | s,Empty -> s + | Leaf(x), t -> if mem x t then Empty else s + | s, Leaf x -> remove x s + | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m (* same prefix, just recurse *) + then merge (diff s0 t0) (diff s1 t1) + + else if m > n && match_prefix q p m then (* q contains p*) + if zero_bit q m + then merge (diff s0 t) s1 + else merge s0 (diff s1 t) + + else if m < n && match_prefix p q n then (* p contains q*) + if zero_bit p n + then diff s t0 + else diff s t1 + + else (* different prefixes *) + s + + let rec inter s t = match s,t with + | Empty,_ -> Empty | _,Empty -> Empty + | (Leaf x as lf), t -> if mem x t then lf else Empty + | t, (Leaf x as lf) -> if mem x t then lf else Empty + | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> + if m = n && match_prefix q p m (* same prefix, just recurse *) + then merge (inter s0 t0) (inter s1 t1) + + else if m > n && match_prefix q p m then (* q contains p *) + if zero_bit q m + then inter s0 t + else inter s1 t + + else if m < n && match_prefix p q n then (* p contains q *) + if zero_bit p n + then inter s t0 + else inter s t1 + + else (* different prefixes *) + Empty + + let gen1 (agen : (?size:int -> Random.State.t -> int)) ?(size=50) rs = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (add (agen ~size:size rs) t) + in + loop num empty + + let gen ?size rs = gen1 Types.Int.gen ?size rs + + type path = + | Top + | PathL of path * t + | PathR of t * path + + type cursor = path * t + type 'a cursor_ = cursor + + let to_cursor t = Top,t + + let at_top = function + | Top,_ -> true + | _ -> false + + let at_right = function + | _, Empty + | _,Leaf _ -> true + | _ -> false + + let at_left = at_right + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let move_up = function + | Top, _ -> failwith "move_up" + | PathL(p,r),l + | PathR(l,p),r -> p, (merge l r) + + let move_down_right (p,t) = match t with + | Empty | Leaf _ -> failwith "move_down_right" + | Branch(_,_,_,r) -> PathR(t,p),r + + let move_down_left (p,t) = match t with + | Empty | Leaf _ -> failwith "move_down_left" + | Branch(_,_,l,_) -> PathL(p,t),l + + let has_value = function _,Leaf _ -> true | _ -> false + + let get_value = function + | _,Leaf v -> v + | _,_ -> failwith "get_value" + + let rec from_cursor curs = + if at_top curs then snd curs + else from_cursor (move_up curs) + +end + +module GenSet = MonoSet diff --git a/src/set/patriciaSet.mli b/src/set/patriciaSet.mli new file mode 100644 index 0000000..4644a80 --- /dev/null +++ b/src/set/patriciaSet.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Efficient sets of integers + + Patricia trees are balanced binary search trees whose elements are + integers. These trees can be very efficient since navigating the + each tree uses only specific bits of the elements value. They + have O(w) worst case running time for the [mem], [add], [remove] + where w is the number of bits in an integer, but typically run in + O(log n) time for most inputs. Because, Patricia trees never need + to be re-balanced, [union], [inter], and [diff] can be much faster + than ordinary balanced trees, but still may take O(n+m) in the + worst case. +*) + +(** This module implements sets with integer keys *) +module MonoSet : Sets.MonoSetSig with type elt = int + and type 'a result = 'a + + +(** Same as the {!PatriciaSet.MonoSet} module, except it also provides + the [gen] function. +*) +module GenSet : Sets.GenSetSig with type elt = int + and type 'a result = 'a + diff --git a/src/set/rBSet.ml b/src/set/rBSet.ml new file mode 100644 index 0000000..00c8b33 --- /dev/null +++ b/src/set/rBSet.ml @@ -0,0 +1,604 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +module BaseSet = struct + (* Red/Black Trees follow: + 1) all nodes are Red or Black + 2) The root is black + 3) Empty Trees (i.e. leafs) are black + 4) Both children of a red node are black + 5) Every path from a leaf to the root has the same "black height" + *) + + (* save a cell by encoding the color in the constructor *) + type 'a tree = + | Empty + | RNode of 'a tree * 'a * 'a tree + | BNode of 'a tree * 'a * 'a tree + + let of_result x = x + + let empty = Empty + let is_empty = function Empty -> true | _ -> false + let singleton x = BNode(Empty,x,Empty) + + let is_black = function + | Empty -> true + | BNode _ -> true + | RNode _ -> false + + let rec black_height t = + let rec bh acc = function + | Empty -> 1+acc + | RNode(l,_,r) -> bh acc l + | BNode(l,_,r) -> bh (acc+1) l + in bh 0 t + + (* true if the top of sub is lt x *) + let sub_lt cmp x sub = match sub with + | RNode(_,y,_) + | BNode(_,y,_) -> cmp y x < 0 + | _ -> assert false + + let sub_gt cmp x sub = match sub with + | RNode(_,y,_) + | BNode(_,y,_) -> cmp y x > 0 + | _ -> assert false + + let rec well_ordered cmp = function + | Empty -> true + | RNode(Empty,e,Empty) | BNode(Empty,e,Empty) -> true + + | BNode(Empty,e,r) + | RNode(Empty,e,r) -> sub_gt cmp e r && well_ordered cmp r + | BNode(l,e,Empty) + | RNode(l,e,Empty) -> sub_lt cmp e l && well_ordered cmp l + + | RNode(l,e,r) | BNode(l,e,r) -> + sub_lt cmp e l && sub_gt cmp e r && + well_ordered cmp l && well_ordered cmp r + + let rec check_red_children = function + | Empty -> true + | BNode(l,_,r) -> check_red_children l && check_red_children r + | RNode(l,_,r) -> is_black l && is_black r && + check_red_children l && check_red_children r + + let rec check_black_height = function + | Empty -> true + | RNode(l,_,r) | BNode(l,_,r) -> + if ((black_height l) = (black_height r)) + then (check_black_height l) && (check_black_height r) + else failwith "black height is off" + + let well_formed_not1 cmp t = + well_ordered cmp t && + check_red_children t && (* prop 4 *) + check_black_height t (* prop 5 *) + + let well_formed cmp t = + well_ordered cmp t && + is_black t && (* prop 2 *) + check_red_children t && (* prop 4 *) + check_black_height t (* prop 5 *) + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | RNode(Empty,v,Empty) | BNode(Empty,v,Empty) -> to_s v + | RNode(l,v,Empty) | BNode(l,v,Empty) -> + Printf.sprintf "%s, %s" (h l) (to_s v) + | RNode(Empty,v,r) | BNode(Empty,v,r) -> + Printf.sprintf "%s, %s" (to_s v) (h r) + | RNode(l,v,r) | BNode(l,v,r) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s v) (h r) + in "{" ^ (h t) ^ "}" + + let rec min_elt t = match t with + | Empty -> raise Not_found + | RNode(Empty,elt,_) | BNode(Empty,elt,_) -> elt + | RNode(l,_,_) | BNode(l,_,_) -> min_elt l + + let rec max_elt t = match t with + | Empty -> raise Not_found + | RNode(_,elt,Empty) | BNode(_,elt,Empty) -> elt + | RNode(_,_,r) | BNode(_,_,r) -> max_elt r + + let rec mem cmp x t = match t with + | Empty -> false + | RNode(l,elt,r) | BNode(l,elt,r) -> match cmp x elt with + | 0 -> true + | c when c < 0 -> mem cmp x l + | _ -> mem cmp x r + + (* Okasaki's rebalancing constructor *) + let bal_l l elt r = match l with + | RNode(RNode(t1,a1,t2),a2,t3) + | RNode(t1,a1,RNode(t2,a2,t3)) -> + RNode(BNode(t1,a1,t2),a2,BNode(t3,elt,r)) + | _ -> BNode(l,elt,r) + + let bal_r l elt r = match r with + | RNode(RNode(t2,a2,t3),a3,t4) + | RNode(t2,a2,RNode(t3,a3,t4)) -> + RNode(BNode(l,elt,t2),a2,BNode(t3,a3,t4)) + | _ -> BNode(l,elt,r) + + let rec ins cmp x t = match t with + | Empty -> RNode(Empty,x,Empty) + | RNode(l,elt,r) -> begin match cmp x elt with + | 0 -> t + (* impossible to violate black height property with a + red node here, so no need to rebalance *) + | c when c < 0 -> RNode(ins cmp x l,elt,r) + | _ -> RNode(l,elt,ins cmp x r) + end + | BNode(l,elt,r) -> begin match cmp x elt with + | 0 -> t + | c when c < 0 -> bal_l (ins cmp x l) elt r + | _ -> bal_r l elt (ins cmp x r) + end + + let blackify = function + | RNode(l,elt,r) -> BNode(l,elt,r) + | t -> t + + let add cmp x t = blackify (ins cmp x t) + + let redify = function + | BNode(l,e,r) -> RNode(l,e,r) + | _ -> assert false + + let balance l v r = match l,v,r with + (* TODO: investigate this first constructor proposed by Kahrs. + Is it better to move Red nodes up?*) + | RNode(a,x,b),y,RNode(c,z,d) + | RNode(RNode(a,x,b),y,c),z,d + | RNode(a,x,RNode(b,y,c)),z,d + | a,x,RNode(b,y,RNode(c,z,d)) + | a,x,RNode(RNode(b,y,c),z,d) -> RNode(BNode(a,x,b),y,BNode(c,z,d)) + + | a,x,b -> BNode(a,x,b) + + let balleft l elt r = match l with + | RNode(ll,lv,lr) -> RNode(BNode(ll,lv,lr),elt,r) + | _ -> match r with + | BNode(rl,rv,rr) -> balance l elt (RNode(rl,rv,rr)) + | RNode(BNode(a,y,b),z,c) -> + RNode(BNode(l,elt,a), y, (balance b z (redify c))) + | _ -> assert false + + let balright l elt r = match r with + | RNode(b,y,c) -> RNode(l,elt,BNode(b,y,c)) + | _ -> match l with + | BNode(a,x,b) -> balance (RNode(a,x,b)) elt r + | RNode(a,x,BNode(b,y,c)) -> + RNode(balance (redify a) x b, y, (BNode(c,elt,l))) + | _ -> assert false + + let rec app l r = match l,r with + | Empty,_ -> r + | _,Empty -> l + | RNode(a,x,b), RNode(c,y,d) -> begin match app b c with + | RNode(b',z,c') -> RNode(RNode(a,x,b'),z,RNode(c',y,d)) + | bc -> RNode(a,x,RNode(bc,y,d)) + end + | BNode(a,x,b), BNode(c,y,d) -> begin match app b c with + | RNode(b',z,c') -> RNode(BNode(a,x,b'),z,BNode(c',y,d)) + | bc -> balleft a x (BNode(bc, y, d)) + end + | a, RNode(b,x,c) -> RNode(app a b, x, c) + | RNode(a,x,b), c -> RNode(a,x,app b c) + + (* based on Stefan Kahrs work on RB trees *) + let rec del cmp x t = match t with + | Empty -> Empty + | BNode(l,elt,r) | RNode(l,elt,r) -> match cmp x elt with + | 0 -> app l r + | c when c < 0 -> del_left cmp x l elt r + | _ -> del_right cmp x l elt r + and del_left cmp x l elt r = match l with + | BNode _ -> balleft (del cmp x l) elt r + | _ -> RNode(del cmp x l, elt, r) + and del_right cmp x l elt r = match r with + | BNode _ -> balright l elt (del cmp x r) + | _ -> RNode(l,elt,del cmp x r) + + let remove cmp x t = blackify (del cmp x t) + + (* join trees of arbitrary size *) + (* This is still really inefficient since it keeps calling + black_height which O(log n) raising this to O(n log n). Should + only call these once in union/diff/inter and then keep track of + local differences. *) + let rec concat3h cmp l v r hl hr = + match hl - hr with + | 0 -> begin match l,r with + | BNode _, BNode _ -> RNode(l,v,r) + | _ -> BNode(l,v,r) + end + + | -1 -> (* r has at exactly 1 extra black node *) + begin match l,r with + | _, Empty -> assert false (* r must have at least 2 black nodes *) + + | RNode(ll,lv,lr),_ -> + (* if l is red, just color it black to match r *) + BNode(BNode(ll,lv,lr),v,r) + + | _,RNode(rl,rv,rr) -> + (* rl and rr must be black by (4) *) + (* recurse to force l=blk rl=blk *) + balance (concat3h cmp l v rl hl hr) rv rr + + | _,BNode(rl,rv,rr) -> + begin match rl,rr with + | (BNode _|Empty), (BNode _|Empty) -> + (*both black, so color their parent red to drop BH, + then use bnode as parent to restore height *) + BNode(l,v,RNode(rl,rv,rr)) + + | RNode _, RNode _ -> + (* push black down to rr and connect rl with l *) + RNode(BNode(l,v,rl),rv, blackify(rr)) + + | (BNode _|Empty), RNode _ -> + (* RNode(l,v,rl) will have same height as rr *) + BNode(RNode(l,v,rl),rv,rr) + + | RNode(rll,rlv,rlr), (BNode _|Empty) -> + (* rll and rlr are black, and all of l,rll,rlr,rr have same BH *) + RNode(BNode(l,v,rll), rlv, BNode(rlr,rv,rr)); + end + end + | 1 -> (* l has at exactly 1 extra black node *) + begin match l,r with + | Empty,_ -> assert false (* l must have at least 2 black nodes *) + + | _,RNode(rl,rv,rr) -> + (* if r is red, just color it black to match l *) + BNode(l,v,BNode(rl,rv,rr)) + + | RNode(ll,lv,lr),_ -> + (* ll and lr must be black by (4) *) + (* recurse to force l=blk rl=blk *) + balance ll lv (concat3h cmp lr v r hl hr) + + | BNode(ll,lv,lr),_ -> + begin match ll,lr with + | (BNode _|Empty), (BNode _|Empty) -> + (*both black, so color their parent red to drop BH, + then use bnode as parent to restore height *) + BNode(RNode(ll,lv,lr),v,r) + + | RNode _, RNode _ -> + (* push black down to ll and connect lr with r *) + RNode(blackify(ll),lv,BNode(lr,v,r)) + + | (BNode _|Empty), RNode(lrl,lrv,lrr) -> + (* lrl and lrr are black, and all of l,rll,rlr,rr have same BH *) + RNode(BNode(ll,lv,lrl), lrv, BNode(lrr,v,r)) + + | RNode _, (BNode _|Empty) -> + (* RNode(lr,v,r) will have same height as ll *) + BNode(ll,lv,RNode(lr,v,r)) + end + end + | c when c < -1 -> (* r has at least 2 more black nodes *) + begin match r with + | Empty -> assert false + | RNode(rl,rv,rr) -> + let t1 = concat3h cmp l v rl hl hr in + let hl = black_height t1 in + let t2 = concat3h cmp t1 rv rr hl hr in + t2 + | BNode(rl,rv,rr) -> + let t1 = concat3h cmp l v rl hl (hr-1) in + let hl = black_height t1 in + let t2 = concat3h cmp t1 rv rr hl (hr-1)in + + t2 + end + | _ -> match l with (* l has at least 2 more black nodes *) + | Empty -> assert false + | RNode(ll,lv,lr) -> + let t1 = concat3h cmp lr v r hl hr in + let hr = black_height t1 in + let t' = concat3h cmp ll lv t1 hl hr in + t' + | BNode(ll,lv,lr) -> + let t1 = concat3h cmp lr v r (hl-1) hr in + let hr = black_height t1 in + let t' = concat3h cmp ll lv t1 (hl-1) hr in + t' + + and concat3 cmp l v r = + let hl = black_height l in + let hr = black_height r in + concat3h cmp l v r hl hr + + let rec split cmp v t = match t with + | Empty -> Empty, Empty + | BNode(l1,elt,r1) + | RNode(l1,elt,r1) -> + match cmp v elt with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp v l1 in + let t' = concat3 cmp r2 elt r1 in + (*assert(well_formed_not1 cmp t');*) + (l2,t') + | _ -> + let l2,r2 = split cmp v r1 in + let t' = concat3 cmp l1 elt l2 in + (*assert(well_formed_not1 cmp t');*) + (t'), r2 + + let union cmp t1 t2 = + let rec u t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | t1, (BNode(l,v,r) | RNode(l,v,r)) -> + let l',r' = split cmp v t1 in + let t' = concat3 cmp (u l' l) v (u r' r) in + (*assert(well_formed_not1 cmp t');*) + t' + in blackify (u t1 t2) + + (* Inefficient, easy version for now *) + let get_and_remove_min cmp t = + let m = min_elt t in + m, (remove cmp m t) + + (* Inefficient, easy version for now *) + let concat cmp t1 t2 = + if is_empty t2 + then t1 + else + let rm,t2 = get_and_remove_min cmp t2 in + concat3 cmp t1 rm t2 + + let rec diff cmp t1 t2 = + let rec helper t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, (BNode(l,v,r)|RNode(l,v,r)) -> + let l',r' = split cmp v t1 in + concat cmp (helper l' l) (helper r' r) + in + blackify (helper t1 t2) + + let rec inter cmp t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, (BNode(l,v,r)|RNode(l,v,r)) -> + let l',r' = split cmp v t1 in + let t = + if mem cmp v t1 + then concat3 cmp (inter cmp l' l) v (inter cmp r' r) + else concat cmp (inter cmp l' l) (inter cmp r' r) + in blackify t + + let rec cardinal = function + | Empty -> 0 + | BNode(l,_,r) | RNode(l,_,r) -> 1 + (cardinal l) + (cardinal r) + + let choose = function + | Empty -> raise Not_found + | BNode(_,v,_) | RNode(_,v,_) -> v + + let rec iter f = function + | Empty -> () + | RNode(l,v,r) | BNode(l,v,r) -> + iter f l; f v; iter f r + + let rec fold f acc t = match t with + | Empty -> acc + | RNode(l,v,r) | BNode(l,v,r) -> + fold f (f (fold f acc l) v) r + + type 'a digit = + | One of 'a * 'a tree + | Two of 'a * 'a tree * 'a * 'a tree + + let rec incr a1 t1 ds = match ds with + | [] -> [One(a1,t1)] + | One(a2,t2)::tl -> Two(a1,t1,a2,t2) :: tl + | Two(a2,t2,a3,t3)::tl -> + One(a1,t1) :: (incr a2 (BNode(t2,a3,t3)) tl) + + let link l = function + | One(a,t) -> BNode(l,a,t) + | Two(a1,t1,a2,t2) -> BNode(RNode(l,a1,t1),a2,t2) + + let linkall lst = + List.fold_right (fun dig t -> link t dig) lst Empty + +(* let add a lst = incr a Empty lst + + let bottom_up lst = + linkall (List.fold_right add lst [])*) + + type 'a path = + | Top + | PathL of 'a path * 'a * 'a tree * bool (* is_black *) + | PathR of 'a tree * 'a * 'a path * bool (* is_black *) + + type 'a curs = 'a path * 'a tree + + let to_cursor c = Top, c + + let has_value = function + | _,Empty -> false + | _ -> true + + let get_value = function + | _,Empty -> failwith "get_value" + | _,RNode(_,v,_) + | _,BNode(_,v,_) -> v + + let at_top = function (Top,_) -> true | _ -> false + + let at_left (_,t) = match t with + | Empty -> true + | _ -> false + + let at_right (_,t) = match t with + | Empty -> true + | _ -> false + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let try_color blk t = + if blk then blackify t + else match t with + (* try to color t red *) + | Empty -> t (* can't *) + | RNode _ -> t (* already *) + | BNode(l', v', r') -> + if is_black l' && is_black r' + then RNode(l',v',r') (* can change to red and still satisfy (4) *) + else t (* have to leave it black *) + + + let move_up cmp = function + | Top, _ -> failwith "move_up" + | PathL(p,x,r,blk),l + | PathR(l,x,p,blk),r -> + let t = concat3 cmp l x r in + (* We try and keep the same color as the original tree if + possible so that we don't do any unnecessary rotations + when rebuilding the tree. Besides being more efficient, + this is also required to make traversals work properly + (otherwise the tree might rotate in the middle of the + traversal, giving incorrect results *) + let t = try_color blk t in + p, t + + let move_down_left = function + | _,Empty -> failwith "move_down_left" + | p, RNode(l,v,r) -> PathL(p,v,r,false),l + | p, BNode(l,v,r) -> PathL(p,v,r,true),l + + let move_down_right = function + | _,Empty -> failwith "move_down_right" + | p,RNode(l,v,r) -> PathR(l,v,p,false),r + | p,BNode(l,v,r) -> PathR(l,v,p,true),r + + let rec from_cursor cmp curs = + if at_top curs then blackify (snd curs) + else from_cursor cmp (move_up cmp curs) + + (** Step the cursor one position "in-order". Does not keep any + state *) + let rec step_io = function + | Top, Empty -> raise Exit + | PathL(p,x,r,_),Empty -> x,(p,r) + | p, RNode(l,x,r) -> step_io (PathL(p,x,r,false),l) + | p, BNode(l,x,r) -> step_io (PathL(p,x,r,true),l) + | PathR _, Empty -> assert false + + let can_step = function Top, Empty -> false | _ -> true + + let cmp kcmp t1 t2 = + let rec helper c1 c2 = + match (can_step c1), (can_step c2) with + | false, false -> 0 + | true, false -> -1 + | false, true -> 1 + | true, true -> + let x1,c1 = step_io c1 in + let x2,c2 = step_io c2 in + match kcmp x1 x2 with + | 0 -> helper c1 c2 + | c -> c + in + helper (to_cursor t1) (to_cursor t2) + + let gen_ cmp (agen:?size:int -> Random.State.t -> 'a) ?(size=50) rs = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (add cmp (agen ~size:size rs) t) + in + loop num empty + +end +module PolySet (*: Tree.PolyTreeSet*) = struct + include BaseSet + + type 'a t = 'a tree + type 'a set = 'a t + type 'a elt_ = 'a + + type ('a,'b) result = 'a + type ('a,'b) result_ = 'a + + let add x t = add Pervasives.compare x t + let mem x t = mem Pervasives.compare x t + let remove x t = remove Pervasives.compare x t + let union t1 t2 = union Pervasives.compare t1 t2 + let diff t1 t2 = diff Pervasives.compare t1 t2 + let inter t1 t2 = inter Pervasives.compare t1 t2 + let compare x y = cmp Pervasives.compare x y + let equal x y = compare x y = 0 + + let well_formed t = well_formed Pervasives.compare t + + type 'a cursor = 'a curs + type 'a cursor_ = 'a cursor + let move_up c = move_up Pervasives.compare c + let from_cursor c = from_cursor Pervasives.compare c + + let gen1 (agen:?size:int -> Random.State.t -> 'a) ?size rs = + gen_ Pervasives.compare agen ?size rs +end + +module MonoSet (C : Types.Mono.Comparable) = +struct + include BaseSet + + type elt = C.t + type 'a elt_ = elt + + type t = C.t tree + type 'a set = t + + type 'a result = 'a + type ('a,'b) result_ = 'a + + let add x t = add C.compare x t + let mem x t = mem C.compare x t + let remove x t = remove C.compare x t + let union t1 t2 = union C.compare t1 t2 + let diff t1 t2 = diff C.compare t1 t2 + let inter t1 t2 = inter C.compare t1 t2 + let compare x y = cmp C.compare x y + let equal x y = compare x y = 0 + + let well_formed t = well_formed C.compare t + let to_string t = to_string C.to_string t + + type cursor = C.t curs + type 'a cursor_ = cursor + + let move_up c = move_up C.compare c + let from_cursor c = from_cursor C.compare c + + let gen1 (agen:?size:int -> Random.State.t -> 'a) ?size rs = + gen_ C.compare agen ?size rs + +end + +module GenSet (C : Types.Mono.ArbitraryComparable) = struct + include MonoSet(C) + + let gen ?size rs = gen1 C.gen ?size rs + +end diff --git a/src/set/rBSet.mli b/src/set/rBSet.mli new file mode 100644 index 0000000..17b0c54 --- /dev/null +++ b/src/set/rBSet.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Balanaced binary search tree with small memory footprint + + Redblack trees are balanced binary search trees that provide O(log + n) [mem], [add], and [remove] tree operations and O(n) [union], + [inter], and [diff] set operations. They can also be more memory + efficient than AVL trees since they only need to store 1 bit of + information to maintain their internal invariants. In the current + implementation, this bit is encoded in the type constructor, + meaning that each internal node of the tree uses one less word of + memory than AVL trees. +*) + +(** This module provides an implementation of RedBlack trees with a + polymorphic element type. The implementation uses the standard + library's polymorphic [compare] function internally and may not be + as efficient as the {!RBSet.MonoSet} module which allows the use + of a more efficient comparison function. +*) +module PolySet : Sets.PolySetSigStd + +(** This functor provides an implementation of RedBlack trees that are + parameterized by a specific monomorphic element type. +*) +module MonoSet : Sets.MonoSetSigFnStd + +(** This functor is similar to the {!RBSet.MonoSet} functor except it + is parameterized by a module that also supports the [gen] + operation. Therefore, the resulting module is also able to + generate number sets. +*) +module GenSet : Sets.GenSetSigFnStd diff --git a/src/set/sets.ml b/src/set/sets.ml new file mode 100644 index 0000000..a729954 --- /dev/null +++ b/src/set/sets.ml @@ -0,0 +1,124 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module type Set_ = sig + type 'a elt_ + type 'a set + type ('a,'b) result_ + + val empty : 'a set + val is_empty : 'a set -> bool + val mem : 'a elt_ -> 'a set -> (bool,'a) result_ + val add : 'a elt_ -> 'a set -> 'a set + val singleton : 'a elt_ -> 'a set + val remove : 'a elt_ -> 'a set -> 'a set + val min_elt : 'a set -> ('a elt_, 'a) result_ + val max_elt : 'a set -> ('a elt_, 'a) result_ + val choose : 'a set -> ('a elt_, 'a) result_ + val cardinal : 'a set -> int + + val compare : 'a set -> 'a set -> int + val equal : 'a set -> 'a set -> bool + val iter : ('a elt_ -> unit) -> 'a set -> unit + val fold : ('b -> 'a elt_ -> 'b) -> 'b -> 'a set -> 'b + val union : 'a set -> 'a set -> 'a set + val inter : 'a set -> 'a set -> 'a set + val diff : 'a set -> 'a set -> 'a set + + val gen1 : (?size:int -> Random.State.t -> 'a elt_) -> + ?size:int -> Random.State.t -> 'a set + + val well_formed : 'a set -> bool + val of_result : ('a,'b) result_ -> 'a + + type 'a cursor_ + val to_cursor : 'a set -> 'a cursor_ + val from_cursor : 'a cursor_ -> 'a set + val at_top : 'a cursor_ -> bool + val at_left : 'a cursor_ -> bool + val at_right : 'a cursor_ -> bool + val move_up : 'a cursor_ -> 'a cursor_ + val move_down_left : 'a cursor_ -> 'a cursor_ + val move_down_right : 'a cursor_ -> 'a cursor_ + + val went_left : 'a cursor_ -> bool + val went_right : 'a cursor_ -> bool + + val has_value : 'a cursor_ -> bool + val get_value : 'a cursor_ -> 'a elt_ + +(* + val for_all : ('a elt_ -> bool) -> 'a set -> bool + val exists : ('a elt_ -> bool) -> 'a set -> bool + val elements : 'a set -> 'a elt_ list + val subset : 'a set -> 'a set -> bool + val filter : ('a elt_ -> bool) -> 'a set -> 'a set + val partition : ('a elt_ -> bool) -> 'a set -> 'a set * 'a set + val split : 'a elt_ -> 'a set -> 'a set * bool * 'a set + val add_at : 'a elt_ -> cursor -> cursor + val mem_at : 'a elt_ -> cursor -> bool + val remove_at : 'a elt_ -> cursor -> cursor +*) + +end + +module type MonoSetSig = sig + type t + type elt + type cursor + type 'a result + + include Set_ + with type 'a elt_ = elt + and type 'a set = t + and type 'a cursor_ = cursor + and type ('a,'b) result_ = 'a result + + val to_string : 'a set -> string + +end + +module type MonoSetSigFn = + functor(C : Types.Mono.Comparable) -> + MonoSetSig with type elt = C.t + +module type MonoSetSigFnStd = + functor(C : Types.Mono.Comparable) -> + MonoSetSig with type elt = C.t and type 'a result = 'a + +module type GenSetSig = sig + include MonoSetSig + val gen : ?size:int -> Random.State.t -> t +end + +module type GenSetSigFn = + functor(C : Types.Mono.ArbitraryComparable) -> + GenSetSig with type elt = C.t + +module type GenSetSigFnStd = + functor(C : Types.Mono.ArbitraryComparable) -> + GenSetSig with type elt = C.t and type 'a result = 'a + +module type PolySetSig = sig + type 'a t + type 'a cursor + type ('a,'b) result + + include Set_ + with type 'a elt_ = 'a + and type 'a set = 'a t + and type 'a cursor_ = 'a cursor + and type ('a,'b) result_ = ('a,'b) result + + val to_string : ('a -> string) -> 'a set -> string +end + +module type PolySetSigStd = PolySetSig with type ('a,'b) result = 'a diff --git a/src/set/sets.mli b/src/set/sets.mli new file mode 100644 index 0000000..66be6f4 --- /dev/null +++ b/src/set/sets.mli @@ -0,0 +1,246 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Signatures for set ADTs. *) + +(** This module represents the core functionality of Sets. It defines + a few extra types to abstract over exact implement details of its + operations. Also, it defines the elements and the set type to be + polymorphic, although this can later be refined to a monomorphic + type (as is done bye {!Sets.MonoSetSig}. +*) +module type Set_ = +sig + type 'a elt_ + (** The type of elements in the set *) + + type 'a set + (** The type of sets *) + + type ('a,'b) result_ + (** The [result_] type is used for operations that may either + return just a result or a result a something else. Most trees + conform to the former, while splay trees use the latter + (e.g. the mem function may modify the tree) *) + + val empty : 'a set + (** The empty set *) + + val is_empty : 'a set -> bool + (** Returns true if the set is empty *) + + val mem : 'a elt_ -> 'a set -> (bool,'a) result_ + (** [mem x t] Returns true if [x] is contained in the set [t]. + More precisely, there exists an element [y] in [t] such that + [compare x y = 0]. *) + + val add : 'a elt_ -> 'a set -> 'a set + (** [add x t] Return the set [t] with the element [x]. + *) + + val singleton : 'a elt_ -> 'a set + (** [singleton x] Return the set consisting of only the element + [x] *) + + val remove : 'a elt_ -> 'a set -> 'a set + (** [remove x t] Return the set [t] with the element [x] removed. + Does {b not} raise an exception if [t] does not contain [x]. *) + + val min_elt : 'a set -> ('a elt_,'a) result_ + (** Return the smallest element in the set. If the set is empty, + raises [Not_found] *) + + val max_elt : 'a set -> ('a elt_,'a) result_ + (** Return the largest element in the set. If the set is empty, + raises [Not_found] *) + + val choose : 'a set -> ('a elt_,'a) result_ + (** Choose an arbitrary element from the set. It is + implementation dependent whether or not the same element is + chosen for equal sets. If the set is empty, it raises + [Not_found]. *) + + val cardinal : 'a set -> int + (** Returns the number of elements in the set. *) + + val compare : 'a set -> 'a set -> int + (** [compare t1 t2] Compares the sets [t1] and [t2] and returns + [0] if they are equal. Returns [<0] if [t1] is less than [t2] + and [>0] otherwise. + *) + + val equal : 'a set -> 'a set -> bool + (** [equal t1 t2] Returns true if [t1] and [t2] contain the same + elements. *) + + val iter : ('a elt_ -> unit) -> 'a set -> unit + (** [iter f t] Apply [f] to each element in list [t]. The + elements are always visited in increasing order. *) + + val fold : ('b -> 'a elt_ -> 'b) -> 'b -> 'a set -> 'b + (** [fold f acc t] Accumulates the result [acc] by applying [f acc + x] for each element [x] in [t]. The elements are always + visited in increasing order. Note that this is a slightly + different signature than the fold from the standard library, + however, it is the same signature as the lists modules use. *) + + val union : 'a set -> 'a set -> 'a set + (** [union t1 t2] Returns a set containing all of the elements in + [t1] and [t2] *) + + val inter : 'a set -> 'a set -> 'a set + (** [inter t1 t2] Returns a set containing only the elements + contained in both [t1] and [t2] *) + + val diff : 'a set -> 'a set -> 'a set + (** [diff t1 t2] Returns a set containing only the elements + contained in [t1] and not [t2] *) + + val gen1 : + (?size:int -> Random.State.t -> 'a elt_) -> + ?size:int -> Random.State.t -> 'a set + (** [gen1 f ?size rs] Generates a random set whose size is bounded + by [size]. Each element in the set is computed by calling [f + ?size rs]. *) + + val well_formed : 'a set -> bool + (** A predicate to test if the set is well-formed. All sets + exposed by this API should always be well-formed. This is + only useful for debugging an implementation. *) + + val of_result : ('a,'b) result_ -> 'a + (** Returns the result part of a [result_] value. This is only + useful when treating a collection of sets abstractly, as most + clients should deconstruct the values of type [result_] for + maximal efficiency *) + + (** The cursor interface to sets *) + + type 'a cursor_ + (** The type of Set cursors. A cursor can be thought of a + pointer to a node in the middle of a tree. Cursors support + navigating the tree in arbitrary ways. Depending on the + implementation, not every node in the tree may have a value + associated with it. *) + + val to_cursor : 'a set -> 'a cursor_ + (** Create a cursor from a tree. The cursor initially points to + the top of the tree. *) + + val from_cursor : 'a cursor_ -> 'a set + (** Return the tree pointed to by the cursor. This operation may + require re-balancing the tree depending on the implementation. + *) + + val at_top : 'a cursor_ -> bool + (** Returns true if the cursor is at the top of the tree. The + {!Sets.Set_.move_up} operation only succeeds when this + returns [false]. *) + + val at_left : 'a cursor_ -> bool + (** Returns true if the cursor is at the left most element in the + current subtree. The {!Sets.Set_.move_down_left} + operation only succeeds when this returns [false]. *) + + val at_right : 'a cursor_ -> bool + (** Returns true if the cursor is at the right most element in the + current subtree. The {!Sets.Set_.move_down_right} + operation only succeeds when this returns [false]. *) + + val move_up : 'a cursor_ -> 'a cursor_ + (** Move the cursor up the tree from a sibling to a parent. If + the cursor is already at the top of the tree (as determined by + {!Sets.Set_.at_top}), it raises [Failure "move_up"]. *) + + val move_down_left : 'a cursor_ -> 'a cursor_ + (** Move the cursor down the tree to the left child. If the + cursor is already at the bottom left of the tree (as + determined by {!Sets.Set_.at_left}), it raises [Failure + "move_down_left"]. *) + + val move_down_right : 'a cursor_ -> 'a cursor_ + (** Move the cursor down the tree to the right child. If the + cursor is already at the bottom right of the tree (as + determined by {!Sets.Set_.at_right}), it raises [Failure + "move_down_right"]. *) + + val went_left : 'a cursor_ -> bool + (** Returns true if the cursor points to an element that is the + left sibling of its parent. *) + + val went_right : 'a cursor_ -> bool + (** Returns true if the cursor points to an element that is the + right sibling of its parent. *) + + val has_value : 'a cursor_ -> bool + (** Returns true if the cursor points to a node that contains a + value. *) + + val get_value : 'a cursor_ -> 'a elt_ + (** Extracts the value from the current node. If the node does + not contain a value (as determined by + {!Sets.Set_.has_value}, then it raises [Failure + "get_value"]. *) + +end + +(** A {!Sets.Set_} whose elements are monomorphic (possibly + using a custom comparison function *) +module type MonoSetSig = sig + type t + type elt + type cursor + type 'a result + + include Set_ with type 'a elt_ = elt + and type 'a set = t + and type 'a cursor_ = cursor + and type ('a,'b) result_ = 'a result + + val to_string : 'a set -> string +end + +module type MonoSetSigFn = + functor(C : Types.Mono.Comparable) -> + MonoSetSig with type elt = C.t + +module type MonoSetSigFnStd = + functor(C : Types.Mono.Comparable) -> + MonoSetSig with type elt = C.t and type 'a result = 'a + +(** The same as {!Sets.MonoSetSig} except includes a [gen] function *) +module type GenSetSig = sig + include MonoSetSig + val gen : ?size:int -> Random.State.t -> t + end + +module type GenSetSigFn = + functor(C : Types.Mono.ArbitraryComparable) -> + GenSetSig with type elt = C.t + +module type GenSetSigFnStd = + functor(C : Types.Mono.ArbitraryComparable) -> + GenSetSig with type elt = C.t and type 'a result = 'a + +(** A {!Sets.Set_} whose elements are polymorphic. *) +module type PolySetSig = sig + type 'a t + type 'a cursor + type ('a,'b) result + + include Set_ with type 'a elt_ = 'a + and type 'a set = 'a t + and type 'a cursor_ = 'a cursor + and type ('a,'b) result_ = ('a,'b) result + + val to_string : ('a -> string) -> 'a set -> string + +end + +module type PolySetSigStd = PolySetSig with type ('a,'b) result = 'a diff --git a/src/set/splaySet.ml b/src/set/splaySet.ml new file mode 100644 index 0000000..332caff --- /dev/null +++ b/src/set/splaySet.ml @@ -0,0 +1,388 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Types + +module BaseSet = struct + + type 'elt tree = + | Empty + | Node of 'elt tree * 'elt * 'elt tree + + type 'a path = + | Top + | PathL of 'a path * 'a tree + | PathR of 'a path * 'a tree + + type 'a curs = 'a path * 'a tree + + let of_result (x,_) = x + + let empty = Empty + let is_empty = function Empty -> true | _ -> false + + let singleton x = Node(Empty,x,Empty) + + let node l e r = Node(l,e,r) + + let to_cursor t = (Top,t) + + let rec from_cursor (p,t) = match p with + | Top -> t + | PathL(p',Node(_,v,r)) -> from_cursor (p', Node(t,v,r)) + | PathR(p',Node(l,v,_)) -> from_cursor (p', Node(l,v,t)) + | _ -> assert false + + let at_top (p,t) = (p = Top) + let has_left (p,t) = match t with + | Node(Empty,_,_) -> false + | Node _ -> true + | _ -> false + + let has_right (p,t) = match t with + | Node(_,_,Empty) -> false + | Node _ -> true + | _ -> false + + let went_left = function PathL _,_ -> true | _ -> false + let went_right = function PathR _,_ -> true | _ -> false + + let move_up (p,t) = match p with + | Top -> failwith "move_up" + | PathL(p',Node(_,v,r)) -> p', Node(t,v,r) + | PathR(p',Node(l,v,_)) -> p', Node(l,v,t) + | _ -> assert false (* parent can't be emptytree *) + + let move_down_left (p,t) = match t with + | Empty -> failwith "move_down_left" + | Node(l,v,r) -> PathL(p,t),l + + let move_down_right (p,t) = match t with + | Empty -> failwith "move_down_right" + | Node(l,v,r) -> PathR(p,t),r + + let rec move_to_ancestor cmp x ((p,t) as curs) = match p with + | Top -> curs + | PathL(p', Node(_,v,_)) -> + if cmp x v < 0 then curs + else move_to_ancestor cmp x (move_up curs) + | PathR(p', Node(_,v,_)) -> + if cmp x v > 0 then curs + else move_to_ancestor cmp x (move_up curs) + | _ -> assert false + + + let rec splay curs = match curs with + | Top,_ -> curs + | _, Empty -> splay (move_up curs) + + (* no grand-parent, so just zig one level *) + | PathL(Top,Node(_,v,r)), Node(ll,lv,lr) -> + Top,Node(ll,lv,Node(lr,v,r)) + + | PathR(Top,Node(l,v,_)),Node(rl,rv,rr) -> + Top,Node(Node(l,v,rl),rv,rr) + + (* has grand-parent *) + (* zig-zig *) + | PathL(PathL(gp_p,Node(_,v,r)),Node(_,lv,lr)), Node(lll,llv,llr) -> + let br = Node(lr,v,r) in + let mr = Node(llr,lv,br) in + splay (gp_p, Node(lll,llv,mr)) + + (* zig-zig *) + | PathR(PathR(gp_p,Node(l,v,_)),Node(ll,lv,_)), Node(rrl,rrv,rrr) -> + let bl = Node(l,v,ll) in + let ml = Node(bl,lv,rrl) in + splay (gp_p,Node(ml,rrv,rrr)) + + (* zig-zag *) + | PathL(PathR(gp_p,Node(l,v,_)),Node(_,rv,rr)), Node(rll,rlv,rlr) -> + let newl = Node(l,v,rll) in + let newr = Node(rlr,rv,rr) in + splay (gp_p,Node(newl, rlv, newr)) + + (* zig-zag *) + | PathR(PathL(gp_p,Node(_,v,r)),Node(ll,lv,_)), Node(lrl,lrv,lrr) -> + let newl = Node(ll,lv,lrl) in + let newr = Node(lrr,v,r) in + splay(gp_p, Node(newl, lrv, newr)) + + (* all of remaining cases are impossible. e.g., the grandparent + tree being Empty *) + | _ -> assert false + + let rec add_at cmp x ((p,t) as curs) = match t with + | Empty -> p,Node(Empty,x,Empty) + | Node(l,v,r) -> match cmp x v with + | 0 -> curs + | c when c < 0 -> add_at cmp x (PathL(p,t),l) + | _ -> add_at cmp x (PathR(p,t),r) + + let add cmp x t = + let curs = add_at cmp x (to_cursor t) in + from_cursor (splay curs) + + let rec closest_to cmp x ((p,t) as curs) = match t with + | Empty -> if at_top curs then curs else move_up curs + | Node(l,v,r) -> match cmp x v with + | 0 -> curs + | c when c < 0 -> closest_to cmp x (PathL(p,t),l) + | _ -> closest_to cmp x (PathR(p,t),r) + + let top_node = function + | Empty -> raise (Invalid_argument "splay:top_node") + | Node(_,v,_) -> v + + let rec goto_min ((p,t) as curs) = match t with + | Empty -> curs + | Node(Empty,_,_) -> curs + | Node(l,_,_) -> goto_min ((PathL(p,t)),l) + + let rec goto_max ((p,t) as curs) = match t with + | Empty -> curs + | Node(_,_,Empty) -> curs + | Node(_,_,r) -> goto_max ((PathR(p,t)),r) + + let rec min_elt t = + if is_empty t then raise Not_found + else + let c = goto_min (to_cursor t) in + let t = from_cursor (splay c) in + top_node t, t + + let max_elt t = + if is_empty t then raise Not_found + else + let c = goto_max (to_cursor t) in + let t = from_cursor (splay c) in + top_node t, t + + let mem cmp x t = + let curs = closest_to cmp x (to_cursor t) in + let t = from_cursor (splay curs) in + match t with + | Empty -> false,t + | Node(_,v,_) -> if cmp x v = 0 + then true,t + else false,t + + (* TODO: fix this to be better than O(n) stack *) + let rec iter f = function + | Empty -> () + | Node(l,v,r) -> iter f l; f v; iter f r + + let rec get_and_remove_min = function + | Empty -> raise (Invalid_argument "remove_min") + | Node(Empty,v,r) -> v,r + | Node(l,v,r) -> + let d,newl = get_and_remove_min l in + d, Node(newl,v,r) + + let remove cmp x t = + let (p,t) = closest_to cmp x (to_cursor t) in + let t = match t with + | Empty -> t + | Node(Empty,v,r) -> if (cmp v x) = 0 then r else t + | Node(l,v,Empty) -> if (cmp v x) = 0 then l else t + | Node(l,v,r) -> + if (cmp v x) = 0 then + let d,newl = get_and_remove_min l in + Node(newl,d,r) + else t + in + from_cursor (splay (p,t)) + + + let rec split cmp v t = match t with + | Empty -> Empty, Empty + | Node(l1,elt,r1) -> + match cmp v elt with + | 0 -> l1,r1 + | c when c < 0 -> + let l2,r2 = split cmp v l1 in + l2,Node(r2,elt,r1) + | _ -> + let l2,r2 = split cmp v r1 in + Node(l1,elt,l2), r2 + + let rec union cmp t1 t2 = match t1,t2 with + | Empty, t | t, Empty -> t + | t1, Node(l,v,r) -> + let l',r' = split cmp v t1 in + Node((union cmp l' l),v,(union cmp r' r)) + + let rec concat t1 t2 = match t1,t2 with + | Empty, _ -> t2 + | _, Empty -> t1 + | Node(l1,v1,r1), Node(l2,v2,r2) -> + let m,t2' = get_and_remove_min t2 in + Node(t1,m,t2') + + let rec diff cmp t1 t2 = match t1,t2 with + | Empty, _ -> Empty + | _, Empty -> t1 + | _, Node(l,v,r) -> + let l',r' = split cmp v t1 in + concat (diff cmp l' l) (diff cmp r' r) + + let rec inter cmp t1 t2 = match t1,t2 with + | Empty,_ | _,Empty -> Empty + | t1, Node(l,v,r) -> + let l',r' = split cmp v t1 in + if fst (mem cmp v t1) + then Node((inter cmp l' l),v,(inter cmp r' r)) + else concat (inter cmp l' l) (inter cmp r' r) + + let at_right = function + | _,Empty -> true + | _,Node _ -> false + + let at_left = at_right + + let has_value = function _,Node _ -> true | _ -> false + let get_value = function + | _,Empty -> failwith "get_value" + | _,Node(_,v,_) -> v + + let rec cardinal = function + | Empty -> 0 + | Node(l,_,r) -> 1 + (cardinal l) + (cardinal r) + + let choose t = match t with + | Empty -> raise Not_found + | Node(l,v,r) -> v, t + + (* TODO: fix this to be better than O(n) stack *) + let rec fold f acc t = match t with + | Empty -> acc + | Node(l,v,r) -> + fold f (f (fold f acc l) v) r + + let rec well_ordered cmp = function + | Empty -> true + | Node(Empty,e,Empty) -> true + | Node(Node(_,le,_) as l,e,Empty) -> + ((cmp le e) < 0) && well_ordered cmp l + | Node(Empty,e,(Node(_,re,_) as r)) -> + ((cmp re e) > 0) && well_ordered cmp r + | Node(Node(_,le,_) as l,e,(Node(_,re,_) as r)) -> + ((cmp le e) < 0) &&((cmp re e) > 0) && + well_ordered cmp l && well_ordered cmp r + + let well_formed t = well_ordered t + + let rec compare_ kcmp t1 t2 = match t1,t2 with + | Empty, Empty -> 0 + | Empty, Node _ -> -1 + | Node _, Empty -> 1 + | _ -> + (* This actually may be one of the most efficient ways to + implement this since we will always be removing near the + top thanks to the splay property. *) + let xk,t1' = get_and_remove_min t1 in + let yk,t2' = get_and_remove_min t2 in + match kcmp xk yk with + | 0 -> compare_ kcmp t1' t2' + | v -> v + + let rec to_string to_s t = + let rec h = function + | Empty -> "" + | Node(Empty,v,Empty) -> to_s v + | Node(l,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s v) + | Node(Empty,v,r) -> Printf.sprintf "%s, %s" (to_s v) (h r) + | Node(l,v,r) -> + Printf.sprintf "%s, %s, %s" + (h l) (to_s v) (h r) + in "{" ^ (h t) ^ "}" + + let gen_ cmp (agen : ?size:int -> Random.State.t -> 'a) + ?(size=50) rs : 'a tree = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else + let t = from_cursor (add_at cmp (agen rs) (to_cursor t)) in + loop (n-1) t + in + loop num empty + + +end + +module PolySet = struct + include BaseSet + type 'a t = 'a tree + type 'a set = 'a t + type ('a,'b) result = 'a * 'b t + type ('a,'b) result_ = ('a,'b) result + + type 'a elt_ = 'a + + type 'a cursor = 'a curs + type 'a cursor_ = 'a cursor + + let add x t = add Pervasives.compare x t + let add_at x t = add_at Pervasives.compare x t + + let compare x y = compare_ Pervasives.compare x y + let equal x y = compare x y = 0 + let mem x t = mem Pervasives.compare x t + let remove x t = remove Pervasives.compare x t + let union t1 t2 = union Pervasives.compare t1 t2 + let diff t1 t2 = diff Pervasives.compare t1 t2 + let inter t1 t2 = inter Pervasives.compare t1 t2 + let well_formed t = well_formed Pervasives.compare t + + let gen1 (agen : ?size:int -> Random.State.t -> 'a) ?size rs : 'a t = + gen_ Pervasives.compare agen ?size rs + +end + +module MonoSet(C : Mono.Comparable) = struct + include BaseSet + type elt = C.t + type 'a elt_ = elt + + type t = elt tree + type 'a set = t + + type 'a result = 'a * t + type ('a,'b) result_ = 'a result + + type cursor = elt curs + type 'a cursor_ = cursor + + let add x t = add C.compare x t + let mem x t = mem C.compare x t + let remove x t = remove C.compare x t + let union t1 t2 = union C.compare t1 t2 + let diff t1 t2 = diff C.compare t1 t2 + let inter t1 t2 = inter C.compare t1 t2 + + let add_at x t = add_at C.compare x t + + let compare t1 t2 = compare_ C.compare t1 t2 + let equal t1 t2 = compare t1 t2 = 0 + let well_formed t = well_formed C.compare t + + let to_string s = to_string C.to_string s + + let gen1 (agen : ?size:int -> Random.State.t -> elt) ?size rs : t = + gen_ C.compare agen ?size rs + +end + +module GenSet(C : Types.Mono.ArbitraryComparable) = struct + include MonoSet(C) + + let gen ?size rs = gen1 C.gen ?size rs +end + diff --git a/src/set/splaySet.mli b/src/set/splaySet.mli new file mode 100644 index 0000000..0ab2100 --- /dev/null +++ b/src/set/splaySet.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(** Sets with excellent non-uniform access performance + + Splay trees are binary search trees that are balanced based on + recently accessed elements. They provide amortized O(log n) + performance for tree operations ([mem], [add], [remove]), and O(n) + amortized time for set operations. Splay trees do not maintain + any invariant information and are therefore very memory efficient. + To achieve their amortized bounds, splay trees re-balance + themselves on every tree access (e.g., [mem]). Re-balancing + always leaves the most recently accessed element at the root of + the tree. Therefore repeated access to recent elements can be + very efficient. However, this also means that tree operations may + take O(n) for degenerate cases. +*) + +(** This module provides an implementation of Splay trees with a + polymorphic element type. The implementation uses the standard + library's polymorphic [compare] function internally and may not be + as efficient as the {!SplaySet.MonoSet} module which allows the + use of a more efficient comparison function. +*) +module rec PolySet : Sets.PolySetSig + with type ('a,'b) result = 'a * 'b PolySet.t + +(** This functor provides an implementation of Splay trees that are + parameterized by a specific monomorphic element type. The + resulting module may be more efficient than its polymorphic + counterpart, {!SplaySet.PolySet}. +*) +module rec MonoSet : functor(C: Types.Mono.Comparable) -> + Sets.MonoSetSig with type elt = C.t + and type 'a result = 'a * MonoSet(C).t + +(** This functor is similar to the {!SplaySet.MonoSet} functor except + it is parameterized by a module that also supports the [gen] + operation. Therefore, the resulting module is also able to + generate number sets. +*) +module rec GenSet : functor(C: Types.Mono.ArbitraryComparable) -> + Sets.GenSetSig with type elt = C.t + and type 'a result = 'a * GenSet(C).t + diff --git a/src/version.mli b/src/version.mli new file mode 100644 index 0000000..90d4218 --- /dev/null +++ b/src/version.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +val version : string +(** Current version of the Reins library *) diff --git a/test/OMakefile b/test/OMakefile new file mode 100644 index 0000000..e18040f --- /dev/null +++ b/test/OMakefile @@ -0,0 +1,2 @@ + +.SUBDIRS: perf unit diff --git a/test/perf/OMakefile b/test/perf/OMakefile new file mode 100644 index 0000000..1ee33e2 --- /dev/null +++ b/test/perf/OMakefile @@ -0,0 +1,28 @@ + +OCAMLINCLUDES += $(ROOT)/src #+benchmark + +FILES[] = + bench_driver + bench + list_bench + dug_set_tests + +TESTDIRS = set + +.SUBDIRS: $(TESTDIRS) + include OMakefile + export FILES + +OCAMLINCLUDES += $(TESTDIRS) + +OCAML_OTHER_LIBS = nums unix #benchmark + +OCAML_LIBS = $(ROOT)/src/reins + +PERF_DRIVER = $(OCamlProgram run_benchmarks,$(FILES)) + +perf_tests.results: $(PERF_DRIVER) + $(PERF_DRIVER) |& tee $@ + + +.DEFAULT: $(PERF_DRIVER) #perf_tests.results diff --git a/test/perf/bench.ml b/test/perf/bench.ml new file mode 100644 index 0000000..14788f1 --- /dev/null +++ b/test/perf/bench.ml @@ -0,0 +1,25 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types + +let time f arg = + let prev = Unix.gettimeofday () in + let _ = f arg in + let aft = Unix.gettimeofday () in + aft -. prev + +let rec loop n f acc = + if n <= 0 then acc + else loop (n-1) f (f acc) + +let random_int_list n = + let rs = Random.State.make_self_init ()in + loop n (fun y -> (Int.gen rs)::y) [] diff --git a/test/perf/bench_driver.ml b/test/perf/bench_driver.ml new file mode 100644 index 0000000..5eaaeaa --- /dev/null +++ b/test/perf/bench_driver.ml @@ -0,0 +1,34 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +(*open Benchmark*) +open Bench_helper +(* +let all_suites = [ + Set_bench.suites; +] +*) + + +(* +let rec run_bench = function + | BenchGroup lst -> + let res = latencyN ~style:Nil 500 lst in + print_newline(); + tabulate res + + | BenchList lst -> List.iter run_bench lst + | BenchLabel (label,bench) -> + Printf.printf "start group: %s\n%!" label; + run_bench bench + +let _ = + List.iter run_bench all_suites + +*) diff --git a/test/perf/bench_helper.ml b/test/perf/bench_helper.ml new file mode 100644 index 0000000..86b908f --- /dev/null +++ b/test/perf/bench_helper.ml @@ -0,0 +1,28 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins.Types + +type ('a,'b) bench_func = { + setup : 'a -> 'b; + run : 'b -> 'b; + teardown : 'b -> unit; +} + + +type ('a,'b) benchmark = + | BenchGroup of (string * ('a,'b) bench_func * 'a) list + | BenchList of ('a,'b) benchmark list + | BenchLabel of string * ('a,'b)benchmark + +(* +let random_int_list n = + let rs = Random.State.make_self_init ()in + loop n (fun y -> (Int.gen rs)::y) [] +*) diff --git a/test/perf/dug_set_tests.ml b/test/perf/dug_set_tests.ml new file mode 100644 index 0000000..fdad667 --- /dev/null +++ b/test/perf/dug_set_tests.ml @@ -0,0 +1,172 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf + +open Reins +open Types + +module ISet = AVLSet.GenSet(Int) + +module ExSet = OracleSet.Extractor(Int) +module BenchSet = OracleSet.Benchmark(ISet) + +module SetProf = DugProfile.Make(OracleSet) + +let pure_acc iters = + Bench.loop iters (ExSet.add 10) ExSet.empty + + +module B1(S : Sets.GenSetSig with type elt = int) = struct + let bench iters = + let rs = Random.State.make_self_init () in + let t0 = S.singleton 50 in + let rec helper n acc = + if n <= 0 then acc + else + let _ = S.add 60 t0 in + let t' = S.add (Int.gen rs) acc in + let t'' = S.add (Int.gen rs) acc in + let acc = S.union t' t'' in + ignore(S.is_empty acc); + ignore(S.is_empty t0); + helper (n-1) acc + in + helper iters S.empty +end + +let inst_bench iters = + let rs = Random.State.make_self_init () in + let t0 = ExSet.singleton 50 in + let rec helper n acc = + if n <= 0 then acc + else + let _ = ExSet.add 60 t0 in + let t' = ExSet.add (Int.gen rs) acc in + let t'' = ExSet.add (Int.gen rs) acc in + let acc = ExSet.union t' t'' in + ignore(ExSet.is_empty acc); + ignore(ExSet.is_empty t0); + helper (n-1) acc + in + helper iters ExSet.empty + +let real_bench iters = + let rs = Random.State.make_self_init () in + let t0 = ISet.singleton 50 in + let rec helper n acc = + if n <= 0 then acc + else + let _ = ISet.add 60 t0 in + let t' = ISet.add (Int.gen rs) acc in + let t'' = ISet.add (Int.gen rs) acc in + let acc = ISet.union t' t'' in + ignore(ISet.is_empty acc); + ignore(ISet.is_empty t0); + helper (n-1) acc + in + helper iters ISet.empty + +let test () = + let iters = 10000 in + let start = Unix.gettimeofday () in + let _ = inst_bench iters in + let mid = Unix.gettimeofday () in + let _ = real_bench iters in + let fin = Unix.gettimeofday () in + printf "wrapped: %f\n" (mid -. start); + printf "actual: %f\n" (fin -. mid); + let dug = ExSet.get_dug () in + let prof = SetProf.profile dug in + let s = SetProf.to_string prof in + printf "profile: %s\n" s + +let test_profile () = + let v0 = ExSet.singleton 10 in + let v1 = ExSet.add 10 v0 in + let v2 = ExSet.empty in + let v3 = ExSet.add 20 v2 in + let v4 = ExSet.choose v3 in + let v5 = ExSet.union v1 v3 in + let v6 = ExSet.remove 20 v5 in + let v7 = ExSet.union v1 v6 in + let v8 = ExSet.remove 10 v7 in + let v9 = ExSet.mem 15 v7 in + let v10 = ExSet.is_empty v8 in + ignore(v4,v9,v10) + +let test2 () = + let () = test_profile () in + let dug = ExSet.get_dug () in + let prof = SetProf.profile dug in + printf "profile: %s\n" (SetProf.to_string prof); + List.iter + (fun (op,c) -> + printf " %f : %s\n" c (OracleSet.op_to_string (OracleSet.coerce_mut op)) + ) prof.SetProf.mut_cdf; + prof + +module SetGen = DugGenerator.Make(OracleSet)(Int) + +let test_gen () = + (*let _ = inst_bench 100 in*) + let _ = Bench.loop 500 test_profile () in + let dug1 = ExSet.get_dug () in + let prof1 = SetProf.profile dug1 in + let _ = printf "profile: %s\n" (SetProf.to_string prof1) in + let dug2 = SetGen.generate prof1 (Dug.Id.to_int (Dug.size dug1)) in + let prof2 = SetProf.profile dug2 in + let _ = printf "generated: %s\n" (SetProf.to_string prof2) in + let tim = BenchSet.benchmark dug2 in + printf "got time: %f\n" tim; +(* + let dug3 = SetGen.generate prof2 (Dug.Id.to_int (Dug.size dug2)) in + let prof3 = SetProf.profile dug3 in + let _ = printf "regenerated: %s\n" (SetProf.to_string prof3) in +*) + () + +module ASet = AVLSet.GenSet(Int) +module RBSet = RBSet.GenSet(Int) +module PatSet = PatriciaSet.GenSet + +module ABench = OracleSet.Benchmark(ASet) +module RBBench = OracleSet.Benchmark(RBSet) +module PatBench = OracleSet.Benchmark(PatSet) + +module A_B1 = B1(ASet) +module RB_B1 = B1(RBSet) +module Pat_B1 = B1(PatSet) +module Inst_B1 = B1(OracleSet.Extractor(Int)) + +let _ = + let () = Gc.compact () in + let avl_real = Bench.time A_B1.bench 1000 in + let () = Gc.compact () in + let rb_real = Bench.time RB_B1.bench 1000 in + let () = Gc.compact () in + let pat_real = Bench.time Pat_B1.bench 1000 in + let () = Gc.compact () in + let inst = Bench.time inst_bench 1000 in + let () = Gc.compact () in + let dug = ExSet.get_dug () in + let () = Gc.compact () in + let avl = Bench.time BenchSet.benchmark dug in + let () = Gc.compact () in + let pat = Bench.time PatBench.benchmark dug in + let () = Gc.compact () in + let rb = Bench.time RBBench.benchmark dug in + printf "avl actual: %f\n" avl_real; + printf "r/b actual: %f\n" rb_real; + printf "patricia actual: %f\n" pat_real; + printf "instrumented: %f\n" inst; + printf "AVL replay: %f\n" avl; + printf "R/B replay: %f\n" rb; + printf "Patricia replay: %f\n" pat + diff --git a/test/perf/list_bench.ml b/test/perf/list_bench.ml new file mode 100644 index 0000000..33571c3 --- /dev/null +++ b/test/perf/list_bench.ml @@ -0,0 +1,133 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open Reins +open Bench +open Types + +type ('elt,'list) dict = { + empty : 'list; + is_empty : 'list -> bool; + length : 'list -> int; + rev : 'list -> 'list; + cons : 'elt -> 'list -> 'list; + snoc : 'elt -> 'list -> 'list; + hd : 'list -> 'elt; + tl : 'list -> 'list; + pop : 'list -> 'elt * 'list; + append : 'list -> 'list -> 'list; + (* flatten *) + from_list : 'elt list -> 'list; + to_list : 'list -> 'elt list; + iter : ('elt -> unit) -> 'list -> unit; + fold : 'a. ('a -> 'elt -> 'a) -> 'a -> 'list -> 'a; +(* + rev_map : ('a -> 'b) -> 'a t -> 'b t; + map : ('a -> 'b) -> 'a t -> 'b t; +*) + to_string : ('elt -> string) -> 'list -> string; + compare : ('elt -> 'elt -> int) -> 'list -> 'list -> int; + gen : (?size:int -> Random.State.t -> 'elt) -> + ?size:int -> Random.State.t -> 'list; + } + +module ListDict(L : Lists.ListSig) = struct + let dict = { + empty = L.empty; + is_empty = L.is_empty; + length = L.length; + rev = L.rev; + cons = L.cons; + snoc = L.snoc; + hd = L.hd; + tl = L.tl; + pop = L.pop; + append = L.append; + from_list = L.from_list; + to_list = L.to_list; + iter = L.iter; + fold = L.fold; + to_string = L.to_string; + compare = L.compare; + gen = L.gen; + } +end + +(* A type for abstractly working with a lists. Using a polymorphic + record field allows the same 'f' to simultaneously apply to lists of + arbitrary type. +*) +type ('elt, 'arg, 'res) polyf = { + f : 'list. ('elt,'list) dict -> 'arg -> 'res + } + +let modules_map f = [ + (let module D = ListDict(CatenableList) in "CatenableList", f.f D.dict); + (let module D = ListDict(DoubleList.Make(SList)) in "DoubleList(SList)", f.f D.dict); + (let module D = ListDict(DoubleQueue) in "DoubleQueue", f.f D.dict); + (let module D = ListDict(SkewBinaryList) in "SkewBinaryList", f.f D.dict); + (let module D = ListDict(SList) in "SList", f.f D.dict); + ] + +module SF = Mono.ComposeComparable(SList)(Mono.ComparablePair(String)(Float)) + +let bench_all polyf arg = + let flist = modules_map polyf in + let times = List.map (fun (s,f) -> s, time f arg) flist in + printf "%s\n" (SF.to_string times) + +let cons_random () = + let f dict rs = + ignore(loop 100000 (fun l -> dict.cons (Int.gen rs) l) dict.empty); + in + let rs = Random.State.make_self_init () in + bench_all {f=f} rs + +let snoc_random () = + let f dict rs = + ignore(loop 6000 (fun l -> dict.snoc (Int.gen rs) l) dict.empty); + in + let rs = Random.State.make_self_init () in + bench_all {f=f} rs + +let append1_random () = + let f dict rs = + ignore(loop 6000 + (fun l -> + let single = dict.cons (Int.gen rs) dict.empty in + dict.append l single + ) dict.empty); + in + let rs = Random.State.make_self_init () in + bench_all {f=f} rs + +let prepend1_random () = + let f dict rs = + ignore(loop 10000 + (fun l -> + let single = dict.cons (Int.gen rs) dict.empty in + dict.append single l + ) dict.empty); + in + let rs = Random.State.make_self_init () in + bench_all {f=f} rs + + +let run () = + printf "cons: \n%!"; + cons_random (); + printf "snoc: \n%!"; + snoc_random (); + printf "append1: \n%!"; + append1_random (); + printf "prepend1: \n%!"; + prepend1_random (); + () + diff --git a/test/perf/set/OMakefile b/test/perf/set/OMakefile new file mode 100644 index 0000000..07709f2 --- /dev/null +++ b/test/perf/set/OMakefile @@ -0,0 +1,5 @@ + +OCAMLINCLUDES += .. + +FILES[] += + set/set_bench diff --git a/test/perf/set/set_bench.ml b/test/perf/set/set_bench.ml new file mode 100644 index 0000000..41645ed --- /dev/null +++ b/test/perf/set/set_bench.ml @@ -0,0 +1,225 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open Bench + +open Reins.Types +(* +(** This is a first class representation of a tree which includes all + of a tree's operations packed into a record. This can be useful + when treating trees as first class objects, such as to benchmark + them *) +type ('set,'elt,'bool_result,'elt_result,'cursor) treeSetDict = { + empty : 'set; + is_empty : 'set -> bool; + mem : 'elt -> 'set -> 'bool_result; + add : 'elt -> 'set -> 'set; + singleton : 'elt -> 'set; + remove : 'elt -> 'set -> 'set; + well_formed : 'set -> bool; + compare : 'set -> 'set -> int; + equal : 'set -> 'set -> bool; + iter : ('elt -> unit) -> 'set -> unit; + fold : 'a. ('a -> 'elt -> 'a) -> 'a -> 'set -> 'a; + min_elt : 'set -> 'elt_result; + max_elt : 'set -> 'elt_result; + choose : 'set -> 'elt_result; + cardinal : 'set -> int; + union : 'set -> 'set -> 'set; + inter : 'set -> 'set -> 'set; + diff : 'set -> 'set -> 'set; + to_cursor : 'set -> 'cursor; + from_cursor : 'cursor -> 'set; + at_top : 'cursor -> bool; + at_left : 'cursor -> bool; + at_right : 'cursor -> bool; + move_up : 'cursor -> 'cursor; + move_down_left : 'cursor -> 'cursor; + move_down_right : 'cursor -> 'cursor; + went_left : 'cursor -> bool; + went_right : 'cursor -> bool; + has_value : 'cursor -> bool; + get_value : 'cursor -> 'elt; + of_result : 'bool_result -> bool; + elt_of_elt_result : 'elt_result -> 'elt; + gen1 : (?size:int -> Random.State.t -> 'elt) -> + ?size:int -> Random.State.t -> 'set +(* + for_all : ('elt -> bool) -> 'set -> bool + exists : ('elt -> bool) -> 'set -> bool + elements : 'set -> 'elt list + subset : 'set -> 'set -> bool + filter : ('elt -> bool) -> 'set -> 'set + partition : ('elt -> bool) -> 'set -> 'set * 'set + split : 'elt -> 'set -> 'set * bool * 'set + add_at : 'elt -> cursor -> cursor + mem_at : 'elt -> cursor -> bool + remove_at : 'elt -> cursor -> cursor +*) +} + + +module MonoTreeSetToDict(Set : Sets.MonoSet) = struct + + let dict = { + empty = Set.empty; + is_empty = Set.is_empty; + mem = Set.mem; + add = Set.add; + singleton = Set.singleton; + remove = Set.remove; + well_formed = Set.well_formed; + compare = Set.compare; + equal = Set.equal; + iter = Set.iter; + fold = Set.fold; + min_elt = Set.min_elt; + max_elt = Set.max_elt; + choose = Set.choose; + cardinal = Set.cardinal; + union = Set.union; + inter = Set.inter; + diff = Set.diff; + to_cursor = Set.to_cursor; + from_cursor = Set.from_cursor; + at_top = Set.at_top; + at_left = Set.at_left; + at_right = Set.at_right; + move_up = Set.move_up; + move_down_left = Set.move_down_left; + move_down_right = Set.move_down_right; + went_left = Set.went_left; + went_right = Set.went_right; + has_value = Set.has_value; + get_value = Set.get_value; + of_result = Set.of_result; + gen1 = Set.gen1; + } +end + + + +module INRIA_Set (C : MonoComparable) = struct + include Set.Make(C) + type 'a set = t + type 'a elt_ = elt + + type elt_result = elt + type 'a elt_result_ = elt_result + + type bool_result = bool + type 'a bool_result_ = bool_result + + + let fold f acc t = fold (fun x y -> f y x) t acc + + let elt_of_elt_result x = x + let bool_of_bool_result x = x + + let well_formed t = true + let to_string t = + "[" ^ (fold (fun acc x -> acc ^ ", " ^ (C.to_string x)) "" t) ^ "]" + + let gen1 (agen : (?size:int -> Random.State.t -> elt)) ?(size=50) rs = + let num = Random.State.int rs size in + let rec loop n t = + if n <= 0 then t + else loop (n-1) (add (agen ~size:size rs) t) + in + loop num empty + + type cursor + type 'a cursor_ = cursor + let get_value _ = assert false + let has_value _ = assert false + let went_right _ = assert false + let went_left _ = assert false + let move_down_right _ = assert false + let move_down_left _ = assert false + let move_up _ = assert false + let at_right _ = assert false + let at_left _ = assert false + let at_top _ = assert false + let from_cursor _ = assert false + let to_cursor _ = assert false + +end + + +(* + A type for abstractly working with a sets. Using a polymorphic + record field allows the same 'f' to simultaneously apply to sets of + arbitrary type. +*) +type ('elt, 'arg,'res) polyf = { + f : 'set 'br 'er 'cur. ('set,'elt, 'br,'er,'cur) treeSetDict -> 'arg -> 'res +} + +let modules_map f = [ + (let module D = MonoTreeSetToDict(AVL.Set1(Int)) in f.f D.dict); + (let module D = MonoTreeSetToDict(AVL.Set2(Int)) in f.f D.dict); + (let module D = MonoTreeSetToDict(AVL.Set3(Int)) in f.f D.dict); + (let module D = MonoTreeSetToDict(Patricia.Set) in f.f D.dict); + (let module D = MonoTreeSetToDict(RedBlack.Set(Int)) in f.f D.dict); + (let module D = MonoTreeSetToDict(Splay.Set(Int)) in f.f D.dict); + (let module D = MonoTreeSetToDict(INRIA_Set(Int)) in f.f D.dict); +] + +let time_f f arg = + let prev = Unix.gettimeofday () in + let _ = f arg in + let aft = Unix.gettimeofday () in + aft -. prev + +let average n f = + let rec loop n acc = + if n <= 0 then acc + else + let acc = List.map2 (+.) acc (f ()) in + loop (n-1) acc + in + let lst = loop (n-1) (f()) in + List.map (fun x -> x /. (float n)) lst + +let time_rand_union n oc = + let rs = Random.State.make_self_init () in + let f d x = + time_f (d.union (d.gen1 ~size:n Int.gen rs)) (d.gen1 ~size:n Int.gen rs) in + let all_bench = modules_map {f=f} in + + let bench () = List.map (fun x -> x ()) all_bench in + let results = average 20 bench in + List.iter (fprintf oc "%f ") results + +let time_rand_insert n oc = + let f d i = ignore(List.fold_left (fun acc x -> d.add x acc) d.empty i) in + let all_bench = modules_map {f=f} in + + let bench () = + let input = random_int_list n in + List.map (fun x -> time_f x input) all_bench + in + let results = average 15 bench in + List.iter (fprintf oc "%f ") results + +(* +let _ = + let oc = open_out "data.1" in + for i = 1 to 100 do + eprintf "at %d\n%!" i; + let size = i * 50 in + fprintf oc "%d " size; + time_rand_union size oc; + fprintf oc "\n%!" + done; + close_out oc + +*) +*) diff --git a/test/unit/OMakefile b/test/unit/OMakefile new file mode 100644 index 0000000..565c83d --- /dev/null +++ b/test/unit/OMakefile @@ -0,0 +1,26 @@ + +TESTDIRS = list heap set map + +OCAMLINCLUDES += \ + $(shell $(OCAMLFIND) query oUnit) \ + $(ROOT)/src + +FILES[] = + test_helper + genericTest + test_runner + +.SUBDIRS: $(TESTDIRS) + include OMakefile + export FILES + +OCAMLINCLUDES += $(TESTDIRS) + +OCAML_LIBS = $(ROOT)/src/reins +OCAML_OTHER_LIBS += str nums unix oUnit +TEST_PROGRAM = $(OCamlProgram run_unit_tests, $(FILES)) + +unit_tests.results: $(TEST_PROGRAM) + ./run_unit_tests |& tee $@ + +.DEFAULT: $(TEST_PROGRAM) unit_tests.results diff --git a/test/unit/genericTest.ml b/test/unit/genericTest.ml new file mode 100644 index 0000000..9b7cea7 --- /dev/null +++ b/test/unit/genericTest.ml @@ -0,0 +1,48 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Test_helper + +module ComparableTests(C : Mono.ArbitraryComparable) = struct + + let random_suite = + [ + (let module T = RandCheck(struct + module Arg = C + let desc = "Compare is reflexive" + let law t = C.compare t t = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(C)(C) + let desc = "Compare is anti-symmetric" + let law (t1,t2) = + let c1 = C.compare t1 t2 in + let c2 = C.compare t2 t1 in + c1 = -c2 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.Gen3Tuple(C)(C)(C) + let desc = "Compare is transitive" + let law (t1, t2, t3) = + match (C.compare t1 t2), (C.compare t2 t3) with + | 0,0 -> (C.compare t1 t3) = 0 + | x,y when x < 0 && y < 0 -> (C.compare t1 t3) < 0 + | x,y when x > 0 && y > 0 -> (C.compare t1 t3) > 0 + | x, y when x < 0 && y > 0 -> raise Quickcheck.Trivial + | x, y (* x > 0 && y < 0*) -> raise Quickcheck.Trivial + end) in (T.desc, T.test)); + ] + + let unit_suite = [] +end diff --git a/test/unit/heap/OMakefile b/test/unit/heap/OMakefile new file mode 100644 index 0000000..f072fe5 --- /dev/null +++ b/test/unit/heap/OMakefile @@ -0,0 +1,7 @@ + +OCAMLINCLUDES += .. + +FILES[] += + heap/genericHeapTest + heap/binomialHeapTest + heap/skewBinomialHeapTest \ No newline at end of file diff --git a/test/unit/heap/binomialHeapTest.ml b/test/unit/heap/binomialHeapTest.ml new file mode 100644 index 0000000..9221f60 --- /dev/null +++ b/test/unit/heap/binomialHeapTest.ml @@ -0,0 +1,21 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types + +let desc = "Binomial" + +module ITest = GenericHeapTest.RandomTests(BinomialHeap.GenHeap)(Int) + +let random_suite = + [ + ] @ ITest.random_suite + +let unit_suite = [] @ ITest.unit_suite diff --git a/test/unit/heap/genericHeapTest.ml b/test/unit/heap/genericHeapTest.ml new file mode 100644 index 0000000..384a738 --- /dev/null +++ b/test/unit/heap/genericHeapTest.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types +open Test_helper + +module GenList = Mono.ComposeGenComparable(SList) + +module type HOHeap = + functor(C : Mono.ArbitraryComparable) -> + Heaps.GenHeapSig with type elt = C.t + +module RandomTests(H : HOHeap)(A : Mono.ArbitraryComparable) = struct + module Heap = H(A) + + let unit_suite = [] + + let random_suite = [ + + (let module T = RandCheck(struct + module Arg = A + let desc = "ins/find 1 element" + let law i = + let t = Heap.insert i Heap.empty in + let i' = Heap.find_min t in + A.compare i i' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = A + let desc = "ins/del is empty" + let law i = + let t = Heap.insert i Heap.empty in + let t = Heap.delete_min t in + Heap.is_empty t + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenList(A) + let desc = "insert list then find_min/del_min each gives sorted output" + let law l = + let t = List.fold_left (fun acc x -> Heap.insert x acc) Heap.empty l in + let lst' = + let rec loop acc t = + if Heap.is_empty t then acc + else loop ((Heap.find_min t)::acc) (Heap.delete_min t) + in loop [] t + in + let lst' = List.rev lst' in + let sortlst = List.sort A.compare l in + lst' = sortlst + end) in (T.desc, T.test)); + + + ] +end diff --git a/test/unit/heap/skewBinomialHeapTest.ml b/test/unit/heap/skewBinomialHeapTest.ml new file mode 100644 index 0000000..0ac8865 --- /dev/null +++ b/test/unit/heap/skewBinomialHeapTest.ml @@ -0,0 +1,21 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types + +let desc = "Skew Binomial" + +module ITest = GenericHeapTest.RandomTests(SkewBinomialHeap.GenHeap)(Int) + +let random_suite = + [ + ] @ ITest.random_suite + +let unit_suite = [] @ ITest.unit_suite diff --git a/test/unit/list/OMakefile b/test/unit/list/OMakefile new file mode 100644 index 0000000..d8a2f0f --- /dev/null +++ b/test/unit/list/OMakefile @@ -0,0 +1,10 @@ + +OCAMLINCLUDES += .. + +FILES[] += + list/sListTest + list/doubleListTest + list/catenableListTest + list/doubleQueueTest + list/skewBinaryListTest + list/genericListTest diff --git a/test/unit/list/catenableListTest.ml b/test/unit/list/catenableListTest.ml new file mode 100644 index 0000000..73afe13 --- /dev/null +++ b/test/unit/list/catenableListTest.ml @@ -0,0 +1,24 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Quickcheck +open Types +open Lists + +let desc = "CatenableList" + +module GTests = GenericListTest.Make(CatenableList)(Int) + +let random_suite = [ + +] @ GTests.random_suite + +let unit_suite = GTests.unit_suite diff --git a/test/unit/list/doubleListTest.ml b/test/unit/list/doubleListTest.ml new file mode 100644 index 0000000..f4554c8 --- /dev/null +++ b/test/unit/list/doubleListTest.ml @@ -0,0 +1,85 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Test_helper +open Types + +let desc = "DoubleList" + +module DSList = DoubleList.Make(SList) + +module G = Mono.ComposeGenComparable(DSList)(Int) +module GTests = GenericListTest.Make(DSList)(Int) + +let random_suite = [ + ( let module T = RandCheck(struct + module Arg = Mono.GenPair(G)(G) + let desc = "splice list is eq to cons each individual" + let law (l1,l2) = + let res1 = DSList.splice l1 l2 in + let lfront = DSList.goto_front l1 in + let res2 = + DSList.fold (fun acc x -> DSList.next (DSList.cons x acc)) l2 lfront + in + G.compare res1 res2 = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "x = (prev (next x))" + let law l = + if DSList.at_back l then true + else G.compare l (DSList.prev (DSList.next l)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "x = (next (prev x))" + let law l = + if DSList.at_front l then true + else G.compare l (DSList.next (DSList.prev l)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(Int)(G) + let desc = "pop of (cons x l) is x,l" + let law (i,l) = + let x,tl = DSList.pop (DSList.cons i l) in + (Int.compare x i) = 0 && (G.compare tl l) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(G)(G) + let desc = "append l is same as to cons'ing individually at end" + let law (l1,l2) = + let l = DSList.append l1 l2 in + let l' = + DSList.fold + (fun acc x -> DSList.cons x (DSList.goto_back acc)) + l1 (DSList.goto_front l2) + in + G.compare l l' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.ComposeGenComparable(DSList)(G) + let desc = "DSList.flatten mirrors List.flatten" + let law dll = + let lst = List.map DSList.to_list (DSList.to_list dll) in + let lst' = List.flatten lst in + let dll1 = DSList.from_list lst' in + let dll2 = DSList.flatten dll in + G.compare dll1 dll2 = 0 + end) in (T.desc, T.test)); + +] @ GTests.random_suite + +let unit_suite = GTests.unit_suite diff --git a/test/unit/list/doubleQueueTest.ml b/test/unit/list/doubleQueueTest.ml new file mode 100644 index 0000000..063a230 --- /dev/null +++ b/test/unit/list/doubleQueueTest.ml @@ -0,0 +1,42 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Test_helper +open Types + +let desc = "DoubleQueue" + +module GenList = Mono.ComposeGenComparable(SList) + +module GTests = GenericListTest.Make(DoubleQueue)(Int) + +let random_suite = + [ + (let module T = RandCheck(struct + module Arg = GenList(Int) + let desc = "queue all elements in list. repeated dequeue gives same order as list fold" + let law l = + let q = List.fold_left (fun acc x -> DoubleQueue.enqueue x acc) + DoubleQueue.empty l in + let t,_ = + List.fold_left (fun (t,acc) x -> + let hd,tl = DoubleQueue.dequeue acc in + (t && hd = x),tl + ) (true,q) l + in + t + end) in (T.desc, T.test)); + + ] @ GTests.random_suite + +let unit_suite = [ + +] @ GTests.unit_suite diff --git a/test/unit/list/genericListTest.ml b/test/unit/list/genericListTest.ml new file mode 100644 index 0000000..2b7831b --- /dev/null +++ b/test/unit/list/genericListTest.ml @@ -0,0 +1,226 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Test_helper + +module GenList = Mono.ComposeGenComparable(SList) + +module Make(L : Lists.ListSig)(A : Mono.ArbitraryComparable) = struct + module GenL = Mono.ComposeGenComparable(L)(A) + + module CmpTests = GenericTest.ComparableTests(GenL) + + let random_suite = CmpTests.random_suite @ [ + (let module T = RandCheck(struct + module Arg = A + let desc = ".rev [x] = [x]" + let law i = + let t = L.cons i L.empty in + GenL.compare (L.rev t) t = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenL)(GenL) + let desc = ".rev (x@y) = (.rev y) @ (.rev x)" + let law (l1,l2) = + let l1' = L.rev (L.append l1 l2) in + let l2' = L.append (L.rev l2) (L.rev l1) in + GenL.compare l1' l2' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenL + let desc = ".rev x = .rev (.rev x)" + let law l1 = + let l2 = L.rev (L.rev l1) in + GenL.compare l1 l2 = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenL) + let desc = "hd (cons x t) is x" + let law (x,l) = + A.compare (L.hd (L.cons x l)) x = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenList(A) + let desc = "Length is n after n cons" + let law il = + let dl = List.fold_left (fun acc x -> L.cons x acc) L.empty il in + (List.length il) = (L.length dl) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenL) + let desc = "tail of (cons x l) is l" + let law (i,l) = + let l' = L.tl (L.cons i l) in + (GenL.compare l l') = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenL + let desc = "from_list (to_list x) is x" + let law l = + GenL.compare l (L.from_list (L.to_list l)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module AL = GenList(A) + module Arg = GenList(A) + let desc = "to_list (from_list x) is x" + let law l = + AL.compare l (L.to_list (L.from_list l)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenList(GenL) + let desc = "flatten mirrors List.flatten" + let law l = + let t = L.from_list l in + let lst1 = L.to_list (L.flatten t) in + let t' = List.map L.to_list l in + let lst2 = List.flatten t' in + let module ML = GenList(A) in + (ML.compare lst1 lst2) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenL) + let desc = "pop of (cons x l) is x,l" + let law (i,l) = + let x,tl = L.pop (L.cons i l) in + (A.compare x i) = 0 && (GenL.compare tl l) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenL) + let desc = "last (snoc x t) is x" + let law (x,l) = + let x' = L.last (L.snoc x l) in + A.compare x x' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenList(A) + let desc = "to_list preserves order" + let law l = + let lr = List.rev l in + let t = List.fold_left (fun acc x -> L.cons x acc) L.empty lr in + let l' = L.to_list t in + let module ML = GenList(A) in + ML.compare l l' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenL + let desc = "(map id l) is same as l" + let law l = + let l' = L.map (fun x -> x) l in + L.compare A.compare l l' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GenL + let desc = "l is same as (rev (rev_map id l))" + let law l = + let l' = L.rev (L.rev_map (fun x -> x) l) in + L.compare A.compare l l' = 0 + end) in (T.desc, T.test)); + + ] + +let assert_equal_int x y = + assert_equal ~cmp:(=) ~printer:string_of_int + ~msg:"ints not equal" x y + + let unit_suite = CmpTests.unit_suite @ [ + + ("is_empty empty" >:: fun () -> + assert_equal true (L.is_empty L.empty)); + + ("empty,ins,del,is_empty" >:: fun () -> + let dl = L.cons 10 L.empty in + let dl = L.tl dl in + assert_equal true (L.is_empty dl)); + + ("hd of empty raises Failure 'hd'" >:: fun () -> + (try + ignore(L.hd L.empty); + assert_failure "hd of empty should raise an exception" + with + | Failure "hd" -> () + | _ -> assert_failure "(hd empty) raised the wrong exception")); + + ("tl of empty raises Failure 'tl'" >:: fun () -> + (try + ignore(L.tl L.empty); + assert_failure "tl of empty should raise an exception" + with + | Failure "tl" -> () + | _ -> assert_failure "(tl empty) raised the wrong exception")); + + ("pop of empty raises Failure 'pop'" >:: fun () -> + (try + ignore(L.pop L.empty); + assert_failure "pop of empty should raise an exception" + with + | Failure "pop" -> () + | _ -> assert_failure "(pop empty) raised the wrong exception")); + + ("last of empty raises Failure 'last'" >:: fun () -> + (try + ignore(L.last L.empty); + assert_failure "last of empty should raise an exception" + with + | Failure "last" -> () + | _ -> assert_failure "(last empty) raised the wrong exception")); + + ("map of (+1) on [1..5] is [2..6]" >:: fun () -> + let l = L.from_list [1;2;3;4;5] in + let l' = L.map ((+) 1) l in + let lr = L.from_list [2;3;4;5;6] in + assert_equal ~cmp:(fun x y -> L.compare Int.compare x y = 0) + ~printer:(L.to_string Int.to_string) l' lr + ); + + ("rev_map of (+1) on [1..5] is [6..2]" >:: fun () -> + let l = L.from_list [1;2;3;4;5] in + let l' = L.rev_map ((+) 1) l in + let lr = L.from_list [6;5;4;3;2] in + assert_equal ~cmp:(fun x y -> L.compare Int.compare x y = 0) + ~printer:(L.to_string Int.to_string) l' lr + ); + + ("to_string of [1;2;3;4;5] is \"[1;2;3;4;5]\"" >:: fun () -> + let l = L.from_list [1;2;3;4;5] in + let s = L.to_string string_of_int l in + let module ML = GenList(Int) in + assert_equal ~cmp:(fun x y -> String.compare x y = 0) + ~printer:(fun x -> x) + s "[1; 2; 3; 4; 5]" + ); + + ("to_string of [] is \"[]\"" >:: fun () -> + let l = L.from_list [] in + let s = L.to_string string_of_int l in + let module ML = GenList(Int) in + assert_equal ~cmp:(fun x y -> String.compare x y = 0) + ~printer:(fun x -> x) + s "[]" + ); + + ] + +end + diff --git a/test/unit/list/sListTest.ml b/test/unit/list/sListTest.ml new file mode 100644 index 0000000..fa1d6df --- /dev/null +++ b/test/unit/list/sListTest.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types + +module List_IT = ListIterator.From_List(SList) + +module GTests = GenericListTest.Make(SList)(Int) + +let desc = "Standard List" + +let fold_test = + "iterator fold" >:: fun () -> + let lst = [1;2;3;4;5] in + let it = List_IT.create List_IT.Left_Right List_IT.Traverse_All lst in + let it_ans = List_IT.fold (+) 0 it in + let std_ans = List.fold_left (+) 0 lst in + assert_equal ~printer:Int.to_string std_ans it_ans + +let unit_suite = + [ + fold_test + ] @ GTests.unit_suite + +let random_suite = + [ + ] @ GTests.random_suite diff --git a/test/unit/list/skewBinaryListTest.ml b/test/unit/list/skewBinaryListTest.ml new file mode 100644 index 0000000..74d97fe --- /dev/null +++ b/test/unit/list/skewBinaryListTest.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Quickcheck +open Types +open Lists +open Test_helper +open OUnit + +let desc = "SkewBinaryList" + +module G = Mono.ComposeGenComparable(SkewBinaryList)(Int) +module GTests = GenericListTest.Make(SkewBinaryList)(Int) + +let random_suite = [ + (let module T = RandCheck(struct + module Arg = Int + let desc = "List of {0..n-1} can lookup {0,...,l-1}" + let law len = + let len = (max 1 len) mod 100 in + let rec f n l = + if n < 0 then l + else f (n-1) (SkewBinaryList.cons n l) + in + let l = f len SkewBinaryList.empty in + for i = 0 to (len-1) do + assert (SkewBinaryList.lookup i l = i) + done; + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "List of length l can update {0,...,l-1}" + let law l = + let len = SkewBinaryList.length l in + for i = 0 to (len-1) do + ignore(SkewBinaryList.update i 10 l); + done; + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "lookup sees updates" + let law l = + if SkewBinaryList.is_empty l then raise Trivial; + let i = Int.gen (Random.State.make_self_init()) in + let len = SkewBinaryList.length l in + let idx = Random.int len in + SkewBinaryList.lookup idx (SkewBinaryList.update idx i l) = i + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "lookup failure raises Not_found" + let law l = + let len = SkewBinaryList.length l in + try ignore(SkewBinaryList.lookup len l); false + with Not_found -> true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = G + let desc = "update failure raises Not_found" + let law l = + let len = SkewBinaryList.length l in + try ignore(SkewBinaryList.update len 10 l); false + with Not_found -> true + end) in (T.desc, T.test)); + +] @ GTests.random_suite + +module L = SkewBinaryList + +let unit_suite = + [ + + ] @ GTests.unit_suite diff --git a/test/unit/map/OMakefile b/test/unit/map/OMakefile new file mode 100644 index 0000000..abad69d --- /dev/null +++ b/test/unit/map/OMakefile @@ -0,0 +1,10 @@ + +OCAMLINCLUDES += .. + +FILES[] += + map/aVLMapTest + map/patriciaMapTest + map/splayMapTest + map/genericMapTest + map/rBMapTest + diff --git a/test/unit/map/aVLMapTest.ml b/test/unit/map/aVLMapTest.ml new file mode 100644 index 0000000..2393df5 --- /dev/null +++ b/test/unit/map/aVLMapTest.ml @@ -0,0 +1,30 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Quickcheck +open Printf + +let desc = "AVL" + +module MapTests1 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen1(Int)(Int)) +module MapTests2 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen2(Int)(Int)) +module MapTests3 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen3(Int)(Int)) + +let random_suite = + [ + ] @ MapTests1.random_suite @ MapTests2.random_suite @ MapTests3.random_suite + + +let unit_suite = + [ + ] + @ MapTests1.unit_suite @ MapTests2.unit_suite @ MapTests3.unit_suite diff --git a/test/unit/map/genericMapTest.ml b/test/unit/map/genericMapTest.ml new file mode 100644 index 0000000..db8516c --- /dev/null +++ b/test/unit/map/genericMapTest.ml @@ -0,0 +1,363 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Test_helper + +module GenList = Mono.ComposeGenComparable(SList) + +module RandomMapTests + (A : Mono.ArbitraryComparable) + (GMap : Maps.GenMapSig with type key = A.t and type elt = A.t) + = struct + + module CmpTests = GenericTest.ComparableTests(GMap) + module KV = Mono.ComparablePair(A)(A) + + let add_list t l = List.fold_left (fun t e -> GMap.add e e t) t l + let join_max k v1 v2 = max v1 v2 + let diff_true _ _ _ = true + + let random_suite = CmpTests.random_suite @ [ + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenList(A)) + let desc = "[Map] Add first element" + let law (i,lst) = + let t = GMap.add i i GMap.empty in + let t = add_list t lst in + GMap.of_result (GMap.mem i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.Gen3Tuple(GMap)(A)(GenList(A)) + let desc = "[Map] Add middle element" + let law (t,i,lst) = + let t = GMap.add i i t in + let t = add_list t lst in + GMap.of_result (GMap.mem i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GMap) + let desc = "[Map] Add last element" + let law (i,t) = + GMap.of_result (GMap.mem i (GMap.add i i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenList(A)) + let desc = "[Map] Remove first element" + let law (i,lst) = + let t = GMap.add i i GMap.empty in + let t = add_list t lst in + let t = GMap.remove i t in + not (GMap.of_result (GMap.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.Gen3Tuple(GMap)(A)(GenList(A)) + let desc = "[Map] Remove middle element" + let law (t,i,lst) = + let t = GMap.add i i t in + let t = add_list t lst in + let t = GMap.remove i t in + not (GMap.of_result (GMap.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(A) + let desc = "[Map] Remove last element" + let law (t,i) = + let t = GMap.add i i t in + let t = GMap.remove i t in + not (GMap.of_result (GMap.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] Union is commutative" + let law (t1,t2) = + (* Note: the join function must also be commutative *) + let t = GMap.union join_max t1 t2 in + let t' = GMap.union join_max t2 t1 in + GMap.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Map] Union follows list concatenation" + let law (l1,l2) = + let t1 = add_list GMap.empty l1 in + let t2 = add_list GMap.empty l2 in + let t = GMap.union join_max t1 t2 in + let t' = add_list GMap.empty (l1 @ l2) in + GMap.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] Intersection is commutative" + let law (t1,t2) = + let t = GMap.inter join_max t1 t2 in + let t' = GMap.inter join_max t2 t1 in + GMap.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Map] Intersection follows list find_all" + let law (l1,l2) = + let t1 = add_list GMap.empty l1 in + let t2 = add_list GMap.empty l2 in + let t = GMap.inter join_max t1 t2 in + let ilst = List.find_all (fun x -> List.mem x l1) l2 in + let t' = add_list GMap.empty ilst in + GMap.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] diff x x is empty" + let law t = + let t' = GMap.diff diff_true t t in + GMap.is_empty t' + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Map] diff follows list filter" + let law (l1,l2) = + let t1 = add_list GMap.empty l1 in + let t2 = add_list GMap.empty l2 in + let t = GMap.diff diff_true t1 t2 in + let dlist = List.filter (fun x -> not (List.mem x l2)) l1 in + let t' = add_list GMap.empty dlist in + GMap.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] A intersected with B has same keys as B - (B - A)" + let law (t1,t2) = + let t = GMap.inter join_max t1 t2 in + let t' = GMap.diff diff_true t2 (GMap.diff diff_true t2 t1) in + GMap.compare_keys t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] map id produces equivalent Map" + let law t = + let t' = GMap.map (fun x -> x) t in + (GMap.compare t t') = 0 + end) in (T.desc, T.test)); + + (* Well formedness tests *) + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GMap) + let desc = "[Map] GMap Well-Formed after add" + let law (i,t) = + assert(GMap.well_formed t); + GMap.well_formed (GMap.add i i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GMap) + let desc = "[Map] GMap Well-Formed after remove" + let law (i,t) = + assert(GMap.well_formed t); + GMap.well_formed (GMap.add i i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] GMap Well-Formed after union" + let law (t1,t2) = + assert(GMap.well_formed t1); + assert(GMap.well_formed t2); + GMap.well_formed (GMap.union join_max t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] GMap Well-Formed after diff" + let law (t1,t2) = + assert(GMap.well_formed t1); + assert(GMap.well_formed t2); + GMap.well_formed (GMap.diff diff_true t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(GMap) + let desc = "[Map] GMap Well-Formed after inter" + let law (t1,t2) = + assert(GMap.well_formed t1); + assert(GMap.well_formed t2); + GMap.well_formed (GMap.inter join_max t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] Iter visits nodes in increasing order" + let law t = + if GMap.is_empty t then true + else + let acc = ref (GMap.of_result (GMap.min_key t)) in + GMap.iter + (fun x _ -> + if A.compare x !acc < 0 then failwith "Failed!" + else acc := x + ) t; + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold visits nodes in increasing order" + let law t = + if GMap.is_empty t then true + else + let min = GMap.of_result (GMap.min_key t) in + let _ = + GMap.fold + (fun acc x _ -> + if A.compare x acc < 0 then failwith "Failed!" + else x + ) min t + in + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold (+1) equals the cardinality" + let law t = + let c = GMap.fold (fun acc _ _ -> acc+1) 0 t in + (GMap.cardinal t) = c + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold finds max_key" + let law t = + if GMap.is_empty t then raise Quickcheck.Trivial; + let mk = GMap.fold + (fun acc k _ -> if A.compare acc k < 0 then k else acc) + (GMap.of_result (GMap.min_key t)) t + in + A.compare mk (GMap.of_result (GMap.max_key t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold finds min_key" + let law t = + if GMap.is_empty t then raise Quickcheck.Trivial; + let mk = GMap.fold + (fun acc k _ -> if A.compare acc k > 0 then k else acc) + (GMap.of_result (GMap.max_key t)) t + in + A.compare mk (GMap.of_result (GMap.min_key t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold finds max_keyval" + let law t = + if GMap.is_empty t then raise Quickcheck.Trivial; + let mkv = GMap.fold + (fun (kacc,vacc) k v -> if A.compare kacc k < 0 then (k,v) else (kacc,vacc)) + (GMap.of_result (GMap.min_keyval t)) t + in + KV.compare mkv (GMap.of_result (GMap.max_keyval t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GMap + let desc = "[Map] fold finds min_keyval" + let law t = + if GMap.is_empty t then raise Quickcheck.Trivial; + let mkv = GMap.fold + (fun (kacc,vacc) k v -> if A.compare kacc k > 0 then (k,v) else (kacc,vacc)) + (GMap.of_result (GMap.max_keyval t)) t + in + KV.compare mkv (GMap.of_result (GMap.min_keyval t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GMap)(A) + let desc = "[Map] removing a non-existent element is no-op" + let law (t,x) = + if GMap.of_result (GMap.mem x t) then raise Quickcheck.Trivial + else GMap.compare t (GMap.remove x t) = 0 + end) in (T.desc, T.test)); + + ] + + let unit_suite = CmpTests.unit_suite @ [ + ("min_key empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(min_key empty) should raise Not_found" + Not_found (fun () -> (GMap.min_key GMap.empty)) + ); + + ("max_key empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(max_key empty) should raise Not_found" + Not_found (fun () -> (GMap.max_key GMap.empty)) + ); + + ("min_keyval empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(min_keyval empty) should raise Not_found" + Not_found (fun () -> (GMap.min_keyval GMap.empty)) + ); + + ("max_keyval empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(max_keyval empty) should raise Not_found" + Not_found (fun () -> (GMap.max_keyval GMap.empty)) + ); + + ("the cardinal of empty is 0" >:: fun () -> + assert_equal ~printer:string_of_int 0 (GMap.cardinal GMap.empty) + ); + + ("the cardinal of a singleton is 1" >:: fun () -> + let rs = Random.State.make_self_init () in + let t = GMap.singleton (A.gen rs) (A.gen rs) in + assert_equal ~printer:string_of_int 1 (GMap.cardinal t) + ); + + ("move_up from the top raises Failure 'move up'" >:: fun () -> + assert_raises ~msg:"move_up should raise Failure" + (Failure "move_up") + (fun () -> (GMap.move_up (GMap.to_cursor GMap.empty))) + ); + + ("move_down_left raises Failure 'move_down_left'" >:: fun () -> + assert_raises ~msg:"move_down_left should raise Failure" + (Failure "move_down_left") + (fun () -> (GMap.move_down_left (GMap.to_cursor GMap.empty))) + ); + + ("move_down_right top raises Failure 'move down_right'" >:: fun () -> + assert_raises ~msg:"move_down_right should raise Failure" + (Failure "move_down_right") + (fun () -> (GMap.move_down_right (GMap.to_cursor GMap.empty))) + ); + + ("empty is well formed" >:: fun () -> + assert_bool "empty should be well-formed" (GMap.well_formed GMap.empty) + ); + + ] + + +end + diff --git a/test/unit/map/patriciaMapTest.ml b/test/unit/map/patriciaMapTest.ml new file mode 100644 index 0000000..48a8f7b --- /dev/null +++ b/test/unit/map/patriciaMapTest.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types + +let desc = "Patricia Sets" + +module MapTests = GenericMapTest.RandomMapTests(Int)(PatriciaMap.GenMap(Int)) + +let random_suite = + [ + ] + @ MapTests.random_suite + +let unit_suite = + [ + ] + @ MapTests.unit_suite + diff --git a/test/unit/map/rBMapTest.ml b/test/unit/map/rBMapTest.ml new file mode 100644 index 0000000..0ec3d72 --- /dev/null +++ b/test/unit/map/rBMapTest.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types + +let desc = "RedBlack" + +module MapTests = GenericMapTest.RandomMapTests(Int)(RBMap.GenMap(Int)(Int)) + +let random_suite = + [ + ] + @ MapTests.random_suite + +let unit_suite = + [ + ] + @ MapTests.unit_suite diff --git a/test/unit/map/splayMapTest.ml b/test/unit/map/splayMapTest.ml new file mode 100644 index 0000000..b46ef55 --- /dev/null +++ b/test/unit/map/splayMapTest.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +open Printf +open OUnit +open Reins +open Test_helper + +open Types + +let desc = "Splay" + +module M = SplayMap.GenMap(Int)(Int) + +let top_key t = + let c = M.to_cursor t in + fst (M.get_value c) + +let mem_at_top i t = + let m,t = M.mem i t in + assert_bool (sprintf "mem failed for %d" i) (m = true); + assert_equal i (top_key t); + t + +let (++) f g = g f + +let add_mem_test = + "add/mem sequential" >:: fun () -> + let t = + M.add 1 1 M.empty ++ + M.add 2 2 ++ + M.add 3 3 ++ + M.add 4 4 ++ + M.add 5 5 + in + ignore(mem_at_top 1 t ++ + mem_at_top 2 ++ + mem_at_top 3 ++ + mem_at_top 4 ++ + mem_at_top 5) + + +module MapTests = GenericMapTest.RandomMapTests(Int)(M) + +let random_suite = + [ + + ] + @ MapTests.random_suite + +let unit_suite = + [ + add_mem_test + ] + @ MapTests.unit_suite diff --git a/test/unit/set/OMakefile b/test/unit/set/OMakefile new file mode 100644 index 0000000..5a9f77d --- /dev/null +++ b/test/unit/set/OMakefile @@ -0,0 +1,11 @@ + +OCAMLINCLUDES += .. + +FILES[] += + set/aVLSetTest + set/patriciaSetTest + set/splaySetTest + set/genericSetTest + set/rBSetTest + set/treeSetIteratorTest + diff --git a/test/unit/set/aVLSetTest.ml b/test/unit/set/aVLSetTest.ml new file mode 100644 index 0000000..bd0c190 --- /dev/null +++ b/test/unit/set/aVLSetTest.ml @@ -0,0 +1,36 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Quickcheck +open Printf + +let desc = "AVL" + +module SetTests1 = GenericSetTest.RandomSetTests(AVLSet.GenSet1(Int))(Int) +module SetTests2 = GenericSetTest.RandomSetTests(AVLSet.GenSet2(Int))(Int) +module SetTests3 = GenericSetTest.RandomSetTests(AVLSet.GenSet3(Int))(Int) + +module Iter1 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet1(Int))(Int) +module Iter2 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet2(Int))(Int) +module Iter3 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet3(Int))(Int) + +let random_suite = + [ + ] @ SetTests1.random_suite @ SetTests2.random_suite @ SetTests3.random_suite + @ Iter1.random_suite @ Iter2.random_suite @ Iter3.random_suite + + +let unit_suite = + [ + ] + @ SetTests1.unit_suite @ SetTests2.unit_suite @ SetTests3.unit_suite + @ Iter1.unit_suite @ Iter2.unit_suite @ Iter3.unit_suite diff --git a/test/unit/set/genericSetTest.ml b/test/unit/set/genericSetTest.ml new file mode 100644 index 0000000..ede1aad --- /dev/null +++ b/test/unit/set/genericSetTest.ml @@ -0,0 +1,311 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types +open Test_helper + +module GenList = Mono.ComposeGenComparable(SList) + +module RandomSetTests(GSet : Sets.GenSetSig) + (A : Mono.ArbitraryComparable with type t = GSet.elt) = struct + + let add_list t l = List.fold_left (fun t e -> GSet.add e t) t l + + module CmpTests = GenericTest.ComparableTests(GSet) + + let random_suite = CmpTests.random_suite @ [ + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenList(A)) + let desc = "[Set] Add first element" + let law (i,lst) = + let t = GSet.add i GSet.empty in + let t = add_list t lst in + GSet.of_result (GSet.mem i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.Gen3Tuple(GSet)(A)(GenList(A)) + let desc = "[Set] Add middle element" + let law (t,i,lst) = + let t = GSet.add i t in + let t = add_list t lst in + GSet.of_result (GSet.mem i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GSet) + let desc = "[Set] Add last element" + let law (i,t) = + GSet.of_result (GSet.mem i (GSet.add i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GenList(A)) + let desc = "[Set] Remove first element" + let law (i,lst) = + let t = GSet.add i GSet.empty in + let t = add_list t lst in + let t = GSet.remove i t in + not (GSet.of_result (GSet.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.Gen3Tuple(GSet)(A)(GenList(A)) + let desc = "[Set] Remove middle element" + let law (t,i,lst) = + let t = GSet.add i t in + let t = add_list t lst in + let t = GSet.remove i t in + not (GSet.of_result (GSet.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(A) + let desc = "[Set] Remove last element" + let law (t,i) = + let t = GSet.add i t in + let t = GSet.remove i t in + not (GSet.of_result (GSet.mem i t)) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] Union is commutative" + let law (t1,t2) = + let t = GSet.union t1 t2 in + let t' = GSet.union t2 t1 in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Set] Union follows list concatenation" + let law (l1,l2) = + let t1 = add_list GSet.empty l1 in + let t2 = add_list GSet.empty l2 in + let t = GSet.union t1 t2 in + let t' = add_list GSet.empty (l1 @ l2) in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] Intersection is commutative" + let law (t1,t2) = + let t = GSet.inter t1 t2 in + let t' = GSet.inter t2 t1 in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Set] Intersection follows list find_all" + let law (l1,l2) = + let t1 = add_list GSet.empty l1 in + let t2 = add_list GSet.empty l2 in + let t = GSet.inter t1 t2 in + let ilst = List.find_all (fun x -> List.mem x l1) l2 in + let t' = add_list GSet.empty ilst in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GSet + let desc = "[Set] diff x x is empty" + let law t = + let t' = GSet.diff t t in + GSet.is_empty t' + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GenList(A))(GenList(A)) + let desc = "[Set] diff follows list filter" + let law (l1,l2) = + let t1 = add_list GSet.empty l1 in + let t2 = add_list GSet.empty l2 in + let t = GSet.diff t1 t2 in + let dlist = List.filter (fun x -> not (List.mem x l2)) l1 in + let t' = add_list GSet.empty dlist in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] A intersected with B is B - (B - A)" + let law (t1,t2) = + let t = GSet.inter t1 t2 in + let t' = GSet.diff t2 (GSet.diff t2 t1) in + GSet.compare t t' = 0 + end) in (T.desc, T.test)); + + (* Well formedness tests *) + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GSet) + let desc = "[Set] GSet Well-Formed after add" + let law (i,t) = + assert(GSet.well_formed t); + GSet.well_formed (GSet.add i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(A)(GSet) + let desc = "[Set] GSet Well-Formed after remove" + let law (i,t) = + assert(GSet.well_formed t); + GSet.well_formed (GSet.add i t) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] GSet Well-Formed after union" + let law (t1,t2) = + assert(GSet.well_formed t1); + assert(GSet.well_formed t2); + GSet.well_formed (GSet.union t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] GSet Well-Formed after diff" + let law (t1,t2) = + assert(GSet.well_formed t1); + assert(GSet.well_formed t2); + GSet.well_formed (GSet.diff t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(GSet) + let desc = "[Set] GSet Well-Formed after inter" + let law (t1,t2) = + assert(GSet.well_formed t1); + assert(GSet.well_formed t2); + GSet.well_formed (GSet.inter t1 t2) + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GSet + let desc = "[Set] Iter visits nodes in increasing order" + let law t = + if GSet.is_empty t then true + else + let acc = ref (GSet.of_result (GSet.min_elt t)) in + GSet.iter + (fun x -> + if A.compare x !acc < 0 then failwith "Failed!" + else acc := x + ) t; + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GSet + let desc = "[Set] fold visits nodes in increasing order" + let law t = + if GSet.is_empty t then true + else + let min = GSet.of_result (GSet.min_elt t) in + let _ = + GSet.fold + (fun acc x -> + if A.compare x acc < 0 then failwith "Failed!" + else x + ) min t + in + true + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GSet + let desc = "[Set] fold finds max_elt" + let law t = + if GSet.is_empty t then raise Quickcheck.Trivial; + let mk = GSet.fold + (fun acc k -> if A.compare acc k < 0 then k else acc) + (GSet.of_result (GSet.min_elt t)) t + in + A.compare mk (GSet.of_result (GSet.max_elt t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = GSet + let desc = "[Set] fold finds min_elt" + let law t = + if GSet.is_empty t then raise Quickcheck.Trivial; + let mk = GSet.fold + (fun acc k -> if A.compare acc k > 0 then k else acc) + (GSet.of_result (GSet.max_elt t)) t + in + A.compare mk (GSet.of_result (GSet.min_elt t)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.GenPair(GSet)(A) + let desc = "[Set] removing a non-existent element is no-op" + let law (t,x) = + if GSet.of_result (GSet.mem x t) then raise Quickcheck.Trivial + else GSet.compare t (GSet.remove x t) = 0 + end) in (T.desc, T.test)); + + ] + + let unit_suite = CmpTests.unit_suite @ [ + ("min_elt empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(min_elt empty) should raise Not_found" + Not_found (fun () -> (GSet.min_elt GSet.empty)) + ); + + ("max_elt empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(max_elt empty) should raise Not_found" + Not_found (fun () -> (GSet.max_elt GSet.empty)) + ); + + ("choose empty raises Not_found" >:: fun () -> + assert_raises ~msg:"(choose empty) should raise Not_found" + Not_found (fun () -> (GSet.choose GSet.empty)) + ); + + ("the cardinal of empty is 0" >:: fun () -> + assert_equal ~printer:string_of_int 0 (GSet.cardinal GSet.empty) + ); + + ("the cardinal of a singleton is 1" >:: fun () -> + let rs = Random.State.make_self_init () in + let t = GSet.singleton (A.gen rs) in + assert_equal ~printer:string_of_int 1 (GSet.cardinal t) + ); + + ("move_up from the top raises Failure 'move up'" >:: fun () -> + assert_raises ~msg:"move_up should raise Failure" + (Failure "move_up") + (fun () -> (GSet.move_up (GSet.to_cursor GSet.empty))) + ); + + ("move_down_left raises Failure 'move_down_left'" >:: fun () -> + assert_raises ~msg:"move_down_left should raise Failure" + (Failure "move_down_left") + (fun () -> (GSet.move_down_left (GSet.to_cursor GSet.empty))) + ); + + ("move_down_right top raises Failure 'move down_right'" >:: fun () -> + assert_raises ~msg:"move_down_right should raise Failure" + (Failure "move_down_right") + (fun () -> (GSet.move_down_right (GSet.to_cursor GSet.empty))) + ); + + ("empty is well formed" >:: fun () -> + assert_bool "empty should be well-formed" (GSet.well_formed GSet.empty) + ); + + ] + +end diff --git a/test/unit/set/patriciaSetTest.ml b/test/unit/set/patriciaSetTest.ml new file mode 100644 index 0000000..8b81eac --- /dev/null +++ b/test/unit/set/patriciaSetTest.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins +open Types + +let desc = "Patricia Sets" + +module SetTests = GenericSetTest.RandomSetTests(PatriciaSet.GenSet)(Int) +module IterTests = TreeSetIteratorTest.RandomTests(PatriciaSet.GenSet)(Int) + +let random_suite = + [ + ] + @ SetTests.random_suite + @ IterTests.random_suite + +let unit_suite = + [ + ] + @ SetTests.unit_suite + @ IterTests.unit_suite + diff --git a/test/unit/set/rBSetTest.ml b/test/unit/set/rBSetTest.ml new file mode 100644 index 0000000..c7b6b29 --- /dev/null +++ b/test/unit/set/rBSetTest.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open OUnit +open Reins +open Types + +let desc = "RedBlack" + +module SetTests = GenericSetTest.RandomSetTests(RBSet.GenSet(Int))(Int) +module IterTests = TreeSetIteratorTest.RandomTests(RBSet.GenSet(Int))(Int) + +let random_suite = + [ + ] + @ SetTests.random_suite + @ IterTests.random_suite + +let unit_suite = + [ + ] + @ SetTests.unit_suite + @ IterTests.unit_suite diff --git a/test/unit/set/splaySetTest.ml b/test/unit/set/splaySetTest.ml new file mode 100644 index 0000000..e8056b5 --- /dev/null +++ b/test/unit/set/splaySetTest.ml @@ -0,0 +1,65 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + + +open Printf +open OUnit +open Reins +open Test_helper + +open Types + +let desc = "Splay" + +module M = SplaySet.GenSet(Int) + +let top_node t = + let c = M.to_cursor t in + M.get_value c + +let mem_at_top i t = + let m,t = M.mem i t in + assert_bool (sprintf "mem failed for %d" i) (m = true); + assert_equal i (top_node t); + t + +let (++) f g = g f + +let add_mem_test = + "add/mem sequential" >:: fun () -> + let t = + M.add 1 M.empty ++ + M.add 2 ++ + M.add 3 ++ + M.add 4 ++ + M.add 5 + in + ignore(mem_at_top 1 t ++ + mem_at_top 2 ++ + mem_at_top 3 ++ + mem_at_top 4 ++ + mem_at_top 5) + + +module SetTests = GenericSetTest.RandomSetTests(M)(Int) +module IterTests = TreeSetIteratorTest.RandomTests(M)(Int) + +let random_suite = + [ + + ] + @ SetTests.random_suite + @ IterTests.random_suite + +let unit_suite = + [ + add_mem_test + ] + @ SetTests.unit_suite + @ IterTests.unit_suite diff --git a/test/unit/set/treeSetIteratorTest.ml b/test/unit/set/treeSetIteratorTest.ml new file mode 100644 index 0000000..e8c0543 --- /dev/null +++ b/test/unit/set/treeSetIteratorTest.ml @@ -0,0 +1,142 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open OUnit +open Test_helper +open Reins +open Types + +let desc = "TreeSet Iterator" + +module RandomTests + (Tree : Sets.GenSetSig) + (Elt : Mono.ArbitraryComparable with type t = Tree.elt) = +struct + module Iter = TreeSetIterator.Make(Tree) + + let tree_of_list lst = + List.fold_left (fun x y -> Tree.add y x) Tree.empty lst + + let list_of_iter it = + List.rev (Iter.fold (fun acc x -> x::acc) [] it) + + let assert_equal_ilist l1 l2 = + let module M = Mono.ComposeComparable(SList)(Int) in + assert_equal ~cmp:(fun x y -> M.compare x y = 0) + ~printer:M.to_string l1 l2 + + + let unit_suite = + [ + ("while false traverse" >:: fun () -> + let rs = Random.State.make_self_init () in + let trav = Iter.Traverse_While (fun _ -> false) in + let s = Tree.singleton (Elt.gen rs) in + let _ = Iter.create (Iter.Ascending Iter.InOrder) trav s in + () + ); + + ] + + + let random_suite = + [ + (let module T = RandCheck(struct + module Arg = Mono.ComposeGen(SList)(Elt) + let desc = "asc inorder is follows List.sort" + let law lst = + let sorted_lst = SList.sort Elt.compare lst in + let t = tree_of_list lst in + let dir = Iter.Ascending Iter.InOrder in + let it = Iter.create dir Iter.Traverse_All t in + let iter_lst = list_of_iter it in + if SList.compare Elt.compare sorted_lst iter_lst = 0 + then true + else begin + let msg = Printf.sprintf "sorted: %s iter: %s\n" + (SList.to_string Elt.to_string sorted_lst) + (SList.to_string Elt.to_string iter_lst) + in + failwith msg + end + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Mono.ComposeGen(SList)(Elt) + let desc = "desc inorder is follows reversed List.sort" + let law lst = + let sorted_lst = SList.sort (fun x y -> -(Elt.compare x y)) lst in + let t = tree_of_list lst in + let dir = Iter.Descending Iter.InOrder in + let it = Iter.create dir Iter.Traverse_All t in + let iter_lst = list_of_iter it in + SList.compare Elt.compare sorted_lst iter_lst = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Tree + let desc = "asc inorder is reverse of desc inorder" + let law t = + let module I = TreeSetIterator.Make(Arg) in + let it1 = I.create (I.Ascending I.InOrder) I.Traverse_All t in + let it2 = I.create (I.Descending I.InOrder) I.Traverse_All t in + let lst1 = I.fold (fun acc x -> x::acc) [] it1 in + let lst2 = I.fold (fun acc x -> x::acc) [] it2 in + let module L = Mono.ComposeComparable(SList)(Elt) in + (L.compare lst1 (List.rev lst2)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Tree + let desc = "asc preorder is reverse of desc preorder" + let law t = + let module I = TreeSetIterator.Make(Arg) in + let it1 = I.create (I.Ascending I.PreOrder) I.Traverse_All t in + let it2 = I.create (I.Descending I.PreOrder) I.Traverse_All t in + let lst1 = I.fold (fun acc x -> x::acc) [] it1 in + let lst2 = I.fold (fun acc x -> x::acc) [] it2 in + let module L = Mono.ComposeComparable(SList)(Elt) in + (L.compare lst1 (List.rev lst2)) = 0 + end) in (T.desc, T.test)); + + (let module T = RandCheck(struct + module Arg = Tree + let desc = "asc postorder is reverse of desc postorder" + let law t = + let module I = TreeSetIterator.Make(Arg) in + let it1 = I.create (I.Ascending I.PostOrder) I.Traverse_All t in + let it2 = I.create (I.Descending I.PostOrder) I.Traverse_All t in + let lst1 = I.fold (fun acc x -> x::acc) [] it1 in + let lst2 = I.fold (fun acc x -> x::acc) [] it2 in + let module L = Mono.ComposeComparable(SList)(Elt) in + (L.compare lst1 (List.rev lst2)) = 0 + end) in (T.desc, T.test)); + +(* + (let module T = RandCheck(struct + module Arg = Tree + let desc = "folding asc preorder follows Tree.fold" + let law t = + + let module ISet = AVL.GenSet(Int) in + let module I = TreeSetIterator.MonoIterator(ISet) in + let s = ISet.add 3 ISet.empty in + let it = I.create (I.Ascending I.PreOrder) I.Traverse_All s in + let it_ans = I.fold (+) 0 it in + let std_ans = 3 in + assert_equal ~printer:Int.to_string std_ans it_ans + end) in (T.desc, T.test)); +*) + ] + + +end + + diff --git a/test/unit/test_helper.ml b/test/unit/test_helper.ml new file mode 100644 index 0000000..d5e901c --- /dev/null +++ b/test/unit/test_helper.ml @@ -0,0 +1,27 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Reins + +module type TestSuite = sig + val desc : string + val unit_suite : OUnit.test list + val random_suite : (string * (Random.State.t -> unit)) list +end + +module Conf = struct + let num_iterations = 100 + let size_arg = Some 100 + let max_trivial_percentage = 10.0 +end + +module RandCheck = Quickcheck.Check(Conf) + +let rec do_times n f acc = + if n <= 0 then acc else do_times (n-1) f (f acc) diff --git a/test/unit/test_runner.ml b/test/unit/test_runner.ml new file mode 100644 index 0000000..7d0eb2c --- /dev/null +++ b/test/unit/test_runner.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* The OCaml Reins Library *) +(* *) +(* Copyright 2007 Mike Furr. *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1 with the linking *) +(* exception given in the COPYING file. *) +(**************************************************************************) + +open Printf +open OUnit +open Test_helper + +module Test(T : TestSuite) = struct + let test rs = T.desc >::: + ["Unit Tests" >::: T.unit_suite; + "Random Tests" >::: + (List.map (fun (desc,suite) -> desc >:: (fun () -> suite rs)) T.random_suite) + ] +end + +let all_tests = fun rs -> "All Tests" >::: + [ + (let module T = Test(SListTest) in T.test rs); + (let module T = Test(DoubleQueueTest) in T.test rs); + (let module T = Test(DoubleListTest) in T.test rs); + (let module T = Test(CatenableListTest) in T.test rs); + (let module T = Test(SkewBinaryListTest) in T.test rs); + (let module T = Test(AVLSetTest) in T.test rs); + (let module T = Test(RBSetTest) in T.test rs); + (let module T = Test(SplaySetTest) in T.test rs); + (let module T = Test(PatriciaSetTest) in T.test rs); + (let module T = Test(AVLMapTest) in T.test rs); + (let module T = Test(RBMapTest) in T.test rs); + (let module T = Test(SplayMapTest) in T.test rs); + (let module T = Test(PatriciaMapTest) in T.test rs); + (let module T = Test(BinomialHeapTest) in T.test rs); + (let module T = Test(SkewBinomialHeapTest) in T.test rs); + ] + +(* +let stime = ref 0.0 +let time_tests = function + | EStart p -> stime := Unix.gettimeofday () + | EEnd p -> + let dtime = Unix.gettimeofday () in + printf "%f : %s\n%!" (dtime -. !stime) (string_of_path p) + | EResult(RError(p,s)) -> failwith s + | EResult(RFailure(p,s)) -> failwith s + | EResult _ -> () +*) + +let _ = + Format.printf "Running unit tests\n"; + let rs = Random.State.make_self_init () in +(* + let _ = perform_test time_tests (all_tests rs) in + ()*) + let _ = run_test_tt_main (all_tests rs) in + Format.printf "\n*** All tests passed ***\n\n" + + -- cgit v1.2.3 From 3f57981943960b5f1f02342cf342d22e93c6ef09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Glondu?= Date: Wed, 19 Jul 2017 10:01:14 +0200 Subject: Import ocaml-reins_0.1a-7.debian.tar.xz [dgit import tarball ocaml-reins 0.1a-7 ocaml-reins_0.1a-7.debian.tar.xz] --- changelog | 71 +++++++++++ compat | 1 + control | 44 +++++++ copyright | 33 +++++ dirs | 0 docs | 0 gbp.conf | 2 + patches/0001-Fix-PREFIX-handling.patch | 26 ++++ patches/0002-Install-cmi.patch | 19 +++ patches/0003-Fix-test-suite-with-new-oUnit.patch | 35 ++++++ patches/0004-Fix-version-in-META.patch | 20 +++ patches/0005-Fix-FTBFS-with-OCaml-4.02.3.patch | 21 ++++ ...ble-blocking-warnings-new-in-OCaml-4.05.0.patch | 21 ++++ ...-module-type-of-to-avoid-FTBFS-with-OCaml.patch | 138 +++++++++++++++++++++ patches/series | 7 ++ rules | 25 ++++ source/format | 1 + watch | 9 ++ 18 files changed, 473 insertions(+) create mode 100644 changelog create mode 100644 compat create mode 100644 control create mode 100644 copyright create mode 100644 dirs create mode 100644 docs create mode 100644 gbp.conf create mode 100644 patches/0001-Fix-PREFIX-handling.patch create mode 100644 patches/0002-Install-cmi.patch create mode 100644 patches/0003-Fix-test-suite-with-new-oUnit.patch create mode 100644 patches/0004-Fix-version-in-META.patch create mode 100644 patches/0005-Fix-FTBFS-with-OCaml-4.02.3.patch create mode 100644 patches/0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch create mode 100644 patches/0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch create mode 100644 patches/series create mode 100755 rules create mode 100644 source/format create mode 100644 watch diff --git a/changelog b/changelog new file mode 100644 index 0000000..c307361 --- /dev/null +++ b/changelog @@ -0,0 +1,71 @@ +ocaml-reins (0.1a-7) unstable; urgency=medium + + * Team upload + * debian/patches: + + Disable blocking warnings new in OCaml 4.05.0 + + Use "include module type of" to avoid FTBFS with OCaml 4.05.0 + * Update Vcs-* + * Bump debhelper compat to 10 + + -- Stéphane Glondu Wed, 19 Jul 2017 10:01:14 +0200 + +ocaml-reins (0.1a-6) unstable; urgency=medium + + * Team upload. + * Fix FTBFS with OCaml 4.02.3 + + -- Mehdi Dogguy Fri, 16 Oct 2015 22:48:32 +0200 + +ocaml-reins (0.1a-5) unstable; urgency=medium + + * Team upload + * debian/patches: + + Fix test-suite with new oUnit (Closes: #713499) + + Fix version in META + * Remove myself from Uploaders + * Update Vcs-* + * Add ocaml-findlib to Suggests + + -- Stéphane Glondu Thu, 30 Jan 2014 14:56:07 +0100 + +ocaml-reins (0.1a-4) unstable; urgency=low + + * Team upload. + * Set a dummy HOME when calling omake (fixes FTBFS on buildds where + HOME is not set). + + -- Mehdi Dogguy Thu, 21 Apr 2011 22:06:00 +0200 + +ocaml-reins (0.1a-3) unstable; urgency=low + + * Switch to dh-ocaml 0.9 + * Switch to format 3.0 (quilt) + * debian/control: + - update my e-mail address, remove DMUA + - update Standards-Version to 3.8.3 (no changes) + + -- Stéphane Glondu Sun, 20 Dec 2009 02:37:35 +0100 + +ocaml-reins (0.1a-2) unstable; urgency=low + + [ Stefano Zacchiroli ] + * promote Homepage to a real debian/control field, now that dpkg supports it + + [ Stephane Glondu ] + * Switch packaging to git + * Switch patches to quilt, add README.source + * Use dh and bump debhelper compatibility level to 7 + * debian/control: + - set Maintainer to d-o-m, add Mike and myself to Uploaders + - move to section ocaml + - update Standards-Version to 3.8.2 + - add versioned dependency on omake to avoid buggy package + * Switch debian/copyright to new format + + -- Stephane Glondu Sat, 04 Jul 2009 17:01:39 +0200 + +ocaml-reins (0.1a-1) unstable; urgency=low + + * Initial release (Closes: #445039) + + -- Mike Furr Tue, 02 Oct 2007 16:35:40 -0400 diff --git a/compat b/compat new file mode 100644 index 0000000..f599e28 --- /dev/null +++ b/compat @@ -0,0 +1 @@ +10 diff --git a/control b/control new file mode 100644 index 0000000..86a8e1e --- /dev/null +++ b/control @@ -0,0 +1,44 @@ +Source: ocaml-reins +Section: ocaml +Priority: optional +Maintainer: Debian OCaml Maintainers +Uploaders: + Mike Furr +Build-Depends: + debhelper (>= 10), + ocaml-nox (>= 3.11.1-3~), + omake (>= 0.9.8.5-3-6), + libounit-ocaml-dev (>= 1.0.3-4~), + ocaml-findlib (>= 1.2.5), + dh-ocaml (>= 0.9) +Standards-Version: 3.8.3 +Vcs-Git: https://anonscm.debian.org/git/pkg-ocaml-maint/packages/ocaml-reins.git +Vcs-Browser: https://anonscm.debian.org/git/pkg-ocaml-maint/packages/ocaml-reins.git +Homepage: http://ocaml-reins.sourceforge.net/ + +Package: libreins-ocaml-dev +Architecture: any +Depends: + ${ocaml:Depends}, + ${shlibs:Depends}, + ${misc:Depends} +Provides: ${ocaml:Provides} +Suggests: ocaml-findlib +Description: data structure library for OCaml + The OCaml Reins data structure library consists of the following + persistent implementations: + * Lists (singly, O(1) catenable, Acyclic doubly linked, + random access) + * Sets/Maps (AVL, Red/Black, Patricia, Splay) + * Heaps (Binomial, Skew-Binomial) + . + All of the implementations conform to a unified signature for each + data type. Also, each data types include zipper style cursor + interfaces and persistent, bi-directional cursor based iterators. + The library also includes a set of standard modules to hoist the base + typs into the module level (Int, Bool, etc...) as well as a + collection of functor combinators to minimize boilerplate (e.g., for + constructing compare or to_string functions). Finally, a + quickcheck-like random testing framework is included and each data + type supports the necessary "gen" function to generate a random + instance of the type. diff --git a/copyright b/copyright new file mode 100644 index 0000000..dea3ba6 --- /dev/null +++ b/copyright @@ -0,0 +1,33 @@ +Packaged-By: Mike Furr +Packaged-Date: Tue, 02 Oct 2007 16:35:40 -0400 +Original-Source-Location: http://ocaml-reins.sourceforge.net/ +Upstream-Author: Mike Furr + +Files: * +Copyright: © 2007 Mike Furr +License: LGPL-2.1 | other + + The OCaml Reins library is distributed under the terms of the Lesser + General Public License version 2.1 (provided in the file + /usr/share/common-licenses/LGPL-2.1) with the following linking + exception. + + As a special exception to the GNU Lesser General Public License, you + may link, statically or dynamically, a "work that uses the Library" + with a publicly distributed version of the Library to produce an + executable file containing portions of the Library, and distribute + that executable file under terms of your choice, without any of the + additional requirements listed in clause 6 of the GNU Lesser General + Public License. By "a publicly distributed version of the Library", + we mean either the unmodified Library as distributed by the official + ocaml-reins website (currently ocaml-reins.sourceforge.net), or a + modified version of the Library that is distributed under the + conditions defined in clause 3 of the GNU Lesser General Public + License. This exception does not however invalidate any other + reasons why the executable file might be covered by the GNU Lesser + General Public License. + +Files: debian/* +Copyright: © 2007 Mike Furr + © 2009 Stéphane Glondu +License: GPL-2+ diff --git a/dirs b/dirs new file mode 100644 index 0000000..e69de29 diff --git a/docs b/docs new file mode 100644 index 0000000..e69de29 diff --git a/gbp.conf b/gbp.conf new file mode 100644 index 0000000..cec628c --- /dev/null +++ b/gbp.conf @@ -0,0 +1,2 @@ +[DEFAULT] +pristine-tar = True diff --git a/patches/0001-Fix-PREFIX-handling.patch b/patches/0001-Fix-PREFIX-handling.patch new file mode 100644 index 0000000..4284299 --- /dev/null +++ b/patches/0001-Fix-PREFIX-handling.patch @@ -0,0 +1,26 @@ +From: Mike Furr +Date: Sat, 4 Jul 2009 14:48:29 +0200 +Subject: Fix PREFIX handling + +--- + config.omake | 7 ++++++- + 1 file changed, 6 insertions(+), 1 deletion(-) + +diff --git a/config.omake b/config.omake +index 4417254..7a35fc2 100644 +--- a/config.omake ++++ b/config.omake +@@ -7,7 +7,12 @@ static. = + exit 1 + OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) + OCAMLDEP=$(OCAMLDEP_MODULES) +- PREFIX=$(shell ocamlc -where) ++ if $(not $(defined PREFIX)) ++ PREFIX=$(shell ocamlc -where) ++ export ++ if $(defined-env OCAMLFIND_DESTDIR) ++ PREFIX = $(getenv OCAMLFIND_DESTDIR) ++ export + VERSION=0.1a + ConfMsgChecking(oUnit) + OUNIT_DIR=$(shell ocamlfind query oUnit) diff --git a/patches/0002-Install-cmi.patch b/patches/0002-Install-cmi.patch new file mode 100644 index 0000000..ec4559a --- /dev/null +++ b/patches/0002-Install-cmi.patch @@ -0,0 +1,19 @@ +From: Mike Furr +Date: Sat, 4 Jul 2009 14:48:41 +0200 +Subject: Install cmi + +--- + src/OMakefile | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/src/OMakefile b/src/OMakefile +index 983799d..e85608c 100644 +--- a/src/OMakefile ++++ b/src/OMakefile +@@ -52,5 +52,5 @@ REINS_CMX=$(if $(NATIVE_ENABLED), reins.cmx) + + install: META $(REINS_LIB) + mkdir -p $(PREFIX)/reins +- ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) \ ++ ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) reins.cmi \ + $(filter-exists $(addsuffix .mli, $(FILES))) diff --git a/patches/0003-Fix-test-suite-with-new-oUnit.patch b/patches/0003-Fix-test-suite-with-new-oUnit.patch new file mode 100644 index 0000000..37e7d24 --- /dev/null +++ b/patches/0003-Fix-test-suite-with-new-oUnit.patch @@ -0,0 +1,35 @@ +From: Stephane Glondu +Date: Thu, 30 Jan 2014 14:39:23 +0100 +Subject: Fix test-suite with new oUnit + +This is a part of https://github.com/ocaml/opam-repository/blob/master/packages/reins/reins.0.1a/files/fix_build.patch + +Bug-Debian: http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=713499 +--- + test/unit/OMakefile | 6 ++---- + 1 file changed, 2 insertions(+), 4 deletions(-) + +diff --git a/test/unit/OMakefile b/test/unit/OMakefile +index 565c83d..4ec66c9 100644 +--- a/test/unit/OMakefile ++++ b/test/unit/OMakefile +@@ -1,9 +1,8 @@ + + TESTDIRS = list heap set map + +-OCAMLINCLUDES += \ +- $(shell $(OCAMLFIND) query oUnit) \ +- $(ROOT)/src ++OCAMLPACKS [] = oUnit num ++OCAMLINCLUDES += $(ROOT)/src + + FILES[] = + test_helper +@@ -17,7 +16,6 @@ FILES[] = + OCAMLINCLUDES += $(TESTDIRS) + + OCAML_LIBS = $(ROOT)/src/reins +-OCAML_OTHER_LIBS += str nums unix oUnit + TEST_PROGRAM = $(OCamlProgram run_unit_tests, $(FILES)) + + unit_tests.results: $(TEST_PROGRAM) diff --git a/patches/0004-Fix-version-in-META.patch b/patches/0004-Fix-version-in-META.patch new file mode 100644 index 0000000..d915927 --- /dev/null +++ b/patches/0004-Fix-version-in-META.patch @@ -0,0 +1,20 @@ +From: Stephane Glondu +Date: Thu, 30 Jan 2014 14:54:58 +0100 +Subject: Fix version in META + +This is a part of https://github.com/ocaml/opam-repository/blob/master/packages/reins/reins.0.1a/files/fix_build.patch +--- + src/META.in | 4 ++-- + 1 file changed, 2 insertions(+), 2 deletions(-) + +diff --git a/src/META.in b/src/META.in +index 6cbc725..cbdb0a3 100644 +--- a/src/META.in ++++ b/src/META.in +@@ -1,3 +1,3 @@ +-version="0.1" ++version="0.1a" + archive(byte)="reins.cma" +-archive(native)="reins.cmxa" +\ No newline at end of file ++archive(native)="reins.cmxa" diff --git a/patches/0005-Fix-FTBFS-with-OCaml-4.02.3.patch b/patches/0005-Fix-FTBFS-with-OCaml-4.02.3.patch new file mode 100644 index 0000000..916bf18 --- /dev/null +++ b/patches/0005-Fix-FTBFS-with-OCaml-4.02.3.patch @@ -0,0 +1,21 @@ +From: Mehdi Dogguy +Date: Fri, 16 Oct 2015 22:45:57 +0200 +Subject: Fix FTBFS with OCaml 4.02.3 + +--- + OMakefile | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/OMakefile b/OMakefile +index b741412..c5b6a4e 100644 +--- a/OMakefile ++++ b/OMakefile +@@ -1,7 +1,7 @@ + + include config.omake + +-OCAMLFLAGS += -dtypes ++OCAMLFLAGS += -dtypes -w +a-3-4-27-50-k + + .SUBDIRS: src doc + diff --git a/patches/0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch b/patches/0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch new file mode 100644 index 0000000..ac15cfb --- /dev/null +++ b/patches/0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch @@ -0,0 +1,21 @@ +From: Stephane Glondu +Date: Wed, 19 Jul 2017 09:48:26 +0200 +Subject: Disable blocking warnings new in OCaml 4.05.0 + +--- + OMakefile | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/OMakefile b/OMakefile +index c5b6a4e..4d15909 100644 +--- a/OMakefile ++++ b/OMakefile +@@ -1,7 +1,7 @@ + + include config.omake + +-OCAMLFLAGS += -dtypes -w +a-3-4-27-50-k ++OCAMLFLAGS += -dtypes -w +a-3-4-27-50-52-60-k + + .SUBDIRS: src doc + diff --git a/patches/0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch b/patches/0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch new file mode 100644 index 0000000..3ba68d8 --- /dev/null +++ b/patches/0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch @@ -0,0 +1,138 @@ +From: Stephane Glondu +Date: Wed, 19 Jul 2017 09:58:29 +0200 +Subject: Use "include module type of" to avoid FTBFS with OCaml 4.05.0 + +--- + src/base/types.mli | 105 ++--------------------------------------------------- + 1 file changed, 3 insertions(+), 102 deletions(-) + +diff --git a/src/base/types.mli b/src/base/types.mli +index c5be9d9..f5e661c 100644 +--- a/src/base/types.mli ++++ b/src/base/types.mli +@@ -294,38 +294,7 @@ end + + module Int32 : + sig +- val zero : int32 +- val one : int32 +- val minus_one : int32 +- external neg : int32 -> int32 = "%int32_neg" +- external add : int32 -> int32 -> int32 = "%int32_add" +- external sub : int32 -> int32 -> int32 = "%int32_sub" +- external mul : int32 -> int32 -> int32 = "%int32_mul" +- external div : int32 -> int32 -> int32 = "%int32_div" +- external rem : int32 -> int32 -> int32 = "%int32_mod" +- val succ : int32 -> int32 +- val pred : int32 -> int32 +- val abs : int32 -> int32 +- val max_int : int32 +- val min_int : int32 +- external logand : int32 -> int32 -> int32 = "%int32_and" +- external logor : int32 -> int32 -> int32 = "%int32_or" +- external logxor : int32 -> int32 -> int32 = "%int32_xor" +- val lognot : int32 -> int32 +- external shift_left : int32 -> int -> int32 = "%int32_lsl" +- external shift_right : int32 -> int -> int32 = "%int32_asr" +- external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" +- external of_int : int -> int32 = "%int32_of_int" +- external to_int : int32 -> int = "%int32_to_int" +- external of_float : float -> int32 = "caml_int32_of_float" +- external to_float : int32 -> float = "caml_int32_to_float" +- external of_string : string -> int32 = "caml_int32_of_string" +- val to_string : int32 -> string +- external bits_of_float : float -> int32 = "caml_int32_bits_of_float" +- external float_of_bits : int32 -> float = "caml_int32_float_of_bits" +- type t = int32 +- val compare : t -> t -> int +- external format : string -> int32 -> string = "caml_int32_format" ++ include module type of Int32 + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Int32.t +@@ -333,42 +302,7 @@ end + + module Int64 : + sig +- val zero : int64 +- val one : int64 +- val minus_one : int64 +- external neg : int64 -> int64 = "%int64_neg" +- external add : int64 -> int64 -> int64 = "%int64_add" +- external sub : int64 -> int64 -> int64 = "%int64_sub" +- external mul : int64 -> int64 -> int64 = "%int64_mul" +- external div : int64 -> int64 -> int64 = "%int64_div" +- external rem : int64 -> int64 -> int64 = "%int64_mod" +- val succ : int64 -> int64 +- val pred : int64 -> int64 +- val abs : int64 -> int64 +- val max_int : int64 +- val min_int : int64 +- external logand : int64 -> int64 -> int64 = "%int64_and" +- external logor : int64 -> int64 -> int64 = "%int64_or" +- external logxor : int64 -> int64 -> int64 = "%int64_xor" +- val lognot : int64 -> int64 +- external shift_left : int64 -> int -> int64 = "%int64_lsl" +- external shift_right : int64 -> int -> int64 = "%int64_asr" +- external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" +- external of_int : int -> int64 = "%int64_of_int" +- external to_int : int64 -> int = "%int64_to_int" +- external of_float : float -> int64 = "caml_int64_of_float" +- external to_float : int64 -> float = "caml_int64_to_float" +- external of_int32 : int32 -> int64 = "%int64_of_int32" +- external to_int32 : int64 -> int32 = "%int64_to_int32" +- external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" +- external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" +- external of_string : string -> int64 = "caml_int64_of_string" +- val to_string : int64 -> string +- external bits_of_float : float -> int64 = "caml_int64_bits_of_float" +- external float_of_bits : int64 -> float = "caml_int64_float_of_bits" +- type t = int64 +- val compare : t -> t -> int +- external format : string -> int64 -> string = "caml_int64_format" ++ include module type of Int64 + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Int64.t +@@ -376,40 +310,7 @@ end + + module Nativeint : + sig +- val zero : nativeint +- val one : nativeint +- val minus_one : nativeint +- external neg : nativeint -> nativeint = "%nativeint_neg" +- external add : nativeint -> nativeint -> nativeint = "%nativeint_add" +- external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" +- external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" +- external div : nativeint -> nativeint -> nativeint = "%nativeint_div" +- external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" +- val succ : nativeint -> nativeint +- val pred : nativeint -> nativeint +- val abs : nativeint -> nativeint +- val size : int +- val max_int : nativeint +- val min_int : nativeint +- external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" +- external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" +- external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" +- val lognot : nativeint -> nativeint +- external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" +- external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" +- external shift_right_logical : nativeint -> int -> nativeint +- = "%nativeint_lsr" +- external of_int : int -> nativeint = "%nativeint_of_int" +- external to_int : nativeint -> int = "%nativeint_to_int" +- external of_float : float -> nativeint = "caml_nativeint_of_float" +- external to_float : nativeint -> float = "caml_nativeint_to_float" +- external of_int32 : int32 -> nativeint = "%nativeint_of_int32" +- external to_int32 : nativeint -> int32 = "%nativeint_to_int32" +- external of_string : string -> nativeint = "caml_nativeint_of_string" +- val to_string : nativeint -> string +- type t = nativeint +- val compare : t -> t -> int +- external format : string -> nativeint -> string = "caml_nativeint_format" ++ include module type of Nativeint + val equal : t -> t -> bool + val hash : 'a -> int + val gen : ?size:'a -> Random.State.t -> Nativeint.t diff --git a/patches/series b/patches/series new file mode 100644 index 0000000..b963721 --- /dev/null +++ b/patches/series @@ -0,0 +1,7 @@ +0001-Fix-PREFIX-handling.patch +0002-Install-cmi.patch +0003-Fix-test-suite-with-new-oUnit.patch +0004-Fix-version-in-META.patch +0005-Fix-FTBFS-with-OCaml-4.02.3.patch +0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch +0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch diff --git a/rules b/rules new file mode 100755 index 0000000..98eb655 --- /dev/null +++ b/rules @@ -0,0 +1,25 @@ +#!/usr/bin/make -f +# -*- makefile -*- + +include /usr/share/ocaml/ocamlvars.mk + +DEST := $(CURDIR)/debian/libreins-ocaml-dev/$(OCAML_STDLIB_DIR) + +%: + dh $@ --with ocaml + +.PHONY: override_dh_auto_build +override_dh_auto_build: + HOME=/nonexistant OCAMLFIND_DESTDIR=$(DEST) omake --config + +.PHONY: override_dh_auto_clean +override_dh_auto_clean: + HOME=/nonexistant omake clean + rm -f .omake* + find . -iname \*.omc -exec rm -f \{\} \; + find . -iname \*.annot -exec rm -f \{\} \; + rm -f doc/html/api/* + +.PHONY: override_dh_auto_install +override_dh_auto_install: + HOME=/nonexistant OCAMLFIND_DESTDIR=$(DEST) omake install diff --git a/source/format b/source/format new file mode 100644 index 0000000..46ebe02 --- /dev/null +++ b/source/format @@ -0,0 +1 @@ +3.0 (quilt) \ No newline at end of file diff --git a/watch b/watch new file mode 100644 index 0000000..1a9f12d --- /dev/null +++ b/watch @@ -0,0 +1,9 @@ +# See uscan(1) for format + +# Compulsory line, this is a version 3 file +version=3 + +# Uncomment to find new files on sourceforge, for debscripts >= 2.9 +http://sf.net/ocaml-reins/ocaml-reins-(.*)\.tar\.gz + + -- cgit v1.2.3 From 968a1f9030fb307f6f28dfe24b179f91c1769aa0 Mon Sep 17 00:00:00 2001 From: Mike Furr Date: Sat, 4 Jul 2009 14:48:29 +0200 Subject: Fix PREFIX handling Gbp-Pq: Name 0001-Fix-PREFIX-handling.patch --- config.omake | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/config.omake b/config.omake index 4417254..7a35fc2 100644 --- a/config.omake +++ b/config.omake @@ -7,7 +7,12 @@ static. = exit 1 OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) OCAMLDEP=$(OCAMLDEP_MODULES) - PREFIX=$(shell ocamlc -where) + if $(not $(defined PREFIX)) + PREFIX=$(shell ocamlc -where) + export + if $(defined-env OCAMLFIND_DESTDIR) + PREFIX = $(getenv OCAMLFIND_DESTDIR) + export VERSION=0.1a ConfMsgChecking(oUnit) OUNIT_DIR=$(shell ocamlfind query oUnit) -- cgit v1.2.3 From 17e65db7f58944a7c4be5da7c4a87149941a8292 Mon Sep 17 00:00:00 2001 From: Mike Furr Date: Sat, 4 Jul 2009 14:48:41 +0200 Subject: Install cmi Gbp-Pq: Name 0002-Install-cmi.patch --- src/OMakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/OMakefile b/src/OMakefile index 983799d..e85608c 100644 --- a/src/OMakefile +++ b/src/OMakefile @@ -52,5 +52,5 @@ REINS_CMX=$(if $(NATIVE_ENABLED), reins.cmx) install: META $(REINS_LIB) mkdir -p $(PREFIX)/reins - ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) \ + ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) reins.cmi \ $(filter-exists $(addsuffix .mli, $(FILES))) -- cgit v1.2.3 From cabcbf64279321f6a8da22a1c11104a4344180c1 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 30 Jan 2014 14:39:23 +0100 Subject: Fix test-suite with new oUnit This is a part of https://github.com/ocaml/opam-repository/blob/master/packages/reins/reins.0.1a/files/fix_build.patch Bug-Debian: http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=713499 Gbp-Pq: Name 0003-Fix-test-suite-with-new-oUnit.patch --- test/unit/OMakefile | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/test/unit/OMakefile b/test/unit/OMakefile index 565c83d..4ec66c9 100644 --- a/test/unit/OMakefile +++ b/test/unit/OMakefile @@ -1,9 +1,8 @@ TESTDIRS = list heap set map -OCAMLINCLUDES += \ - $(shell $(OCAMLFIND) query oUnit) \ - $(ROOT)/src +OCAMLPACKS [] = oUnit num +OCAMLINCLUDES += $(ROOT)/src FILES[] = test_helper @@ -17,7 +16,6 @@ FILES[] = OCAMLINCLUDES += $(TESTDIRS) OCAML_LIBS = $(ROOT)/src/reins -OCAML_OTHER_LIBS += str nums unix oUnit TEST_PROGRAM = $(OCamlProgram run_unit_tests, $(FILES)) unit_tests.results: $(TEST_PROGRAM) -- cgit v1.2.3 From 7fc3b8e2b16cc18f1361790ea44881ddadff72df Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 30 Jan 2014 14:54:58 +0100 Subject: Fix version in META This is a part of https://github.com/ocaml/opam-repository/blob/master/packages/reins/reins.0.1a/files/fix_build.patch Gbp-Pq: Name 0004-Fix-version-in-META.patch --- src/META.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/META.in b/src/META.in index 6cbc725..cbdb0a3 100644 --- a/src/META.in +++ b/src/META.in @@ -1,3 +1,3 @@ -version="0.1" +version="0.1a" archive(byte)="reins.cma" -archive(native)="reins.cmxa" \ No newline at end of file +archive(native)="reins.cmxa" -- cgit v1.2.3 From 472f888af08b1f9276a839f8cc081a08ae9c4fc6 Mon Sep 17 00:00:00 2001 From: Mehdi Dogguy Date: Fri, 16 Oct 2015 22:45:57 +0200 Subject: Fix FTBFS with OCaml 4.02.3 Gbp-Pq: Name 0005-Fix-FTBFS-with-OCaml-4.02.3.patch --- OMakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/OMakefile b/OMakefile index b741412..c5b6a4e 100644 --- a/OMakefile +++ b/OMakefile @@ -1,7 +1,7 @@ include config.omake -OCAMLFLAGS += -dtypes +OCAMLFLAGS += -dtypes -w +a-3-4-27-50-k .SUBDIRS: src doc -- cgit v1.2.3 From ca3d6fbbe636f6fa591aee8c9a80d57c2214ec7f Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 19 Jul 2017 09:48:26 +0200 Subject: Disable blocking warnings new in OCaml 4.05.0 Gbp-Pq: Name 0006-Disable-blocking-warnings-new-in-OCaml-4.05.0.patch --- OMakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/OMakefile b/OMakefile index c5b6a4e..4d15909 100644 --- a/OMakefile +++ b/OMakefile @@ -1,7 +1,7 @@ include config.omake -OCAMLFLAGS += -dtypes -w +a-3-4-27-50-k +OCAMLFLAGS += -dtypes -w +a-3-4-27-50-52-60-k .SUBDIRS: src doc -- cgit v1.2.3 From 4c0c5ed0ebb6a49330042ea6c6f570ee95e87056 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 19 Jul 2017 09:58:29 +0200 Subject: Use "include module type of" to avoid FTBFS with OCaml 4.05.0 Gbp-Pq: Name 0007-Use-include-module-type-of-to-avoid-FTBFS-with-OCaml.patch --- src/base/types.mli | 105 ++--------------------------------------------------- 1 file changed, 3 insertions(+), 102 deletions(-) diff --git a/src/base/types.mli b/src/base/types.mli index c5be9d9..f5e661c 100644 --- a/src/base/types.mli +++ b/src/base/types.mli @@ -294,38 +294,7 @@ end module Int32 : sig - val zero : int32 - val one : int32 - val minus_one : int32 - external neg : int32 -> int32 = "%int32_neg" - external add : int32 -> int32 -> int32 = "%int32_add" - external sub : int32 -> int32 -> int32 = "%int32_sub" - external mul : int32 -> int32 -> int32 = "%int32_mul" - external div : int32 -> int32 -> int32 = "%int32_div" - external rem : int32 -> int32 -> int32 = "%int32_mod" - val succ : int32 -> int32 - val pred : int32 -> int32 - val abs : int32 -> int32 - val max_int : int32 - val min_int : int32 - external logand : int32 -> int32 -> int32 = "%int32_and" - external logor : int32 -> int32 -> int32 = "%int32_or" - external logxor : int32 -> int32 -> int32 = "%int32_xor" - val lognot : int32 -> int32 - external shift_left : int32 -> int -> int32 = "%int32_lsl" - external shift_right : int32 -> int -> int32 = "%int32_asr" - external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" - external of_int : int -> int32 = "%int32_of_int" - external to_int : int32 -> int = "%int32_to_int" - external of_float : float -> int32 = "caml_int32_of_float" - external to_float : int32 -> float = "caml_int32_to_float" - external of_string : string -> int32 = "caml_int32_of_string" - val to_string : int32 -> string - external bits_of_float : float -> int32 = "caml_int32_bits_of_float" - external float_of_bits : int32 -> float = "caml_int32_float_of_bits" - type t = int32 - val compare : t -> t -> int - external format : string -> int32 -> string = "caml_int32_format" + include module type of Int32 val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Int32.t @@ -333,42 +302,7 @@ end module Int64 : sig - val zero : int64 - val one : int64 - val minus_one : int64 - external neg : int64 -> int64 = "%int64_neg" - external add : int64 -> int64 -> int64 = "%int64_add" - external sub : int64 -> int64 -> int64 = "%int64_sub" - external mul : int64 -> int64 -> int64 = "%int64_mul" - external div : int64 -> int64 -> int64 = "%int64_div" - external rem : int64 -> int64 -> int64 = "%int64_mod" - val succ : int64 -> int64 - val pred : int64 -> int64 - val abs : int64 -> int64 - val max_int : int64 - val min_int : int64 - external logand : int64 -> int64 -> int64 = "%int64_and" - external logor : int64 -> int64 -> int64 = "%int64_or" - external logxor : int64 -> int64 -> int64 = "%int64_xor" - val lognot : int64 -> int64 - external shift_left : int64 -> int -> int64 = "%int64_lsl" - external shift_right : int64 -> int -> int64 = "%int64_asr" - external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" - external of_int : int -> int64 = "%int64_of_int" - external to_int : int64 -> int = "%int64_to_int" - external of_float : float -> int64 = "caml_int64_of_float" - external to_float : int64 -> float = "caml_int64_to_float" - external of_int32 : int32 -> int64 = "%int64_of_int32" - external to_int32 : int64 -> int32 = "%int64_to_int32" - external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" - external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" - external of_string : string -> int64 = "caml_int64_of_string" - val to_string : int64 -> string - external bits_of_float : float -> int64 = "caml_int64_bits_of_float" - external float_of_bits : int64 -> float = "caml_int64_float_of_bits" - type t = int64 - val compare : t -> t -> int - external format : string -> int64 -> string = "caml_int64_format" + include module type of Int64 val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Int64.t @@ -376,40 +310,7 @@ end module Nativeint : sig - val zero : nativeint - val one : nativeint - val minus_one : nativeint - external neg : nativeint -> nativeint = "%nativeint_neg" - external add : nativeint -> nativeint -> nativeint = "%nativeint_add" - external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" - external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" - external div : nativeint -> nativeint -> nativeint = "%nativeint_div" - external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" - val succ : nativeint -> nativeint - val pred : nativeint -> nativeint - val abs : nativeint -> nativeint - val size : int - val max_int : nativeint - val min_int : nativeint - external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" - external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" - external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" - val lognot : nativeint -> nativeint - external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" - external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" - external shift_right_logical : nativeint -> int -> nativeint - = "%nativeint_lsr" - external of_int : int -> nativeint = "%nativeint_of_int" - external to_int : nativeint -> int = "%nativeint_to_int" - external of_float : float -> nativeint = "caml_nativeint_of_float" - external to_float : nativeint -> float = "caml_nativeint_to_float" - external of_int32 : int32 -> nativeint = "%nativeint_of_int32" - external to_int32 : nativeint -> int32 = "%nativeint_to_int32" - external of_string : string -> nativeint = "caml_nativeint_of_string" - val to_string : nativeint -> string - type t = nativeint - val compare : t -> t -> int - external format : string -> nativeint -> string = "caml_nativeint_format" + include module type of Nativeint val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Nativeint.t -- cgit v1.2.3