diff options
| author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
|---|---|---|
| committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
| commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
| tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/struct | |
| parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
| parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
| download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 | |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/struct')
225 files changed, 84661 insertions, 0 deletions
diff --git a/tcllib/modules/struct/ChangeLog b/tcllib/modules/struct/ChangeLog new file mode 100644 index 0000000..096ab45 --- /dev/null +++ b/tcllib/modules/struct/ChangeLog @@ -0,0 +1,2433 @@ +2013-10-21 Andreas Kupries <andreask@activestate.com> + + * matrix.tcl: [_columnwidth]: Recognize ANSI color control + * matrix.man: sequences and exclude them from the + * matrix.test: calculation. They are logically of no width and + * pkgIndex.tcl: thus their characters must not be counted when + determining a column's width. + +2013-03-26 Andreas Kupries <andreask@activestate.com> + + * pkgIndex.tcl: Fixed, was missing struct::queue version bump + causing mismatch. + +2013-03-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * queue.testsuite: [Bug 3608240]: Fixed get/peek not taking + * queue_oo.tcl: the amount of already delivered elements + * queue_tcl.tcl: into account. Extended testsuite. Bumped version + to 1.4.5 + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2013-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * queue.tcl: Rewritten, simplified. The 8.5 requisite means + * queue_oo.tcl: that we have extended requirement syntax allowing + * stack.tcl: us to jump the major version barrier without fuss. + * stack_oo.tcl: + +2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Fixed package require mismatch for use of TclOO + * queue.man: in Tcl 8.6+. This is TclOO v1 (major version change). + * queue.tcl: Now accepting 0.6.1+ and 1+. Versions bumped to + * queue_oo.tcl: 1.4.4 and 1.5.3 respectively. + * stack.man: + * stack.tcl: + * stack_oo.tcl: + +2012-12-07 Andreas Kupries <andreask@activestate.com> + + * list.tcl: [Bug 3593689]. Applied patch by Donal Fellows fixing + * list.test: a busyloop in [nextperm] due to use of the wrong + * pkgIndex.tcl: comparison operator. Bumped version to 1.8.2. + * struct_list.man: Added test for this. + +2012-11-21 Andreas Kupries <andreask@activestate.com> + + * pkgIndex.tcl: Fixed package require mismatch for use of TclOO. + * queue.man: Load check accepts anything, code restricts to 0.6.1. + * queue.tcl: Now both restrict to 0.6.1+. Versions bumped to + * stack.man: 1.4.3 and 1.5.2 respectively. + * stack.tcl: + +2012-07-09 Andreas Kupries <andreask@activestate.com> + + * tree/m.c (tm_ATTR): Fixed non-static string array used in call + of Tcl_GetIndexFromObj(). Memory smash waiting to happen. Thanks + to Brian Griffin for alerting us all to the problem. + +2012-06-22 Andreas Kupries <andreask@activestate.com> + + * queue.man: [Bug 3537006] Fixed typos. + +2012-01-08 Andreas Kupries <andreask@activestate.com> + + * struct_tree.man: [Bug 3471182] Fixed typo. + * struct_tree1.man: + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-09-17 Michael Schlenker <mic42@users.sourceforge.ner> + + * list.tcl: [Bug 3308051]: Fixed noncommutative equal check + * list.test: + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-10-26 Andreas Kupries <andreask@activestate.com> + + * graphops.man: [Bug 3090738]: Fixed typo in command names. + +2010-10-05 Andreas Kupries <andreask@activestate.com> + + * list.tcl (::struct::list::Lshuffle): New command, shuffling a + * list.test: list into random order. Bumped version to 1.8. + * struct_list.man: Extended testsuite, updated documentation. + * pkgIndex.tcl: Removed the backward compatibility implementation + of 'lset' from code and tests and bumped the runtime + requirements to Tcl 8.4. + +2010-09-10 Andreas Kupries <andreask@activestate.com> + + * queue_oo.tcl: Established minimum requirements for TclOO + * stack_oo.tcl: to support the two classes. Bug 3062782 was + a very old TclOO (0.3) interfering in the test. + +2010-09-09 Andreas Kupries <andreask@activestate.com> + + * graph/tests/ops/adjmatrix.test: Converted to tcltest v2 for + * graph/tests/ops/components.test: proper independence of the + * graph/tests/ops/componentof.test: tests. Preparation for + * graph/tests/ops/bipartite.test: the investigation of Bug + * graph/tests/ops/kruskal.test: 3062782. + * graph/tests/ops/prim.test: + * graph/tests/ops/tarjan.test: + +2010-05-25 Andreas Kupries <andreask@activestate.com> + + * queue.testsuite: Fixed bug in C implementation of 'unget'. + * queue/m.c: Used bogus variable in assert, hit only when trying + * ../tcllibc.tcl: to reuse a list Tcl_Obj for the unget + buffer. Tcllibc version bumped to 0.3.9. Testsuite extended. + +2010-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph/arcshimmer.c: Squash a number of warnings in the C + * graph/methods.c: implementations of graph, sets, and trees, + * graph/nodeshimmer.c: using casts, and including missing + * sets/s.c: headers. + * tree/m.c: + * tree/shimmer.c: + * tree/walk.c: + + * stack_oo.tcl: Remove superfluous 'package require'. Handled by + stack.tcl. + +2010-03-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * stack_oo.tcl: Tcl implementation of struct::stack based + * stack.tcl: on TclOO. Available in 8.5+TclOO, and 8.6+. + * stack.bench: Fixed missing dependency in benchmarks. + * stack.test: Updated tests (different error messages). + * stack.testsuite: Bumped version to 1.5.1. + * stack.man: + * pkgIndex.tcl: + + * queue_oo.tcl: Tcl implementation of struct::queue based + * queue.tcl: on TclOO. Available in 8.5+TclOO, and 8.6+. + * queue.bench: Updated and fixed benchmarks, and tests + * queue.test: (different error messages). Bumped version + * queue.testsuite: to 1.4.2. + * queue.man: + * pkgIndex.tcl: + + * sets.bench: Updated to allow switching of implementations. + +2010-03-16 Andreas Kupries <andreask@activestate.com> + + * pkgIndex.tcl: Fix version mismatch for struct::stack. + +2009-03-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * stack.man: struct::stack bumped to version 1.5. API extensions: + * stack.tcl: New methods getr, peekr, trim*. The first two return + * stack.test: their results in reversed order. For use in places + * stack.testsuite: which need the reverted order. As the regular + * stack/m.c: order requires an internal [lreverse], to be undone + * stack/m.h: by the caller it is better to simply avoid both + * stack/ms.c: [lreverse]s. Similarly, trim* does the trim, without + * stack/s.c: returning the trimmed items, for use where they are + * stack/s.h: thrown away anyway. ... Further, inlined the peek/pop + * stack_tcl.tcl: calls internal to get and trim, allowing + * pkgIndex.tcl: simplification of the resulting code, like + avoidance of additional argument checks. ... At last, now using + 8.5 features when detecting Tcl 8.5+ as our runtime ... I.e. + ensembles for the method dispatch instead of doing everything on + our own, with eval and uplevel. Result: The speed of the Tcl + implementation roughly doubles. + + * stack.bench: Updated to use the ability to switch between the + various implementations. + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-11-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph_tcl.tcl: Fixed mismatches due to the 2009-11-03 change. + * graph/tests/command.test: + + * pkgIndex.tcl: Extended struct::stack with convenience methods + * stack.man: 'get' and 'trim', to get whole stack, and alternate + * stack.tcl: argument specification of 'pop'. Bumped version to + * stack_tcl.tcl: 1.4. Bumped the tcllibc umbrella package to + * stack.testsuite: version 0.3.7. + * stack/m.c: version + * stack/m.h: + * stack/ms.c: + * stack/ms.h: + * stack/s.c: + * stack/s.h: + +2009-11-03 Andreas Kupries <andreask@activestate.com> + + * graph/tests/XOpsSetup: [Bug 2811747]: Removed the import of + * graph/tests/Xsetup: command struct::graph into the global + * graph/tests/Xsupport: namespace in the testsuite, and updated + * graph/tests/arcs.test: all users. This prevents the masking + * graph/tests/command.test: of scope errors in the graph::op + * graph1.test: package when its testsuite is run. + +2009-09-24 Andreas Kupries <andreask@activestate.com> + + * list.test: [Bug 2557046]: Updated the testsuite to for changes + to lassign and lrepeat in 8.6 (do nothing gracefully, and + changes to error messages). Affected tests are either skipped or + get conditional results. + + * tree.testsuite (tree-*-1.8): Pattern match the name, do not + expect a particular id number (Depends on which previous tests + have run, especially in graphops). + +2009-09-24 Andreas Kupries <andreask@activestate.com> + + * The integration of Michal Antoniewski's (<antoniewsli@gmail.com>) + work on graph operations for GSoC 2009 is now complete, with all + testsuites integrated and fixed up to handle both Tcl and C + implementations of struct::graph, tree, set, etc., and some bugs + uncovered by this work fixed as well. + + * graphops.tcl (::struct::graph::op::WeightedKCenter): Fixed + * graphops.man: object leak. Added the missing release of the + * pkgIndex.tcl: Gi(SQ) in error case (no solution). Bumped + * graphops.test: version to 0.11.3. Tweaked comment in testsuite + regarding repetition. + + * graph/tests/XOpsControl: Added testsuite for weighted k-center. + * graph/tests/ops/weightedkcenter.test: Testsuite for weighted k-center. + Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Several tests demonstrates how the result is influenced by + node/arc ordering. Extended to accept the variations. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + * graph/tests/ops/kcenter.test: Moved the custom matcher/verifier for + * graph/tests/XOpsSupport: max-independent-set to shared file. + * graph/tests/XOpsSetup: Simplified some setup procedures a bit. + + * graphops.tcl (::struct::graph::op::MaximumFlowByDinic): Fixed + * graphops.man: object leak. Added the missing release of the + * pkgIndex.tcl: residual graph generated in each iteration. Bumped + version to 0.11.2. + + * graph/tests/XOpsControl: Added testsuite for Dinic Maximum Flow. + * graph/tests/ops/dinicmaximumflow.test: Testsuite for Dinic Maximum + Flow. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Added dictsort to force a canonical ordering on the + results. + - Results updated to be in the canonical ordering. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + + * graphops.man: [Bug 2800387]: Updated descriptions of Kruskal and + Prim with time complexity information, tweaked terminology a bit + (minimum _weight_ spanning tree), and noted the exceptional + handling of 1-vertex components (they are not shown in the + results). + + * graph.man: Added method 'arc nodes' to the Tcl and C + * graph.tcl: implementations. Extended testsuite and + * graph_tcl.tcl: documentation. Bumped package to + * graph/methods.c: version 2.4. Bumped the tcllibc + * graph/objcmd.c: umbrella package to version 0.3.6. + * graph/tests/arc/nodes.test: + * graph/tests/command.test: + * graph/tests/Xcontrol: + * pkgIndex.tcl: + * ../tcllibc.tcl: + +2009-09-23 Andreas Kupries <andreask@activestate.com> + + * graphops.tcl (::struct::graph::op::MinimumDegreeSpanningTree): + Stop search+insertion loop after it has added the candidate + arc. (::struct::graph::op::MinimumDiameterSpanningTree): Fix two + object leaks. + + * graph/tests/XOpsControl: Added testsuite for Min D Spanning Trees. + * graph/tests/ops/mdst.test: Testsuite for MDST. + Blocking Flow. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Added undirected to force a canonical ordering on the + results. + - Results updated to be in the canonical ordering. + - Several tests demonstrates how the result is influenced by + node ordering. Extended to accept the variations. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + + * graphops.tcl (::struct::graph::op::BlockingFlowByMKM): Fixed + * graphops.man: object leak. Added the missing release of the + * pkgIndex.tcl: LevelGraph on exceptional return (No path between + nodes s and t). Bumped version to 0.11.1. + + * graph/tests/XOpsControl: Added testsuite for MKM Blocking Flow. + * graph/tests/ops/mkmblockingflow.test: Testsuite for MKM + Blocking Flow. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Added dictsort to force a canonical ordering on the + results. + - Results updated to be in the canonical ordering. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + +2009-09-22 Andreas Kupries <andreask@activestate.com> + + * graph/tests/XOpsControl: Added testsuite for Dinic Blocking Flow. + * graph/tests/ops/dinicblockingflow.test: Testsuite for Dinic + Blocking Flow. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Added dictsort to force a canonical ordering on the + results. + - Results updated to be in the canonical ordering. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + + * graph/tests/XOpsControl: Added testsuite for k-center. + * graph/tests/ops/kcenter.test: Testsuite for k-center. + Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Several tests demonstrates how the result is influenced by + node ordering. Extended to accept the variations. + - Custom matcher/verifier for max-independent-set. + Note: SETUP_KCENTER_1 is not creating a complete graph, + violating the pre-conditions of the algorithm. This affects test + cases 1.3 - 1.6, it is not clear if their results are correct in + general. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + * graph/tests/XOpsSetup: Re-indented, some notes added, loop + conditions tweaked. + + * graph/tests/XOpsControl: Added testsuite for vertex cover. + * graph/tests/ops/verticescover.test: Testsuite for vertex cover. + Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Several tests demonstrates how the result is influenced by + node ordering. Extended to accept the variations. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + +2009-09-21 Andreas Kupries <andreask@activestate.com> + + * graph/tests/XOpsControl: Added the testsuites for metrictsp, + christofides and tspheuristics. + * graph/tests/ops/metrictsp.test: Testsuite for metrictsp. + * graph/tests/ops/christofides.test: Testsuite for christofides. + * graph/tests/ops/tspheuristics.test: Testsuite for tspheuristics. + Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - Conversion to v2 syntax, and cleanup of resource handling. + - Updated results for different implementations, sorting. + + * graph/tests/XOpsSetup (SETUP_TSPHEURISTIC_1): Fixed growing + cycle list throwing of repeated execution of the same test. + + * graph/tests/Xsupport: Added helper commands for the test cases + of the various metric tsp commands (canonical tours, ...). + + * graph/tests/Xsetup (tmSE): Added result selection based on + implementation of struct::set. + + * graphops.tcl (::struct::graph::op::MetricTravellingSalesman): + Fixed problem in algorithm for asymmetric TSP, selecting the + tour in the wrong (higher-weight) direction. The Fleury + underneath does not care about arc direction. + (::struct::graph::op::Christofides): Dropped superfluous + variable and fixed M+T operation. The matching does not care + about arc direction, and we have insert anti-parallel arcs to + avoid any existing. + (::struct::graph::op::isEulerian?): Extended API to return + tour start. Computable from the arcs, but not easy. Better to get + it from the algorithm which knows by definition. + (::struct::graph::op::findHamiltonCycle): Get tour start from + isEulerian, and drop bogus computation from the tour arcs. + (::struct::graph::op::createTGraph): Moved graph creation after + error check to avoid a leak when the check fails. + * graphops.man: Bumped version to 0.11 + * pkgIndex.tcl: (isEulerian API extension, plus bugfixes). + +2009-09-17 Andreas Kupries <andreask@activestate.com> + + * queue/m.c (qum_PEEK): Convert C99/C++ comment to C89 + comment. Some unix compilers, like AIX are strict C89 and fail + on this. + +2009-09-16 Andreas Kupries <andreask@activestate.com> + + * graph/tests/XOpsControl: Added testsuite for maxcut. + * graph/tests/ops/maxcut.test: Testsuite for maxcut. + Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Indentation, line-endings + - test 1.4 demonstrates not only how the heuristic can run into + local optimum, but also how the result is influenced by node + ordering, critcl implementation gives optimal solution + instead, now accepted. + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + + * graphops.tcl: Fixed indentation, and removed trailing + whitespace. + + * graph/tests/XOpsControl: Added testsuite for BFS. + * graph/tests/ops/bfs.test: Testsuite for breadth-first + search. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Added dictsort and lsort to force a canonical ordering on + results. Where sorting was not possible we provide the two + valid results for Tcl and Critcl implementations. + - Results updated to be in the canonical ordering. + - Indentation, line-endings + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + +2009-09-15 Andreas Kupries <andreask@activestate.com> + + * graph/tests/XOpsControl: Added new testsuites. + + * graph/tests/ops/busackergowen.test: Changes like for + edmondskarp.test, i.e. equivalent data leakage bugs (1.4-1.6). + + * graph/tests/ops/edmondskarp.test: Ditto, plus conversion of a + few tests to tcltest v2 form, to make the setup and cleanup of + resources more explicit, fixing data leakage between tests + (FF-1.5-1.9), and fixing test results of these. First actual bug + fixes. + + * graph/tests/ops/adjlist.test: Ditto, except this one is using a + custom sorting command. + + * graph/tests/ops/floydwarshall.test: Ditto. + * graph/tests/ops/johnsons.test: Ditto. + + * graph/tests/ops/bellmanford.test: New testsuite for bellman-ford + algorithm. Changes compared to GSoC result: + - Test names extended with 'treeimpl'. + - Added dictsort to force a canonical ordering on the + results. + - Results updated to be in the canonical ordering. + - Indentation, line-endings + This passes the testsuite for both tcl and critcl + implementations of struct::graph. + + * graphops.tcl: Starting on the integration of Michal + * graphops.man: Antoniewski's (<antoniewsli@gmail.com>) work on + * graphops.test: graph operations for GSoC 2009. Added all + * graphops.man: operations, and their documentation. Version + * graphops.tcl: bumped to 0.10. The graphops package now requires + * graphops.test: Tcl 8.5. The testsuite requires tcltest v2. + * pkgIndex.tcl: Extended setup commands for upcoming new tests. + * graph/tests/XOpsSetup: The package and tests now require + * graph/tests/ops/adjmatrix.test: struct::tree, another package + * graph/tests/ops/bipartite.test: with acceleration via critcl. + * graph/tests/ops/bridge.test: Testsuite updated to switch its + * graph/tests/ops/componentof.test: implementations well. The + * graph/tests/ops/components.test: testsuites for the new + * graph/tests/ops/connected.test: commands will be added + * graph/tests/ops/cutvertex.test: incrementally over the next + * graph/tests/ops/diameter.test: days. + * graph/tests/ops/dijkstra.test: + * graph/tests/ops/distance.test: + * graph/tests/ops/eccentricity.test: + * graph/tests/ops/eulerpath.test: + * graph/tests/ops/eulertour.test: + * graph/tests/ops/kruskal.test: + * graph/tests/ops/maxmatching.test: + * graph/tests/ops/prim.test: + * graph/tests/ops/radius.test: + * graph/tests/ops/tarjan.test: + +2009-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph/filter.c: Fixed bug in 'arcs -adj' implementation. Wrong + * graph/tests/arcs.test: range check. Extended testsuite. Bumped + * ../tcllibc.tcl: version of tcllibc containing this fix to 0.3.5. + + * graphops.tcl: Destroy internal temporary object on internal + * graphops.man: error. Bumped version to 0.9.2. + * pkgIndex.tcl: + + * graph/tests/ops/eulerpath.test: Converted to tcltest v2 form. + + * graph/tests/XOpsControl: Added sourcing of the support code + needed when the graphops testsuite is run standalone. + +2009-07-10 Andreas Kupries <andreask@activestate.com> + + * graphops.tcl (::struct::graph::op::TarjanSub): + * graphops.tcl (::struct::graph::op::isCutVertex?): + * graphops.tcl (::struct::graph::op::Fleury): + * pkgIndex.tcl: Fixed [Bug 2815302]. Replaced a number of uses of + * graphops.man: struct::set subtract' with the proper 'struct::set + exclude', as these places remove a single element, not a + set. Use of the wrong method then breaks the code if elements + (node/arc names) with whitespace in them is used. Bumped version + to 0.9.1. + +2009-06-22 Andreas Kupries <andreask@activestate.com> + + * tree_tcl.tcl (::struct::tree::_swap): Removed code which flipped + the attributes around. This is wrong. They stay with their + nodes, per the node name. Thanks to Tom Krehbiel for the report. + + * tree.testsuite : Extended with a test for method swap which + checks that the attributes of the nodes are handled correctly. + + * pkgIndex.tcl: Bumped to version 2.1.2. + * tree.tcl: + +2009-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Fixed typo. + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph_tcl.tcl (::struct::graph::_walk): Fixed post-order dfs + * graph/tests/walk.test: problem [Bug 2420330] in Tcl side. + * pkgIndex.tcl: Extended testsuite. Bumped to version 2.3.1 + +2008-11-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph1.test: Cleanup to avoid interference with the accelerators + * graphops.test: of graph v2. Bring in the accelerators for queues + * graph/tests/ops/adjmatrix.test: and stacks. Fixed bug in tarjan + * graph/tests/ops/bipartite.test: exposed by the accelerator (*). + * graph/tests/ops/bridge.test: (*) Changed order of arc traversal. + * graph/tests/ops/componentof.test: + * graph/tests/ops/components.test: + * graph/tests/ops/connected.test: + * graph/tests/ops/cutvertex.test: + * graph/tests/ops/diameter.test: + * graph/tests/ops/dijkstra.test: + * graph/tests/ops/distance.test: + * graph/tests/ops/eccentricity.test: + * graph/tests/ops/eulerpath.test: + * graph/tests/ops/eulertour.test: + * graph/tests/ops/kruskal.test: + * graph/tests/ops/maxmatching.test: + * graph/tests/ops/prim.test: + * graph/tests/ops/radius.test: + * graph/tests/ops/tarjan.test: + + * graphops.tcl: Near-completed integration of graph algorithms. + * graphops.man: Node distances, eccentricity, radius, diameter. + * graph/tests/ops/distance.test: Bumped package version to 0.9. + * graph/tests/ops/radius.test: Disabled the placeholders for max- + * graph/tests/ops/diameter.test: matching, the only algorithm we + * graph/tests/ops/eccentricity.test: are missing. + * graph/tests/XOpsControl: + * pkgIndex.tcl: + +2008-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. Node + * graphops.man: distances, dijkstra's algorithm. Bumped the + * graph/tests/ops/dijkstra.test: package version to 0.8. + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * pkgIndex.tcl: + +2008-11-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. Euler + * graphops.man: paths and tours. Bumped the package version + * graph/tests/ops/eulertour.test: to 0.7. + * graph/tests/ops/eulerpath.test: + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * graph/tests/XOpsSupport: + * pkgIndex.tcl: + +2008-11-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. More + * graphops.man: about connectivity. Bumped the package version + * graph/tests/ops/connected.test: to 0.6. + * graph/tests/ops/cutvertex.test: + * graph/tests/ops/bridge.test: + * graph/tests/XOpsControl: + * pkgIndex.tcl: + +2008-11-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. + * graphops.man: Connected components. Bumped package version + * graph/tests/ops/components.test: to 0.5. + * graph/tests/ops/componentof.test: + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * graph/tests/XOpsSupport: + * pkgIndex.tcl: + +2008-11-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. + * graphops.man: SCCs via Tarjan. Placeholder for max matching. + * graph/tests/ops/tarjan.test: Bumped version to 0.4. + * graph/tests/ops/maxmatching.test: + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * graph/tests/XOpsSupport: + * pkgIndex.tcl: + +2008-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. + * graphops.man: Test for bipartite graph. Bumped version + * graph/tests/ops/bipartite.test: to 0.3 + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * graph/tests/XOpsSupport: + * pkgIndex.tcl: + +2008-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. + * graphops.man: Minimum spanning tree/forest as per Prim. + * graph/tests/ops/prim.test: Bumped version to 0.2 + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + * pkgIndex.tcl: + +2008-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Continued integration of graph algorithms. + * graphops.man: Minimum spanning tree/forest as per Kruskal. + * graph/tests/ops/kruskal.test: + * graph/tests/XOpsControl: + * graph/tests/XOpsSetup: + +2008-11-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graphops.tcl: Starting on the integration of Alejandro Paz's + * graphops.man: (<vidriloco@gmail.com>) work on graph operations + * graphops.test: for GSoC 2008. First operation: Adjacency matrix. + * pkgIndex.tcl: + * graph/test/XOpsControl: + * graph/test/XOpsSetup: + * graph/test/XOpsSupport: + * graph/test/ops/adjmatrix.test: + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph/graph.c (dup): Fixed duplication of an empty graph, mis- + * graph/tests/command.test: handled the re-chaining of the node- + list in the source. Added test for this case. + +2008-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph/graph.c (dup): Fixed missing propagation of arc weights. + * graph/tests/command.test: Added test for graph assignment with + weights. + +2008-10-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.man: Extended graphs with the ability to define arc + * graph.tcl: weights. Added methods to query and manipulate weight + * graph_tcl.tcl: information. Extended the serialization format to + * pkgIndex.tcl: handle graphs with and without arc weights. + * graph/arc.c: Implemented in both Tcl and C. The Tcl code is + * graph/ds.h: derived from Alejandro Paz's (<vidriloco@gmail.com>) + * graph/methods.c: work during GSoC 2008. Extended testsuite and + * graph/methods.h: documentation. The package now requires Tcl 8.4 + * graph/objcmd.c: for operation. Bumped the package version to 2.3. + * graph/tests/Xcontrol: + * graph/tests/arc/getunweighted.test: + * graph/tests/arc/getweight.test: + * graph/tests/arc/hasweight.test: + * graph/tests/arc/setunweighted.test: + * graph/tests/arc/setweight.test: + * graph/tests/arc/unsetweight.test: + * graph/tests/arc/weights.test: + * graph/tests/command.test: + * graph/tests/deserialize.test: + * graph/tests/serialize.test: + * graph/tests/Xsupport: + +2008-09-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * disjointset.man: Added a modified form of the disjoint-set class + * disjointset.tcl: created by Alejandro Paz <vidriloco@gmail.com> + * disjointset.test: for the Google Summer Of Code 2008. Version 1.0. + * disjointset.testsuite: + * pkgIndex.tcl: + +2008-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * prioqueue.man: Extended with a 'remove' method for the + * prioqueue.tcl: deletion of items from queues before their + * prioqueue.test: time comes up with 'get'. Bumped version + * pkgIndex.tcl: to 1.4. Code originally by Alejandro Paz + <vidriloco@gmail.com> for GSoC 2008, with modifications by + myself to make the item search more efficient. + +2008-09-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.testsuite: Updated tests based on walk error stack traces + to handle new differences between 8.4 and 8.5. + + * tree.testsuite.4417b84.txt: Moved the stacktraces to separate files + * tree.testsuite.4417=84tcl.txt: for better readability of both the + * tree.testsuite.4417a84tcl.txt: traces and the test using it. + * tree.testsuite.4417a83critcl.txt: + +2008-08-12 Michael Schlenker <mic42@users.sourceforge.net> + + * graph1.tcl: Removed reference to the cgraph download. + * graph1.man: Its no longer available from that site, + and there is currently no replacement site. Newer + code should use graph 2 with the critcl accelerators. + +2008-07-11 Andreas Kupries <andreask@activestate.com> + + * list.tcl (::struct::list::Ldelete): Added a 'delete' command + * struct_list.man: for removing of elements from a list by name + * list.test: Bumped version to 1.7. + * pkgIndex.tcl: + +2008-07-03 Andreas Kupries <andreask@activestate.com> + + * queue/m.c: Separated qdump from queue_debug mode. + * queue/util.h: Brought all assert macros in line with the + * stack/util.h: definitions provided to graph (which print + * tree/util.h: file/line information). Also activated assertions + throughout for regular build. + +2008-07-02 Andreas Kupries <andreask@activestate.com> + + * queue.tcl: Changed core queue code to support multiple + * queue_tcl.tcl: implementations, and Tcl implementation. Bumped + * queue.man: to version 1.4.1. Updated documentation to mention + * pkgIndex.tcl: the critcl implementation, version number, + etc. Reworked the Tcl implementation as well for speed (split + buffer, indexing, avoid memcopies, K-operator). + + * queue_c.tcl: Critcl based implementation of queues. + * queue/ds.h: + * queue/m.c: + * queue/m.h: + * queue/q.c: + * queue/q.h: + + * queue.testsuite: Reworked the testsuite to handle both Tcl and + * queue.test: critcl implementations. + +2008-06-19 Andreas Kupries <andreask@activestate.com> + + * stack.tcl: Changed core stack code to support multiple + * stack_tcl.tcl: implementations, and Tcl implementation. Bumped + * stack.man: to version 1.3.3. Updated documentation to mention + * pkgIndex.tcl: the critcl implementation, version number, etc. + + * stack_c.tcl: Critcl based implementation of stacks. + * stack/ds.h: + * stack/m.c: + * stack/m.h: + * stack/s.c: + * stack/s.h: + + * stack.testsuite: Reworked the testsuite to handle both Tcl and + * stack.test: critcl implementations. + +2008-06-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * stack.bench: New file, added benchmarks for stack objects. + * stack.tcl: Rewrites of various commands for speed, using K + * pkgIndex.tcl: operator etc. Bumped to version 1.3.2. + * stack.man: + +2008-03-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph/tests/nodes.test: Extended with tests to capture the + situation of [Bug 1923685]. They properly crash without the fix + and pass when the fix is applied. + + * graph/util.h (ASSERT): Extended to reported the asserted expression, + and the file and line the assert is at. + + * graph/filter.c (filter_mode_n_in, filter_mode_n_out): Fixed bug + in checking for duplicate nodes. Allowed dups to remain, causing + parallel arcs more than the number of total nodes to trigger the + overrun assertion. Reported as [Bug 1923685] by Georgios Petasis + <petasis@users.sourceforge.net>. Thanks. + +2008-03-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets_tcl.tcl (::struct::set::S_subtract,::struct::set::S_exclude): + * sets.testsuite: Added an explicit check for the existence of the + variable so that we can report the actual name of the missing + variable instead of the name internally used by the + implementation. Modified the relevant testcases to use a + variable name different from the internal name to expose this + properly. This should fix [Bug 1680176]. + + * sets/m.c (sm_ADD): Brought the behaviour of method 'add' back + * sets.testsuite: into line with the behaviour of 'include', + * sets.tcl: i.e. create a missing variable, in both Tcl and critcl + * struct_set.man: implementations. Updated the relevant tests as + * pkgIndex.tcl: well. See changelog entry 2006-01-30 as well, + and [SF Tcllib Bug 1414051]. Bumped version to 2.2.3. + + * sets/m.c (sm_INCLUDE): Replaced bogus TCL_LEAVE_ERR_MSG when + * sets.testsuite: checking for variable existence, as the variable + is created if missing. In contrast to exclude/subtract which + require the variable to exist. This is likely a copy/paste + error. The bogus error message was returned as the result of the + command, not an error trace, but could be mistaken for it in + interactive use. This fixes [Bug 1908098] reported by Stephane + Jeanjean <sjeanjean@users.sourceforge.net>. Testsuite extended. + +2008-03-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets.test: Updated tests to have error messages in line with the + * graph/tests/Xsetup: 8.5 core. + * graph/tests/attr/append.test: + * graph/tests/attr/get.test: + * graph/tests/attr/getall.test: + * graph/tests/attr/keyexists.test: + * graph/tests/attr/keys.test: + * graph/tests/attr/lappend.test: + * graph/tests/attr/set.test: + * graph/tests/attr/unset.test: + +2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.test: Updated tests to have error messages in line with the + * list.tcl: 8.5 core. Added light comments to make separation of + 8.4 and 8.5+ clear. This fixes the SF Tcllib Bugs [1897846] + and [1897848] (and their duplicates). + +2008-02-14 Andreas Kupries <andreask@activestate.com> + + * matrix.tcl: Changed uses of abbreviated '-regex' in switch + * pkgIndex.tcl: commands to the full option, '-regexp'. Bumped + version to 2.0.2. + +2008-01-28 Andreas Kupries <andreask@activestate.com> + + * sets_tcl.tcl (::struct::set::Cleanup): Fixed handling of set + * sets.testsuite: elements looking like namespace variable + * sets.test: names. They break our hack of using the proc-local + * sets.tcl: var hashtable. We have to use an explicit + * pkgIndex.tcl: array. Updated the testsuite to use such + * struct_set.man: elements. Bumped version to 2.2.2. + +2008-01-28 Andreas Kupries <andreask@activestate.com> + + * graph_c.tcl: Disabled the critcl::debug and critcl::cheaders -g + * sets_c.tcl: definitions. + * tree_c.tcl: + +2007-09-19 Andreas Kupries <andreask@activestate.com> + + * list.tcl (::struct::list::Lpermutations): Fixed use of + unqualified 'list' command for case of 1-element list. This + fixes [SF Tcllib Bug 1798337]. Thanks to Glenn Jackman + <glennjnn@users.sourceforge.net> for both report and fix. + * pkgIndex.tcl: Version bumped to 1.6.2. Extended the + * struct_list.man: testsuite with a test for this case. + * list.test: + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-29 Andreas Kupries <andreask@activestate.com> + + * tree.testsuite: Simplified constraint definition, we now have a + standard syntax (backward compat def for tcltest 1.0 in the + devtools/testutilities.tcl). + + * sets.testsuite: Added a test demonstrating a shimmering problem + in the C implementation of struct::set (handling of pure list + values is bad). + + * sets/s.c: Fixed the bug demonstrated by the new test, see + * pkgIndex.tcl: above. Version of package bumped to 2.2.1. Version + of tcllibc bumped to 0.3.2. + +2007-08-22 Andreas Kupries <andreask@activestate.com> + + * struct_list.man: Fixed example for 'filterfor', removed the + bogus 'expr' layer. The command runs 'expr' itself. This fixes + [SF Tcllib Bug 1779424]. + +2007-08-03 Andreas Kupries <andreask@activestate.com> + + * sets.test (Nothing): Updated to changes in reporting of errors + with alias commands in 8.5. + +2007-05-16 Kevin B. Kenny <kennykb@acm.org> + + * list.tcl (LlcsInvertMerge2): Fixed a bug where incorrect + "unchanged" entries were generated on a merged list. + * list.test (lcsInv-4.2,lcsInv-4.3): Corrected the test cases + because they were expecting incorrect results from + the above bug. [Bug 1720331] + * pkgIndex.tcl: Advanced version number of 'struct::list' to 1.6.1 + +2007-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl: Renamed various commands handling accelerators. This + brought their names into compliance with the requirements of the + 'TestAccel*' commands in devtools. + + * sets.tcl: Fixed use of KnownImplementations missed by last + change. + +2007-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets.tcl: Renamed various commands handling accelerators. This + brought their names into compliance with the requirements of the + 'TestAccel*' commands in devtools. + + * sets.test: Rewritten to use the 'TestAccel*' convenience + commands. + + * tree.test: Rewritten to use the 'TestAccel*' convenience + commands. Additionally moved the helper commands into a new, + separate file + + * tree/tests/Xsupport: New file now containing the helper commands + for testing struct::tree. + + * graph.test: Rewritten to make use of 'useAccel'. + + * graph.test: The testsuite already switches various + * graph/tests/arcs.test: implementations of struct::graph. Added + * graph/tests/assign.test: the switching of struct::set + * graph/tests/command.test: implementations. + * graph/tests/deserialize.test: + * graph/tests/nodes.test: + * graph/tests/rassign.test: + * graph/tests/serialize.test: + * graph/tests/swap.test: + * graph/tests/walk.test: + * graph/tests/arc/attr.test: + * graph/tests/arc/delete.test: + * graph/tests/arc/exists.test: + * graph/tests/arc/flip.test: + * graph/tests/arc/insert.test: + * graph/tests/arc/move-source.test: + * graph/tests/arc/move-target.test: + * graph/tests/arc/move.test: + * graph/tests/arc/rename.test: + * graph/tests/arc/source.test: + * graph/tests/arc/target.test: + * graph/tests/attr/append.test: + * graph/tests/attr/get.test: + * graph/tests/attr/getall.test: + * graph/tests/attr/keyexists.test: + * graph/tests/attr/keys.test: + * graph/tests/attr/lappend.test: + * graph/tests/attr/set.test: + * graph/tests/attr/unset.test: + * graph/tests/node/attr.test: + * graph/tests/node/degree.test: + * graph/tests/node/delete.test: + * graph/tests/node/exists.test: + * graph/tests/node/insert.test: + * graph/tests/node/opposite.test: + * graph/tests/node/rename.test: + +2007-03-26 Andreas Kupries <andreask@activestate.com> + + * struct_tree.man: Documentation improvements as suggested by Lars + * struct_tree1.man: Bergstrom ([Bug 1687902]). + +2007-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.man: Fixed all warnings due to use of now + * graph1.man: deprecated. Added a section about how + * matrix.man: to give feedback. + * matrix1.man: + * pool.man: + * prioqueue.man: + * queue.man: + * record.man: + * skiplist.man: + * stack.man: + * struct_list.man: + * struct_set.man: + * struct_tree.man: + * struct_tree1.man: + +2007-02-27 Andreas Kupries <andreask@activestate.com> + + * sets/s.c (from_any): Crashing bug in the Critcl implementation + of 'struct::set'. Remembered the old object type X in the + from_any conversion function, then converted to type 'list', and + at the end tried to release the list using the freeintrep + function of type X instead of type 'list'. Fixed by moving the + code to remember the type after the conversion to a 'list'. + +2007-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.tcl: pragma/hint for md generator. + +2007-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets.bench: Added more benchmarks, add/include, + subtract/exclude, equality. + + * sets/m.c: Rewrote sm_ADD, inlined s_add to enable us to defer + set duplication until the set actually changes. This also + ensures that the string-rep is invalidated only in cvase of a + true change. Ditto rewrites of sm_INCLUDE, sm_SUBTRACT, and + sm_EXCLUDE. + +2007-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_set.man: Updated documentation to mention the critcl + implementation, version number, etc. + + * pkgIndex.tcl: Version of sets bumped to 2.2. + + * sets.bench: New, benchmarks for set operations, incomplete. + + * sets.tcl: Changed core sets code to support multiple + * sets_tcl.tcl: implementations, and Tcl implementation. + + * sets_c.tcl: Critcl based implementation of sets. + * sets/ds.h: + * sets/m.c: + * sets/m.h: + * sets/s.c: + * sets/s.h: + + * sets.testsuite: Reworked the testsuite to handle both Tcl and + * sets.test: critcl implementations. + +2006-11-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Version of graph bumped to 2.2. + + * graph.man: Updated documentation for new features, extended + abilities, critcl implementation, etc. + + * graph.tcl: Changed core graph code to support multiple + * graph_tcl.tcl: implementations, and Tcl implementation. Added + some more features (arc|node delete multiple nodes, insertion of + multiple nodes, flipping the direction of arcs), internal + refactoring of common argument checks, additional checks closing + some holes. + + * graph_c.tcl: Critcl based implementation of graph. + * graph/arc.c: + * graph/methods.c: + * graph/ds.h: + * graph/node.c: + * graph/objcmd.h: + * graph/attr.c: + * graph/arcshimmer.c: + * graph/objcmd.c: + * graph/arc.h: + * graph/filter.c: + * graph/methods.h: + * graph/util.c: + * graph/util.h: + * graph/node.h: + * graph/graph.h: + * graph/graph.c: + * graph/nacommon.c: + * graph/walk.c: + * graph/walk.h: + * graph/global.h: + * graph/nodeshimmer.c: + * graph/attr.h: + * graph/global.c: + * graph/nacommon.h: + + * graph.test: Reworked testsuite, split into about one file per + * graph/tests/Xsetup: tested method, plus helper and control + * graph/tests/arc/delete.test: files. Extended testsuite testing + * graph/tests/arc/exists.test: several of the holes which were + * graph/tests/arc/flip.test: closed and had never been tested + * graph/tests/arc/insert.test: before. + * graph/tests/arc/move.test: + * graph/tests/arc/move-source.test: + * graph/tests/arc/move-target.test: + * graph/tests/arc/rename.test: + * graph/tests/arc/source.test: + * graph/tests/arc/target.test: + * graph/tests/arc/attr.test: + * graph/tests/attr/get.test: + * graph/tests/attr/getall.test: + * graph/tests/attr/keyexists.test: + * graph/tests/attr/keys.test: + * graph/tests/attr/lappend.test: + * graph/tests/attr/set.test: + * graph/tests/attr/unset.test: + * graph/tests/attr/append.test: + * graph/tests/attr/Xsetup: + * graph/tests/node/degree.test: + * graph/tests/node/delete.test: + * graph/tests/node/exists.test: + * graph/tests/node/insert.test: + * graph/tests/node/rename.test: + * graph/tests/node/opposite.test: + * graph/tests/node/attr.test: + * graph/tests/walk.test: + * graph/tests/Xsupport: + * graph/tests/Xcontrol: + * graph/tests/arcs.test: + * graph/tests/nodes.test: + * graph/tests/deserialize.test: + * graph/tests/assign.test: + * graph/tests/serialize.test: + * graph/tests/command.test: + * graph/tests/rassign.test: + * graph/tests/swap.test: + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-27 Andreas Kupries <andreask@activestate.com> + + * list.test: Fixed expected error message for 8.5. + [SF Tcllib Bug 1566439]. + +2006-09-19 Andreas Kupries <andreask@activestate.com> + + * struct_set.man: Bumped versions to 2.1.1 + * sets.tcl: + * struct_tree.man: + * tree.tcl: + * pkgIndex.tcl: + +2006-09-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree/tn.c (tn_leaf): Fixed mangling of the list of leaves when + trying to add a node which is already in the list. Tracked down + with valgrind and instrumentation due intermittent failure of + treeql testsuite (seg fault). + (tn_new): Added initialization of list pointers to allow + checking by "tn_leaf". + + * tree/t.c (t_dump): Added function to dump the internal linkage + of nodes. Not used by regular code. For debugging. + +2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: Fixed the new tests for the arc move method. They + used hardcoded wrong#args messages. Now the proper the + compatibility commands are in place. + +2006-07-27 Andreas Kupries <andreask@activestate.com> + + * tree/t.c (t_newnodename): Fixed bug [SF TCllib Bug 1528614], + * tree/tn.c (tn_new): reported by Helmut Giese + * tree.testsuite: <hgiese@users.sourceforge.net>. + Auto-generation of node names was able to generate + duplicates. Now it checks new handles for existence. Also added + a check to the function doing actual node creation to check + again, and panic on duplicates. Extended testsuite with variant + of Helmut's example. + +2006-06-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.tcl : Added three new arc commands, 'move', 'move-target', + and 'move-source'. They change the nodes an arc is attached to, + without changing the identity of the arc itself. This makes + certain graph operations easier, as there is no need to save the + attributes of a node, delete it, create in the new location, + then recreate the attribute data. + * pkgIndex.tcl: Bumped version number for this. + * graph.man: Added documentation for them. + * graph.test: Extended the testsuite to cover them as well. + +2006-06-13 Andreas Kupries <andreask@activestate.com> + + * list.tcl: Added two commands requested by Sarnold75, + * list.test: see [SF Tcllib RFE 1484791], variants of + * struct_list.man: map and filter. Implemented, documented, + * pkgIndex.tcl: and tested. + +2006-01-30 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets.tcl: Fixed [SF Tcllib Bug 1414051], brought implementation + of 'include' into sync with documentation. Behaving like + 'lappend' means that we have to create the variable if it does + not exist. Thanks to michael Schlenker <mic42@users.sf.net>. + * sets.test: Corrected the testsuite as well. + +2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix1.test: Replaced [aget] with usage of the standard + * matrix.test: [dictsort]. Moved helper commands out of the + testsuites proper into a supporting file. + + * graph1.test: Fixed duplicate usage of test names. + * list.test: + * matrix.test: + * matrix1.test: + * stack.test: + * tree1.test: + +2006-01-26 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: More boilerplate simplified via use of test support. + * graph1.test: + * list.test: + * matrix.test: + * matrix1.test: + * pool.test: + * prioqueue.test: + * queue.test: + * record.test: + * sets.test: + * skiplist.test: + * stack.test: + * tree.test: + * tree1.test: + +2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: Hooked into the new common test support code. + * graph1.test: + * list.test: + * matrix.test: + * matrix1.test: + * pool.test: + * prioqueue.test: + * queue.test: + * record.test: + * sets.test: + * skiplist.test: + * stack.test: + * tree.test: + * tree1.test: + +2006-01-10 Andreas Kupries <andreask@activestate.com> + + * pool.test: New file. Structured tests. + * pooltest.tcl: Removed unstructured tests. + + * tree.test: Fixed [SF Tcllib Bug 1316061]. Uncluttering test + output. + +2005-11-02 Andreas Kupries <andreask@activestate.com> + + * graph.tcl (::struct::graph::_serialize): Fixed bug mishandling + the serialization of arcs with spaces in their names. Thanks to + Spyros Potamianos <spotam@users.sourceforge.net> for bug report + and fix. [SF Tcllib Bug 1345967] + +2005-10-27 Andreas Kupries <andreask@activestate.com> + + * tree.bench: Added more benchmarks perturbing structure, + invalidating caches, to capture true cost of computing results + of various methods. + + * tree_tcl.tcl: Reworked the core algorithm used by the method + "descendants". Avoiding the shifting of a list speeds it up + around 6 times and the factor is going higher as lists grow + larger. This makes the dependent methods (height, serialize, + children -all) about 2 times faster than they were with the + recursive implementation. + + * tree.bench: Extended the benchmarks for "height" and "serialize" + to demonstrate that the height limitation is gone. + + * tree_tcl.tcl: Fixed the limitation of the methods "height" and + "serialize" when run on deep trees. Moved to an iterative + solution using the core algorithm of "descendants". Factored + this code into an internal command used throughout. Rewrote + method "children -all" to use this command as well. + + Impact: The limitation are gone, however the performance of + "height" and "serialize" has become 2 to 3 times worse. + + * tree.bench: Substantially extended the benchmarks, covering + basically everything except tree walks, modifiers, and + tree-global attribute search. Had to restrict tests for + "height", "serialize", running into problems with deep + trees. Recursive implementation fails for interp recursion + limit. + +2005-10-21 Andreas Kupries <andreask@activestate.com> + + * tree.bench: Made this benchmark suite operational. Incomplete, + but already giving good results. + + * tree_c.tcl: Gave the method functions and their support a + * tree/m.c: better prefixes (m_ -> tm_, ms_ -> tms_), to + * tree/m.h: make them more unique, tree specific. This is + * tree/ms.c: needed to avoid conflicts with future critcl + * tree/ms.h: code for graph and other structures. + +2005-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-10-07 Andreas Kupries <andreask@activestate.com> + + * tree/t.c (t_deserialize): Fixed bug which caused us to drop the + attributes of the new root node when setting up the new tree. + +2005-10-06 Andreas Kupries <andreask@activestate.com> + + * tree/m.c (m_WALK): Fixed [SF Tcllib Bug 1313173]. This was + refcounting bug for the objects containing the names of the loop + variables. We have to declare that we are holding a reference, + otherwise the object can be reused when compiling the loop body + for the first iteration. This may also release the objects too + early, causing crashes. + + * tree/walk.c (t_walkdfs*): Fixed behavioural difference between + the two implementations of a tree walker. The dfs code has to + save a copy of the child array during the walk to handle the + possibility of a child node being moved by the loop body. + + Note: This area, modifying a tree during walks, has no test + cases at all and is in need of them. At least to describe the + exact behaviour we have now. + +2005-10-03 Jeff Hobbs <jeffh@ActiveState.com> + + * tree1.tcl (::struct::tree::Serialize): fix serialize of + attributes. + +2005-09-30 Andreas Kupries <andreask@activestate.com> + + * queue.test: Extended API with new method 'unget'. Updated + * queue.man: documentation and testsuite. Version bumped to + * queue.tcl: 1.4. This implements [SF Tcllib RFE 1229352]. + * pkgIndex.tcl: + +2005-09-23 Michael Schlenker <mic42@users.sourceforge.net> + + * prioqueue.tcl : Fixed a bug in binary sort algorithm. + prioqueue.test: Thanks to Krzysztof Skałecki <krys@dacsystem.pl> + and Tomasz Kosiak <tk@dacsystem.pl> for spotting it. + [Tcllib SF Patch 1300795] + +2005-09-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.testsuite: Added test constraint 'tree_critcl'. Fixed a + number of tests whose results are version dependent, using the + new contraint, tcl8.4plus, and tcl8.5plus. + + * tree.tcl (LoadAccel): Restricted use of critcl implementation to + Tcl 8.4+. + +2005-08-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree/*.[ch]: Cleaned code up, per Tcl styleguide. + + * tree/tn.c (tn_not{leaf,node}): Fixed buggy node unlink when list + contained only one node. Was a no-op, keeping a reference to + deallocated memory, and writing to it when the list was expanded + and then reduced again, causing memory smashes. + +2005-07-25 Andreas Kupries <andreask@activestate.com> + + * tree.tcl: Moved tcl implementation into "tree_tcl.tcl". This + file now contains management code looking for and selecting from + the available implementations. + * tree_tcl.tcl (**NEW**): Contains the tcl implementation of + struct::tree, moved out of "tree.tcl". + * tree_c.tcl (**NEW**): Contains the toplevel parts of the critcl + implementation of struct::tree. + * tree/*.[ch] (**NEW**): Contains the bulk of the critcl + implementation of struct::tree. + * tree.test: Moved actual tests into "tree.testsuite". This file + now contains the generic helper commands and management code + loading, activating and iterating over all available + implementations. + * tree.testsuite (**NEW**): Contains the actual tests, moved out + of "tree.test". The tests were updated to take the cosmetic + differences between tcl and critcl implementations into account. + * ../package_version.tcl: Added the critcl implementation of + struct::tree to the list of files to compile for tcllibc. + + * struct_tree.man: Added clarifications regarding acceptable + arguments. + + * tree.tcl: Smoothed error messages, added some missing argument + checks, rewrote handling of index arguments to make code mmore + clear. Fixing bugs in constructor, was not cleaning up a + partially build object when deserialization failed. + + * tree.test: Adapted to changed error messages. Added tests to + for a number of problems which had been forgotten so far. Made + the output of a number of tests (tree structure) unambigous. + +2005-05-23 Andreas Kupries <andreask@activestate.com> + + * list.test: + * list.tcl (::struct::list::Lflatten): Fixed [SF Tcllib Bug + 1206499] Replaced the 'eval' construction with a more basic + check for list syntax and handling of the data. The removed + construct was unable to handle elements containing special + characters (Brackets, Braces, Double-apostrophes, etc.) + correctly. The bug was reported by Yahalom Emet + <yahalom@users.sourceforge.net>. This is actually something we + created Tcl 8.5's {expand} for. Extended the testsuite as well. + +2005-05-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: + * tree.test: + * tree.tcl: New method 'walkproc'. Like walk, but calls a command + prefix (three arguments). Extended documentation, testsuite. + + * tree.tcl: Minor touchup of object creation. + * graph.tcl: Minor touchup of object creation. + * stack.tcl: Minor touchup of object creation. + * queue.tcl: Minor touchup of object creation. + * matrix.tcl: Minor touchup of object creation. + +2005-05-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl: Added two methods to the class, returning the + * tree.test: list of all nodes, or the list of leaf nodes. + * struct_tree.man: Both are easy to determine by the object + itself, and require either a walk or (children -all) otherwise, + both expensive. + +2005-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.tcl: Replaced the use of the global variable 'version' + with a properly namespaced form. This fixes the [SF Tcllib Bug + 1177108], reported by Stephen Huntley + <blacksqr@users.sourceforge.net>. + +2005-02-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_list.man: Extended to cover the new functionality. + + * list.tests: Extended testsuite for the new functionality, see + below. + + * list.tcl: New functionality. Exchange of two elements of a list, + and handling of list permutations (first, next, all, foreach). + The code has been taken from the Wiki, page 11262. The swap code + by Richard Suchenwirth. The 'firstperm' code by Kevin Kenny. The + 'nextperm' algorithm by Donal E. Knuth [*], as translated to Tcl + by Kevin Kenny. Generation of all permutations and looping over + them by myself, using code from the module 'control' as well. + -- [*] Detailed references in the documentation. + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-10-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Added a bit more structure to the manpage, + added an example demonstrating the creation of nodes, added an + explicit statement that new nodes are created with the method + "insert". + +2004-09-29 Andreas Kupries <andreask@activestate.com> + + * record.tcl: Fixed [Tcllib SF Bug 1018733]. Corrected management + * record.text: of _level, which was reset to the level 0 to early, + and also was not decremented after a sub-record was completed. + + * record.tcl (Delete): Fixed [Tcllib SF Bug 1023973]. Do not count + * record.test: the id generator down. Added test case for this. + + * tree.tcl: Fixed [Tcllib SF Bug 1034924]. Both tree and graph + * struct_tree.man: depend on struct::list for some of their methods. + * tree.test: Now in the code, documented as well, testsuite + * graph.tcl: header code extended. + * graph.man: + * graph.test: + +2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * skiplist.tcl: Fixed expr'essions without braces. + + * graph.tcl (CheckSerialization): Fixed nested reuse of foreach + variable (attr). + +2004-09-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: Fixed [Tcllib SF Bug 1007396]. Multiple use + * graph.tcl: of the various restrictions is not allowed. + * graph.man: Added to code, test suite, and documentation. + * graph1.test: + * graph1.tcl: + * graph1.man: + +2004-08-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * stack.tcl: Corrected typo in constructor error message, + * queue.tcl: due to copying from tree. Found by Michael + Schlenker. + +2004-08-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Added methods 'ancestors' and 'descendants'. + * tree.test: + * tree.tcl: + + * struct_tree.man: Added a prune operation to the tree walk + * tree.tcl: command. This implements the [SF Tcllib + * tree.test: RFE 916160]. + +2004-08-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl (::struct::tree::tree, ::struct::tree::_destroy): + Better alias for the object command (removed superfluous leading + colons). + + * stack.man: Stack, queue; version bumped to 1.3. + * queue.man: + * stack.tcl: + * queue.tcl: + * pkgIndex.tcl: + + * queue.test: + * queue.tcl: Changed way of mapping from queue object commands to + associoated namespaces. The object namespace now has the same + name and location of the object command. Adapted all tests to + account for this change. + + * queue.test: + * queue.tcl: Changed dispatcher to auto-generate the list of queue + commands when a wrong one is given. Updated tests to account for + this. Changed dispatcher to uplevel 1 the method execution, + updated walking system to reflect this change. + + See log entry 2003-07-06 as well. + + * stack.test: + * stack.tcl: Changed way of mapping from stack object commands to + associated namespaces. The object namespace now has the same + name and location of the object command. Adapted all tests to + account for this change. + + * stack.test: + * stack.tcl: Changed dispatcher to auto-generate the list of stack + commands when a wrong one is given. Updated tests to account for + this. Changed dispatcher to uplevel 1 the method execution, + updated walking system to reflect this change. + + See log entry 2003-07-06 as well. + + * stack.man: Fixed [SF Tcllib 1005380]. Documentation for peek and + pop now matching the actual behaviour. See also entry 2003-04-25 + for the same thing, for queue. + + * tree.tcl: Spelling police. + * graph.tcl: + * stack.tcl: + * queue.tcl: + * matrix.tcl: + * ChangeLog: + +2004-08-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * sets.tests: + * sets.tcl (::struct::set::Sdifference): Fixed the [Tcllib SF Bug + 1002143]. Thanks to Todd Coram <maroc@users.sourceforge.net> for + the report. Set elements containing parentheses screw up the + special implementation using the elements as names for local + vars, as they are not seen as regular locals, but as array + elements. Disabled the special implementation, using the regular + one across versions. Extended the testsuite. + + * graph.test: Fixed [SF Tcllib Bug 1003671]: Ensured that + * tree.test: (de)serialization of empty graph/tree is + * graph.tcl: working properly. Thanks to Bhushit Joshipura + * tree.tcl: <bhushit@users.sf.net> for the report. + +2004-08-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: Fixed [SF Tcllib Bug 1000716]: Unset of last + * tree.test: attribute followed by delete does not result + * graph.tcl: in error anymore. Thanks to Brian Theado + * tree.tcl: <btheado@users.sf.net> for both report and fix. + +2004-06-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl (_search): Fixed bug reported by Joachim Kock + <kock@math.uqam.ca>, using his fix. Search went into an infinite + loop if -nocase was used. + * matrix.test: Added a testcase. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.test: Added clean up commands to prevent tests + * matrix1.test: from interfering with each other. Testsuite + * tree1.test: is now passing again. + + * graph.man: Fixed the 'require' declarations in the + * matrix.man: documentation to use the correct package + * pool.man: names. + * prioqueue.man: + * queue.man: + * record.man: + * skiplist.man: + * stack.man: + * struct_list.man: + * struct_set.man: + * struct_tree.man: + + * tree1.man: Folded the v1 data structures back into the struct + * tree1.tcl: directory, as their own packages. Recorded the old + * tree1.test: v1 struct as a set of packages now as well. The + * graph1.man: unchanged data structures from struct v1 have been + * graph1.tcl: removed from the repository. They were duplicates. + * graph1.test: + * matrix1.man: + * matrix1.tcl: + * matrix1.test: + * pkgIndex.tcl: + +2004-05-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.tcl: Made all data structures full packages. + * list.tcl: + * matrix.tcl: + * pkgIndex.tcl: + * pool.tcl: + * pooltest.tcl: + * prioqueue.tcl: + * queue.tcl: + * record.tcl: + * sets.tcl: + * skiplist.tcl: + * stack.tcl: + * struct.tcl: + * tree.tcl: + + * graph.test: Updated all testsuites to report the versions + * list.test: of the packages they test. + * matrix.test: + * prioqueue.test: + * queue.test: + * record.test: + * sets.test: + * skiplist.test: + * stack.test: + * tree.test: + + * graph.man: Updated the documentation to show the correct + * matrix.man: new package names. + * pool.man: + * prioqueue.man: + * queue.man: + * record.man: + * skiplist.man: + * stack.man: + * struct_list.man: + * struct_set.man: + * struct_tree.man: + +2004-02-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: Overall package bumped to v2.1 + * struct.tcl: + + * sets.tcl: Added include, exclude, add, and subtract + * sets.test: operators, and a new predicate subsetof. + * struct_set.man: Added documentation for the new methods + above. Added tests for the new methods. + + * sets.tcl: Typo police. No functional changes. + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.tcl (split): New method, like 'filter', but returns lists + * list.test: of both passing and failing elements. Extended + * struct_list.man: both testsuite and documentation. + +2004-02-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.tcl (assign): Synchronized API to Tcl 8.5 lassign. + * struct_list.man: + + * list.test: Added conditionals for version dependent results. + +2004-02-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.man: Added new method 'arc attr' ad 'node attr' to + * graph.tcl: the graph data structure. They serve the same + * graph.test: purpose as the 'attr' method for trees. See below. + + Additional the 'arcs' and 'nodes' method have been given + '-filter' options, similar to the filter for the children of a + node in trees. + +2004-02-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: New method 'attr' for attribute searches + * tree.tcl: based on attribute name, and node + * tree.test: restrictions. + +2004-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Extended the method 'children', now allows + * tree.tcl: node filtering and recursive listing of all + * tree.man: children in the tree starting at the node. + + * struct_list.man: Added a 'shift method to 'struct::list'. + * list.tcl: + * list.test: + + * struct_list.man: Added a 'filter' method to 'struct::list'. + * list.tcl: This method applies a test to all elements + * list.test: of a list and returns a list containing + only those elements which pass the test. + +2004-02-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.tcl (repeat(n)): ** API INCOMPATIBILITY ** + + Renamed the existing 'repeat' to 'repeatn' to keep the + functionality. Created new 'repeat' command which is + functionally equivalent to the 'lrepeat' command found in the + forthcoming Tcl 8.5. + + * struct_set.man: New submodule for set operations. Implementation, + * sets.tcl: documentation, tests, and integrated into the + * sets.test: main package. + * struct.tcl: + +2004-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Extended with table showing the relationship + between the various combination of type and order, and the + possible visitor actions. + +2004-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Updated documentation. + * tree.test: Updated testsuite for modified 'walk' syntax. + * tree.tcl (method walk): Modified to use list of loop variables, + containing either one or two. Default: One variable, node + information. When two specified the first refers to action data. + + * list.test: Added test for call with illegal option. + * list.tcl (Lflatten): Added proper error message when + encountering an unknown/illegal option. + +2004-01-26 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct_tree.man: Updated the documentation to reflect the + changes below. + + * tree.test: Updated testsuite to reflect the changes made below. + + * tree.tcl (walk): Changed API to be more like [foreach]. Allowing + break/return/continue in the walk body as well now too. + +2004-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.test: Implemented (de)serialization of matrix objects, + * matrix.tcl: copy and assignment operators, and a transpose + * matrix.man: method. Extended testsuite and documentation. + +2004-01-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.man: Implemented Ed Suominen's sort methods, with + * matrix.tcl: modifications to speed things up, and to have + * matrix.test: a more standard API (-options). + +2004-01-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.man: Documented method 'links'. + + * matrix.test: Updated test to cover for method links. + * matrix.tcl: Changed the code to determine the list of available + methods automatically for use in the error message when an + unknown method is called. + + * matrix.test: + * matrix.tcl: Namespaces of objects now standalone, and not inside + of struct::matrix anymore. Arbitrary placement of objects is now + possible, including nested namespaces. Cleanup of all references + to instance variables. + + * matrix.tcl: Made the return of errors more regular. + + * matrix.tcl: Changed a number of eval calls to the more proper + 'uplevel 1'. This means that an implementation of a method can + now assume that it is called on the same stack level as the + method itself. + +2004-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl: Typo in comments fixed. + * matrix.tcl (__set_rect): Fixed typos in var names causing the + system to retain bogus cache data. + +2003-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * prioqueue.tcl: Applied patch in file 64215 of [SF Tcllib Bug 822850]. + * skiplist.tcl: This cleans up a number of dangerous uses of [eval] + * matrix.tcl: and makes them more robust. + * queue.tcl: + * stack.tcl: + * pool.tcl: + + * pool.tcl (::struct::pool::request): Changed to return 0 as + documented when trying to get an already allocated item. Fixed + [SF Tcllib Bug 842408]. Used the alternative fix. + +2003-10-21 Andreas Kupries <andreask@activestate.com> + + * struct_tree.man: Added more documentation about the root node of + tree's. [Bug 827643]. + +2003-07-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl: Fixed bugs in tree serialization code found when + hitting them during testing the graph. + + * graph.man: Completed the implementation of graph serialization. + * graph.tcl: Updated testsuite, documentation. + * graph.test: + +2003-07-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl: Created 'ldelete' and 'lset' (emulation pre 8.4) + * graph.tcl: and replaced as much 'lreplace's as possible. Using + the K operator for speed, encapsulated in the two l + commands. + + * graph.man: Implemented the renaming of nodes and arcs. + * graph.tcl: + * graph.test: + +2003-07-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.tcl: ** API INCOMPATIBILITY ** + * graph.test: + * graph.man: Same changes in attribute handling as for + 'tree'. Noted that the graph attributes had neither 'append' nor + 'lappend' methods. Added. Documentation and testsuite updated. + + * pkgIndex.tcl: ** API INCOMPATIBILITY ** + * struct_tree.man: + * tree.test: + * tree.tcl: More rework. The attribute APIs are now backward + incompatible, the default attribute 'data' has been dropped. The + whole module 'struct' has been bumped to version 2.0 because of + this. Reworked the testsuite for the changed APIs. Reworked the + (de)serialization stuff a bit and added tests for them. Added an + API to rename nodes, and an API to query the name of the + root node. The APIs 'getall' and 'keys' now allow usage of glob + patterns to restrict their results. Documentation is now + uptodate. Added API to compute the 'height' of a node (= + distance to its deepest child). + +2003-07-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.test: + * tree.tcl: Reworked node attribute storage. Name of array to + store the information is now dissociated from the name of the + node. This enables the use of arbitrary node names, i.e. ':' in + node names. The second benefit is that nodes without attribute + data (normal) require less memory than before. Removed the now + irrelevant validation of node names and updated the testsuite. + + * tree.test: + * tree.tcl: Changed way of mapping from tree object commands to + associated namespaces. The object namespace now has the same + name and location of the object command. Adapted all tests to + account for this change. + + * tree.test: + * tree.tcl: Changed dispatcher to auto-generate the list of tree + commands when a wrong one is given. Updated tests to account for + the now correct sort order. Changed dispatcher to uplevel 1 the + method execution, updated walking system to reflect this change. + +2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.tcl: The changes in the list dispatcher required + corresponding changes in a number of methods: upvar/level 2 => + upvar/level 1. Detected by testsuite. Bad me, should have run it + immediately. Bugs fixed. + + * list.test: Extended the testsuite. + * list.tcl (lcsInvertMerge2): Fixed problem with extending the + result with an chunk of type unchanged, for the case that this + happens at the very beginning, i.e. for an empty result. This + fixes SF Tcllib bug [765321]. + +2003-05-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.tcl (dispatcher): eval => uplevel so that upvar's in the + method commands do not need to know about the dispatcher frame + in the stack. + + * list.man: + * list.tcl (dbJoin(Keyed)): Extended the commands with an option + -keys. Argument is the name of a variable to store the actual + list of keys into, independent of the output table. As the + latter may not contain all the keys, depending on how and where + key columns are present or not. Additionally cleanups in the use + of loop variables in the keyed helper commands 'frink' complained + about. + +2003-05-16 Andreas Kupries <andreask@activestate.com> + + * Extension of the package functionality warrants version bump to 1.4. + + * list.man: Added descriptions of the db join commands, and + section explaining the table joins. + + * list.test: Added tests for the db join functionality. Adapted + existing tests to changed (fixed) error messages. + + * list.tcl: Rewrote the main dispatcher a bit to make it simpler, + and to allow us to hide internal functions from it. Added + 'dbJoin(Keyed)' for relational table join (inner, left/right/full + outer). Fixed function name in some error messages. + +2003-05-14 Andreas Kupries <andreask@activestate.com> + + * tree.tcl: Added some [list]'s to show node names containing + spaces properly in error messages. + + * tree.test: Reworked to test handling of item nodes + containing spaces. + + * tree.bench: Reworked, added helper procedures, test cases are now + simpler. + + * struct_list.man: Fixed typos in the examples. + +2003-05-06 Jeff Hobbs <jeffh@ActiveState.com> + + * tree.test: + * tree.tcl: allow node names with space chars and single :. + Double :: may be OK, but the check against it is still in. + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-05-05 Andreas Kupries <andreask@activestate.com> + + * prioqueue.tcl: Applied patch by author Michael Schlenker + <mic42@users.sourceforge.net>. Refactors internals for + speed. Passes the prioqueue testsuite. + +2003-04-25 Andreas Kupries <andreask@activestate.com> + + * queue.man: Documentation fix. peek/get throw errors if more was + requested than in the queue. The documentation talked about + returning empty strings. Thanks to Michael Schlenker + <mic42@users.sourceforge.net> for the report. + + * prioqueue.test: Extended to check for stable insertion. + * prioqueue.tcl (__elementcompare): Bugfix, makes insertion stable. + * prioqueue.man: New, documentation. + + * skiplist.man: Typo fix. Thanks to Michael Schlenker + <mic42@users.sourceforge.net> for the report. + +2003-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.bench: New file, beginnings of a benchmark suite for the + data structure 'struct::tree'. + +2003-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.man: Changed name to struct_tree.man. Was in conflict with + tree manpage of BLT. + +2003-04-22 Andreas Kupries <andreask@activestate.com> + + * graph.man: Switched cgraph reference to a purl supplied by the + cgraph author, and added wiki reference. + +2003-04-16 Andreas Kupries <andreask@activestate.com> + + * prioqueue.tcl (__elementcompare): Failures in testsuite fixed, + patch provided by original author, Michael Schlenker + <mic42@users.sourceforge.net>. + +2003-04-15 Andreas Kupries <andreask@activestate.com> + + * skiplist.man: + * skiplist.tcl: + * skiplist.test: New files. Patch #553980 submitted by Eric Melski + <ericm@users.sourceforge.net> on behalf of Keith Vetter. + + * prioqueue.tcl: + * prioqueue.test: New files. Patch #607085 submitted by Michael + Schlenker <mic42@users.sourceforge.net>. + +2003-04-15 Andreas Kupries <andreask@activestate.com> + + * tcllib_list.man: Changed name to struct_list.man. Allows for + usage of struct outside of tcllib, not as big a coupling. + + * graph.tcl: Redone the setting up of namespace a bit to prevent + problem with the generation of a master package + index. struct.tcl bailed out with an error because the namespace + was net set up when using [pkg_mkIndex] in this directory. + +2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: + * graph.man: + * graph.tcl: Added code to look for the C-implementation, cgraph, + first, and to fall back to the Tcl implementation if cgraph is + not present (#720348). The documentation links to the place + where cgraph can be had from. Note presence of cgraph when + executing the testsuite. + +2003-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.man: Changed name to tcllib_list.man to prevent a clash + with tcl's manpages. + +2003-04-11 Andreas Kupries <andreask@activestate.com> + + * struct.tcl: + * list.man: + * matrix.man: + * pool.man: + * queue.man: + * record.man: + * stack.man: + * tree.man: + * pkgIndex.tcl: Set version of the package to 1.3. + +2003-04-09 Andreas Kupries <andreask@activestate.com> + + * list.man: + * list.test: + * list.tcl: Added 'lcsInvertMerge'. + +2003-04-08 Andreas Kupries <andreask@activestate.com> + + * list.man: + * list.test: + * list.tcl: Added and documented commands [iota], [equal], and + [repeat]. Extended the testsuite. + +2003-04-02 Andreas Kupries <andreask@activestate.com> + + * list.tcl: + * list.test: Fixed SF tcllib bug #714209. + + * ../../../examples/struct: Added example applications for usage + of longestCommonSubsequence and lcsInvert. + + * struct.tcl: Integrated new list commands. + + * list.tcl: Added commands 'reverse', 'assign', 'flatten', + * list.man: 'map', and 'fold' to the suite of list functions. + * list.test: + +2003-04-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * list.man: New files, extended list manipulation + * list.tcl: facilities. Started out with Kevin Kenny's + * list.test: implementation of the algorithm to find the longest + common subsequence of two sequences, aka lists. + Added myself a method to invert a LCS into a + description of differences instead. + +2003-04-01 Andreas Kupries <andreask@activestate.com> + + * record.test: Applied changes provided by Brett Schwarz + <schwarzkopf@users.sourceforge.net>. His comments: I had changed + the return when encountering a circular record; previously I + returned "", but now I return an error. This fixes record.test + to reflect the change. Part of fix for Tcllib SF Bug #709375. + + Additional changes by myself: Reformatted (proper tcl + indentations). Renumbered so that all tests have unique id + numbers (Before all tests had id 0.1). + +2003-02-25 David N. Welton <davidw@dedasys.com> + + * matrix.tcl: Require Tcl 8.2 because of string map. Use string + map instead of regexp. + +2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.man: More semantic markup, less visual one. + * matrix.man: + * pool.man: + * record.man: + * tree.man: + +2002-11-06 Brett Schwarz <schwarzkopf@users.sourceforge.net> + + * record.tcl: cleaned up code based on output from frink + +2002-11-05 Brett Schwarz <schwarzkopf@users.sourceforge.net> + + * struct.tcl: modified to include record.tcl + + * record.man: + * record.html: + * record.n: + * record.test: + * record.tcl: new data structure + +2002-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: + * graph.man: + * graph.tcl: Implemented FR 603924. getall, keys, keyexists + methods for keys of the whole graph. + +2002-08-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.test: Followup to fix for bug SF #587533. Had to update the + test suite too. + +2002-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl (lappend): Fixed bug SF #587533 reported by Evan Rempel + <erempel@users.sourceforge.net>. + + * pool.tcl: Fixed bug SF #585093, reported by Michael Cleverly + <cleverly@users.sourceforge.net>. Patch provided by Michael too. + +2002-07-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.man: Updated the documentation to clarify the behaviour. + + * test.tcl: Updated testsuite, part of the patch below. + + * tree.tcl (_move): Accepted patch by Brian Theado + <btheado@users.sourceforge.net> fixing the behaviour of move, SF + bug #578460. The command now also validates all nodes before + trying to move any of them. + +2002-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.man: Fixed typo (graph -> matrix). + + * struct.tcl: Added pool files to list of files to source. + + * pool.man: New documentation for pool based upon the original + HTML manpage. + + * pool.html: + * pooltest.tcl: + * pool.tcl: New data structure, pool, by Erik Leunissen + <e.leunissen@hccnet.nl>. Modified code to be a sub-namespace of + ::struct, made it a part of the struct package. No regular + testsuite yet (see pooltest.tcl for the irregular testsuite). + +2002-05-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.n: This file is out of sync. + * graph.man: + * graph.test: + * graph.tcl: See tree, for arcs and nodes. + + * tree.man: + * tree.n: + * tree.test: + * tree.tcl: Accepted FR #552972 (new methods append, lappend, + getall, keys, keyexists) for tree structures. + +2002-04-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl: Fixed SF Tcllib #532791 about unsetting of elements + in linked arrays as reported by Ken Jones + <kenj@users.sourceforge.net>. Unsetting an element in a linked + array now sets the corresponding cell in the matrix to the empty + string, and the corresponding elements in other linked arrays + are now unset too. + + * tree.man: New file, doctools manpage. + +2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl: Fixed bug #532783 reported by Ken Jones + <kenj@users.sourceforge.net>. Any operation adding new material + to a linked matrix causes a circular trace (op -> "MatTraceOut" + -> "MatTraceIn" -> set cell) and the inbound trace fails because + the data structures are not uptodate causing the range checks in + "set cell" to fail. Fixed by breaking the cycle. Calls to + "MatTraceIn" are now disabled while we are in "MatTraceOut". + +2002-03-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.man: Added example of formatting a matrix using tabular + reports (See tcllib module "reports" too.). Fixes #530207. + +2002-03-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.n: + * matrix.man: + * matrix.test: + * matrix.tcl: Accepted FR #524430 and added option -nocase to the + 'search' method. + + * matrix.man: Added doctools manpage. + +2002-03-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.man: Added doctools manpage. + +2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl: Frink run. + +2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Version up to 1.2.1 to differentiate development from the + version in the tcllib 1.2 release. + + * matrix.test: + * matrix.tcl: See below, but not complete. + * queue.test + * stack.test: + * graph.tcl: + * graph.test: + * tree.tcl: + * tree.test: Updated code and tests to cover all paths through the + code. + +2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Bumped version to 1.2 + +2001-11-26 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl (add rows): Indices were transposed. Fixed. + +2001-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.test: + * matrix.n: + * matrix.tcl: Implementation of FR #481022: matrix printing and + searching. + +2001-11-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * graph.test: + * graph.n: + * graph.tcl: Applied patch #483125 provided by Frank Pilhofer + <fp@fpx.de>. The patch adds key/value information for the whole + graph and extends the selection methods 'arcs' and 'nodes' to + allow selection based on keys and their values. + +2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * pkgIndex.tcl: + * struct.tcl: + * graph.n: + * matrix.n: + * queue.n: + * stack.n: + * tree.n: Version up to 1.1.1 + +2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * The changes below fix bug [458011]. + + * tree.test (6.16): New test. Checks verificator of forbidden names. + + * tree.tcl (::struct::tree::_insert): Added verification that node + names do not contain forbidden characters. + + * tree.n: Documented limitations on node names. Documented allowed + index "end" for insert. + +2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl: Frink 2.2 run, fixed dubious code. + +2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * tree.tcl: + * graph.tcl: Fixed dubious code reported by frink. + +2001-06-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.n: Fixed nroff trouble. + +2001-05-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.tcl (insert row/column): Fixed wrong references to the + internal add row/column procedures. + + * modules/struct/matrix.test: Added 8.11 and 8.12 to test the case + of 'insert FOO' devolving to 'add FOO'. + +2001-05-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Committed changes (matrix) to CVS head at SF. + +2001-04-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * matrix.n: updated and completed documentation + * matrix:test: Added testsuite + * matrix.tcl: Added the implementation. + +2001-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * struct.tcl: Added loading of the matrix definition. + + * matrix.n: Adding matrix structure. + +2000-04-07 Eric Melski <ericm@scriptics.com> + + * stack.test: + * queue.test: Changed "package require struct" to "source [file + join [file dirname [info script]] xxxx.tcl]", which is more reliable. + + * tree.test: + * tree.tcl: Added support for different walk orders (post, + in, and both) [RFE: 4420]. Added support for percent substitution + on walk command. (WalkCall) Added protection against node/tree + names with spaces. + + * graph.tcl: + * graph.test: + * graph.n: Graph implementation from Andreas Kupries. + +2000-03-20 Eric Melski <ericm@scriptics.com> + + * tree.test: + * tree.n: + * tree.tcl: Added support for inserting/moving multiple nodes at + once. Changed behavior of insert with respect to inserting nodes + that already exist; instead of an error, it will move the node. + +2000-03-14 Eric Melski <ericm@scriptics.com> + + * tree.n: Added a brief description of what a tree is. + +2000-03-10 Eric Melski <ericm@scriptics.com> + + * tree.n: + * tree.tcl: + * tree.test: Applied patch from [RFE: 4337], with enhancements for + better efficiency, and additional test cases; adds cut and splice + functions to tree. + +2000-03-09 Eric Melski <ericm@scriptics.com> + + * tree.n: + * tree.tcl: + * tree.test: Applied patch from [RFE: 4338]; adds index function to + tree. Applied patch from [RFE: 4339], with slight modification; adds + numchildren function to tree. Applied patch from [RFE: 4336], + with additional error checks and test cases; adds next, previous + functions to tree. Added extra tests for walk command. + + * tree.tcl: Added isleaf function and tests [RFE: 4340] + + * struct.tcl: Changed order of namespace import/namespace export + calls. Added -force to namespace import calls. + + * tree.test: + * stack.test: + * queue.test: Adapted tests to run in/out of tcllib test framework. + + * tree.test: + * tree.tcl: Added code to auto-generate node names on insert if no + name is given [RFE: 4345] + +2000-03-08 Eric Melski <ericm@scriptics.com> + + * tree.test: + * tree.tcl: Added check for node existence in children function + [Bug: 4341] + +2000-03-03 Eric Melski <ericm@scriptics.com> + + * tree.tcl: Changed usage information for tree::_walk. + + * tree.n: Enhanced description of walk function, fixed a typo. diff --git a/tcllib/modules/struct/disjointset.man b/tcllib/modules/struct/disjointset.man new file mode 100644 index 0000000..5dd2b24 --- /dev/null +++ b/tcllib/modules/struct/disjointset.man @@ -0,0 +1,160 @@ +[manpage_begin struct::disjointset n 1.0] +[keywords {disjoint set}] +[keywords {equivalence class}] +[keywords find] +[keywords {merge find}] +[keywords partition] +[keywords {partitioned set}] +[keywords union] +[moddesc {Tcl Data Structures}] +[titledesc {Disjoint set data structure}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::disjointset [opt 1.0]] +[description] +[para] + +This package provides [term {disjoint sets}]. An alternative name for +this kind of structure is [term {merge-find}]. + +[para] + +Normally when dealing with sets and their elements the question is "Is +this element E contained in this set S?", with both E and S known. + +[para] + +Here the question is "Which of several sets contains the element +E?". I.e. while the element is known, the set is not, and we wish to +find it quickly. It is not quite the inverse of the original question, +but close. + +Another operation which is often wanted is that of quickly merging two +sets into one, with the result still fast for finding elements. Hence +the alternative term [term merge-find] for this. + +[para] + +Why now is this named a [term disjoint-set] ? + +Because another way of describing the whole situation is that we have + +[list_begin itemized] +[item] a finite [term set] S, containing +[item] a number of [term elements] E, split into +[item] a set of [term partitions] P. The latter term + applies, because the intersection of each pair P, P' of + partitions is empty, with the union of all partitions + covering the whole set. +[item] An alternative name for the [term partitions] would be + [term {equvalence classes}], and all elements in the same + class are considered as equal. +[list_end] + +Here is a pictorial representation of the concepts listed above: +[example { + +-----------------+ The outer lines are the boundaries of the set S. + | / | The inner regions delineated by the skewed lines + | * / * | are the partitions P. The *'s denote the elements + | * / \ | E in the set, each in a single partition, their + |* / \ | equivalence class. + | / * \ | + | / * / | + | * /\ * / | + | / \ / | + | / \/ * | + | / * \ | + | / * \ | + +-----------------+ +}] + +[para] + +For more information see [uri http://en.wikipedia.org/wiki/Disjoint_set_data_structure]. + +[section API] + +The package exports a single command, [cmd ::struct::disjointset]. All +functionality provided here can be reached through a subcommand of +this command. + +[para] + +[list_begin definitions] + +[call [cmd ::struct::disjointset] [arg disjointsetName]] + +Creates a new disjoint set object with an associated global Tcl +command whose name is [emph disjointsetName]. This command may be used +to invoke various operations on the disjointset. It has the following +general form: + +[list_begin definitions] + +[call [arg disjointsetName] [arg option] [opt [arg {arg arg ...}]]] + +The [cmd option] and the [arg arg]s determine the exact behavior of +the command. The following commands are possible for disjointset +objects: + +[list_end] + +[call [arg disjointsetName] [method add-partition] [arg elements]] + +Creates a new partition in specified disjoint set, and fills it with +the values found in the set of [arg elements]. The command maintains +the integrity of the disjoint set, i.e. it verifies that none of the +[arg elements] are already part of the disjoint set and throws an +error otherwise. + +[para] + +The result of the command is the empty string. + +[call [arg disjointsetName] [method partitions]] + +Returns the set of partitions the named disjoint set currently +consists of. + +[call [arg disjointsetName] [method num-partitions]] + +Returns the number of partitions the named disjoint set currently +consists of. + +[call [arg disjointsetName] [method equal] [arg a] [arg b]] + +Determines if the two elements [arg a] and [arg b] of the disjoint set +belong to the same partition. The result of the method is a boolean +value, [const True] if the two elements are contained in the same +partition, and [const False] otherwise. + +[para] + +An error will be thrown if either [arg a] or [arg b] are not elements +of the disjoint set. + +[call [arg disjointsetName] [method merge] [arg a] [arg b]] + +Determines the partitions the elements [arg a] and [arg b] are +contained in and merges them into a single partition. If the two +elements were already contained in the same partition nothing will +change. + +[para] + +The result of the method is the empty string. + +[call [arg disjointsetName] [method find] [arg e]] + +Returns the partition of the disjoint set which contains the element +[arg e]. + +[call [arg disjointsetName] [method destroy]] + +Destroys the disjoint set object and all associated memory. + +[list_end] + +[vset CATEGORY {struct :: disjointset}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/disjointset.tcl b/tcllib/modules/struct/disjointset.tcl new file mode 100644 index 0000000..028b86f --- /dev/null +++ b/tcllib/modules/struct/disjointset.tcl @@ -0,0 +1,344 @@ +# disjointset.tcl -- +# +# Implementation of a Disjoint Set for Tcl. +# +# Copyright (c) Google Summer of Code 2008 Alejandro Eduardo Cruz Paz +# Copyright (c) 2008 Andreas Kupries (API redesign and simplification) + +package require Tcl 8.2 +package require struct::set + +# Initialize the disjointset structure namespace. Note that any +# missing parent namespace (::struct) will be automatically created as +# well. +namespace eval ::struct::disjointset { + # Counter for naming disjoint sets without a given name + variable counter 0 + + # Only export one command, the one used to instantiate a new + # disjoint set + namespace export disjointset +} + +# ::struct::disjointset::disjointset -- +# +# Create a new disjoint set with a given name; if no name is +# given, use disjointsetX, where X is a number. +# +# Arguments: +# name Optional name of the disjoint set; if not specified, generate one. +# +# Results: +# name Name of the disjoint set created + +proc ::struct::disjointset::disjointset {args} { + variable counter + + # Derived from the constructor of struct::queue, see file + # "queue_tcl.tcl". Create name of not specified. + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "disjointset${counter}" + } + 2 { + # Standard call. New empty disjoint set. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"::struct::disjointset ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + # Done after qualification so that we have a canonical name and + # know exactly what we are looking for. + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create disjointset" + } + + + # This is the structure where each disjoint set will be kept. A + # namespace containing a list/set of the partitions, and a set of + # all elements (for quick testing of validity when adding + # partitions.). + + namespace eval $name { + variable partitions {} ; # Set of partitions. + variable all {} ; # Set of all elements. + } + + # Create the command to manipulate the DisjointSet + interp alias {} ::$name {} ::struct::disjointset::DisjointSetProc $name + return $name +} + +########################## +# Private functions follow + +# ::struct::disjointset::DisjointSetProc -- +# +# Command that processes all disjointset object commands. +# +# Arguments: +# name Name of the disjointset object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::disjointset::DisjointSetProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Derived from the struct::queue dispatcher (see queue_tcl.tcl). + # Gets rid of the explicit list of commands. Slower in case of an + # error, considered acceptable, as errors should not happen, or + # only seldomly. + + set sub _$cmd + if { ![llength [info commands ::struct::disjointset::$sub]]} { + set optlist [lsort [info commands ::struct::disjointset::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + # Run the method in the same context as the dispatcher. + return [uplevel 1 [linsert $args 0 ::struct::disjointset::_$cmd $name]] +} + +# ::struct::disjointset::_add-partition +# +# Creates a new partition in the disjoint set structure, +# verifying the integrity of each new insertion for previous +# existence in the structure. +# +# Arguments: +# name The name of the actual disjoint set structure +# items A set of elements to add to the set as a new partition. +# +# Results: +# A new partition is added to the disjoint set. If the disjoint +# set already included any of the elements in any of its +# partitions an error will be thrown. + +proc ::struct::disjointset::_add-partition {name items} { + variable ${name}::partitions + variable ${name}::all + + # Validate that one of the elements to be added are already known. + foreach element $items { + if {[struct::set contains $all $element]} { + return -code error \ + "The element \"$element\" is already known to the disjoint set $name" + } + } + + struct::set add all $items + lappend partitions $items + return +} + +# ::struct::disjointset::_partitions +# +# Retrieves the set of partitions the disjoint set consists of. +# +# Arguments: +# name The name of the disjoint set. +# +# Results: +# A set of the partitions contained in the disjoint set. +# If the disjoint set has no partitions the returned set +# will be empty. + +proc ::struct::disjointset::_partitions {name} { + variable ${name}::partitions + return $partitions +} + +# ::struct::disjointset::_num-partitions +# +# Retrieves the number of partitions the disjoint set consists of. +# +# Arguments: +# name The name of the disjoint set. +# +# Results: +# The number of partitions contained in the disjoint set. + +proc ::struct::disjointset::_num-partitions {name} { + variable ${name}::partitions + return [llength $partitions] +} + +# ::struct::disjointset::_equal +# +# Determines if the two elements belong to the same partition +# of the disjoint set. Throws an error if either element does +# not belong to the disjoint set at all. +# +# Arguments: +# name The name of the disjoint set. +# a The first element to be compared +# b The second element set to be compared +# +# Results: +# The result of the comparison, a boolean flag. +# True if the element are in the same partition, and False otherwise. + +proc ::struct::disjointset::_equal {name a b} { + CheckValidity $name $a + CheckValidity $name $b + return [expr {[FindIndex $name $a] == [FindIndex $name $b]}] +} + +# ::struct::disjointset::_merge +# +# Determines the partitions the two elements belong to and +# merges them, if they are not the same. An error is thrown +# if either element does not belong to the disjoint set. +# +# Arguments: +# name The name of the actual disjoint set structure +# a 1st item whose partition will be merged. +# b 2nd item whose partition will be merged. +# +# Results: +# An empty string. + +proc ::struct::disjointset::_merge {name a b} { + CheckValidity $name $a + CheckValidity $name $b + + set a [FindIndex $name $a] + set b [FindIndex $name $b] + + if {$a == $b} return + + variable ${name}::partitions + + set apart [lindex $partitions $a] + set bpart [lindex $partitions $b] + + # Remove the higher partition first, otherwise the 2nd replace + # will access the wrong element. + if {$b > $a} { set t $a ; set a $b ; set b $t } + + set partitions [linsert \ + [lreplace [lreplace [K $partitions [unset partitions]] \ + $a $a] $b $b] \ + end [struct::set union $apart $bpart]] + return +} + +# ::struct::disjointset::_find +# +# Determines and returns the partition the element belongs to. +# Returns an empty partition if the element does not belong to +# the disjoint set. +# +# Arguments: +# name The name of the disjoint set. +# item The element to be searched. +# +# Results: +# Returns the partition containing the element, or an empty +# partition if the item is not present. + +proc ::struct::disjointset::_find {name item} { + variable ${name}::all + if {![struct::set contains $all $item]} { + return {} + } else { + variable ${name}::partitions + return [lindex $partitions [FindIndex $name $item]] + } +} + +proc ::struct::disjointset::FindIndex {name item} { + variable ${name}::partitions + # Check each partition directly. + # AK XXX Future Use a nested-tree structure to make the search + # faster + + set i 0 + foreach p $partitions { + if {[struct::set contains $p $item]} { + return $i + } + incr i + } + return -1 +} + +# ::struct::disjointset::_destroy +# +# Destroy the disjoint set structure and releases all memory +# associated with it. +# +# Arguments: +# name The name of the actual disjoint set structure + +proc ::struct::disjointset::_destroy {name} { + namespace delete $name + interp alias {} ::$name {} + return +} + +# ### ### ### ######### ######### ######### +## Internal helper + +# ::struct::disjointset::CheckValidity +# +# Verifies if the argument element is a member of the disjoint +# set or not. Throws an error if not. +# +# Arguments: +# name The name of the disjoint set +# element The element to look for. +# +# Results: +# 1 if element is a unary list, 0 otherwise + +proc ::struct::disjointset::CheckValidity {name element} { + variable ${name}::all + if {![struct::set contains $all $element]} { + return -code error \ + "The element \"$element\" is not known to the disjoint set $name" + } + return +} + +proc ::struct::disjointset::K { x y } { set x } + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + namespace import -force disjointset::disjointset + namespace export disjointset +} + +package provide struct::disjointset 1.0 diff --git a/tcllib/modules/struct/disjointset.test b/tcllib/modules/struct/disjointset.test new file mode 100644 index 0000000..71400f8 --- /dev/null +++ b/tcllib/modules/struct/disjointset.test @@ -0,0 +1,116 @@ +# -*- tcl -*- +# Test procedures for the disjoint set structure implementation +# Author: Alejandro Eduardo Cruz Paz +# 5 August 2008 + +package require tcltest +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 1.0 + +support { + useAccel [useTcllibC] struct/sets.tcl struct::set + TestAccelInit struct::set +} +testing { + useLocal disjointset.tcl struct::disjointset +} + +############################################################ +# Helper functions +# - Create a disjoint set of many partitions. +# - Sort a set of partitions into a canonical order for comparison. + +proc testset {} { + ::struct::disjointset DS + DS add-partition {1 2 3 4} + DS add-partition {5 6} + DS add-partition 0 + DS add-partition {9 8} + DS add-partition {10 7} + return +} + +proc canonset {partitions} { + set res {} + foreach x $partitions { + lappend res [lsort -dict $x] + } + return [lsort -dict $res] +} + +proc djstate {ds} { + list [canonset [$ds partitions]] [$ds num-partitions] +} + +############################################################ +## Iterate over all loaded implementations, activate +## them in turn, and run the tests for the active +## implementation. + +TestAccelDo struct::set impl { + # The global variable 'impl' is part of the public + # API the testsuite (in set.testsuite) can expect + # from the environment. + + switch -exact -- $impl { + critcl { + if {[package vsatisfies [package present Tcl] 8.5]} { + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "struct::disjointset $m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "struct::disjointset $m" $loarg] + } + + proc Nothing {} { + return [tcltest::wrongNumArgs {struct::disjointset} {cmd ?arg ...?} 0] + } + } else { + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "::struct::disjointset $m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "::struct::disjointset $m" $loarg] + } + + proc Nothing {} { + return [tcltest::wrongNumArgs {::struct::disjointset} {cmd ?arg ...?} 0] + } + } + } + tcl { + if {[package vsatisfies [package present Tcl] 8.5]} { + # In 8.5 head the alias itself is reported, not what it + # resolved to. + proc Nothing {} { + return [tcltest::wrongNumArgs struct::disjointset {cmd args} 0] + } + } else { + proc Nothing {} { + return [tcltest::wrongNumArgs {::struct::disjointset} {cmd args} 0] + } + } + + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "::struct::disjointset::S_$m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "::struct::disjointset::S_$m" $loarg] + } + } + } + + source [localPath disjointset.testsuite] +} + +############################################################ +TestAccelExit struct::set + +testsuiteCleanup diff --git a/tcllib/modules/struct/disjointset.testsuite b/tcllib/modules/struct/disjointset.testsuite new file mode 100644 index 0000000..09f16a6 --- /dev/null +++ b/tcllib/modules/struct/disjointset.testsuite @@ -0,0 +1,223 @@ +# -*- tcl -*- +# Tests for the 'disjointset' module in the 'struct' library. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcllib +# procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2008 by Alejandro Eduardo Cruz Paz +# Copyright (c) 2008 by Andreas Kupries (extended for API changes and error conditions) +# +# RCS: @(#) $Id: disjointset.testsuite,v 1.1 2008/09/10 16:23:14 andreas_kupries Exp $ + +#---------------------------------------------------------------------- + +test disjointset-${impl}-1.0 {disjointset creation} { + ::struct::disjointset DS + set result [djstate DS] + DS destroy + set result +} {{} 0} + +test disjointset-${impl}-1.1 {disjointset creation error} { + catch {::struct::disjointset DS other} msg + set result $msg +} {wrong # args: should be "::struct::disjointset ?name?"} + +#---------------------------------------------------------------------- + +test disjointset-${impl}-2.0 {disjointset add-partition error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS add-partition} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_add-partition {name items} 1] + +test disjointset-${impl}-2.1 {disjointset add-partition error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS add-partition x y} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_add-partition {name items}] + +test disjointset-${impl}-2.2 {disjointset add-partition error, elements already known} { + testset + catch {DS add-partition {1}} msg + DS destroy + set msg +} {The element "1" is already known to the disjoint set ::DS} + +test disjointset-${impl}-2.3 {disjointset add-partition, ok} { + testset + set result [list [DS add-partition {11 14}] [djstate DS]] + DS destroy + set result +} {{} {{0 {1 2 3 4} {5 6} {7 10} {8 9} {11 14}} 6}} + +#---------------------------------------------------------------------- + +test disjointset-${impl}-3.0 {disjointset partitions error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS partitions x} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_partitions {name}] + +test disjointset-${impl}-3.1 {disjointset partitions, ok} { + testset + set result [djstate DS] + DS destroy + set result +} {{0 {1 2 3 4} {5 6} {7 10} {8 9}} 5} + +#---------------------------------------------------------------------- + +test disjointset-${impl}-4.0 {disjointset equal error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS equal} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_equal {name a b} 1] + +test disjointset-${impl}-4.1 {disjointset equal error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS equal x} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_equal {name a b} 2] + +test disjointset-${impl}-4.2 {disjointset equal error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS equal x y z} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_equal {name a b}] + +test disjointset-${impl}-4.3 {disjointset equal error, unknown elements} { + testset + catch {DS equal x 1} msg + DS destroy + set msg +} {The element "x" is not known to the disjoint set ::DS} + +test disjointset-${impl}-4.4 {disjointset equal error, unknown elements} { + testset + catch {DS equal 1 x} msg + DS destroy + set msg +} {The element "x" is not known to the disjoint set ::DS} + +test disjointset-${impl}-4.5 {disjointset equal ok, unequal elements} { + testset + set res [DS equal 1 5] + DS destroy + set res +} 0 + +test disjointset-${impl}-4.6 {disjointset equal ok, equal elements} { + testset + set res [DS equal 4 1] + DS destroy + set res +} 1 + +#---------------------------------------------------------------------- + +test disjointset-${impl}-5.0 {disjointset merge error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS merge} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_merge {name a b} 1] + +test disjointset-${impl}-5.1 {disjointset merge error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS merge x} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_merge {name a b} 2] + +test disjointset-${impl}-5.2 {disjointset merge error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS merge x y z} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_merge {name a b}] + +test disjointset-${impl}-5.3 {disjointset merge error, unknown elements} { + testset + catch {DS merge x 1} msg + DS destroy + set msg +} {The element "x" is not known to the disjoint set ::DS} + +test disjointset-${impl}-5.4 {disjointset merge error, unknown elements} { + testset + catch {DS merge 1 x} msg + DS destroy + set msg +} {The element "x" is not known to the disjoint set ::DS} + +test disjointset-${impl}-5.5 {disjointset merge ok, different partitions} { + testset + DS merge 1 5 + set result [djstate DS] + DS destroy + set result +} {{0 {1 2 3 4 5 6} {7 10} {8 9}} 4} + +test disjointset-${impl}-5.6 {disjointset merge ok, same partition, no change} { + testset + DS merge 4 3 + set result [djstate DS] + DS destroy + set result +} {{0 {1 2 3 4} {5 6} {7 10} {8 9}} 5} + +#---------------------------------------------------------------------- + +test disjointset-${impl}-6.0 {disjointset find error, wrong#args, missing} { + ::struct::disjointset DS + catch {DS find} msg + DS destroy + set msg +} [tcltest::wrongNumArgs ::struct::disjointset::_find {name item} 1] + +test disjointset-${impl}-6.1 {disjointset find error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS find x y} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_find {name item}] + +test disjointset-${impl}-6.2 {disjointset find, unknown element} { + testset + set result [DS find 11] + DS destroy + set result +} {} + +test disjointset-${impl}-6.3 {disjointset find, known element} { + testset + set result [lsort -dict [DS find 3]] + DS destroy + set result +} {1 2 3 4} + +#---------------------------------------------------------------------- + +test disjointset-${impl}-7.0 {disjointset num-partitions error, wrong#args, too many} { + ::struct::disjointset DS + catch {DS num-partitions x} msg + DS destroy + set msg +} [tcltest::tooManyArgs ::struct::disjointset::_num-partitions {name}] + +test disjointset-${impl}-7.1 {disjointset num-partitions, ok} { + testset + set result [DS num-partitions] + DS destroy + set result +} 5 + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph.man b/tcllib/modules/struct/graph.man new file mode 100644 index 0000000..e8b80c5 --- /dev/null +++ b/tcllib/modules/struct/graph.man @@ -0,0 +1,942 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::graph n 2.4] +[keywords adjacent] +[keywords arc] +[keywords cgraph] +[keywords degree] +[keywords edge] +[keywords graph] +[keywords loop] +[keywords neighbour] +[keywords node] +[keywords serialization] +[keywords subgraph] +[keywords vertex] +[copyright {2002-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate directed graph objects}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::graph [opt 2.4]] +[require struct::list [opt 1.5]] +[require struct::set [opt 2.2.3]] +[description] +[para] + +A directed graph is a structure containing two collections of +elements, called [term nodes] and [term arcs] respectively, together +with a relation ("connectivity") that places a general structure upon +the nodes and arcs. + +[para] + +Each arc is connected to two nodes, one of which is called the + +[term source] and the other the [term target]. This imposes a +direction upon the arc, which is said to go from the source to the +target. It is allowed that source and target of an arc are the same +node. Such an arc is called a [term loop]. + +Whenever a node is either the source or target of an arc both are said +to be [term adjacent]. This extends into a relation between nodes, +i.e. if two nodes are connected through at least one arc they are said +to be [term adjacent] too. + +[para] + +Each node can be the source and target for any number of arcs. The +former are called the [term {outgoing arcs}] of the node, the latter +the [term {incoming arcs}] of the node. The number of arcs in either +set is called the [term in-degree] resp. the [term out-degree] of the +node. + +[para] + +In addition to maintaining the node and arc relationships, this graph +implementation allows any number of named [term attributes] to be +associated with the graph itself, and each node or arc. + +[para] + +[emph Note:] The major version of the package [package struct] has +been changed to version 2.0, due to backward incompatible changes in +the API of this module. Please read the section + +[sectref {Changes for 2.0}] for a full list of all changes, +incompatible and otherwise. + +[para] + +[emph Note:] A C-implementation of the command can be had from the +location [uri http://www.purl.org/NET/schlenker/tcl/cgraph]. See also +[uri http://wiki.tcl.tk/cgraph]. This implementation uses a bit less +memory than the tcl version provided here directly, and is faster. Its +support is limited to versions of the package before 2.0. + +[para] + +As of version 2.2 of this package a critcl based C implementation is +available from here as well. This implementation however requires Tcl +8.4 to run. + +[para] + +The main command of the package is: + +[list_begin definitions] + +[call [cmd ::struct::graph] [opt [arg graphName]] \ + [opt "[const =]|[const :=]|[const as]|[const deserialize] [arg source]"]] + +The command creates a new graph object with an associated global Tcl +command whose name is [arg graphName]. This command may be used to +invoke various operations on the graph. It has the following general +form: + +[list_begin definitions] +[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] +[para] + +If [arg graphName] is not specified a unique name will be generated by +the package itself. If a [arg source] is specified the new graph will +be initialized to it. For the operators [const =], [const :=], and +[const as] the [arg source] argument is interpreted as the name of +another graph object, and the assignment operator [method =] will be +executed. For the operator [const deserialize] the [arg source] is a +serialized graph object and [method deserialize] will be executed. + +[para] + +In other words +[para] +[example { + ::struct::graph mygraph = b +}] +[para] +is equivalent to +[para] +[example { + ::struct::graph mygraph + mygraph = b +}] +[para] +and +[para] +[example { + ::struct::graph mygraph deserialize $b +}] +[para] +is equivalent to +[para] +[example { + ::struct::graph mygraph + mygraph deserialize $b +}] + +[list_end] + +[para] + +The following commands are possible for graph objects: + +[list_begin definitions] + +[call [arg graphName] [method =] [arg sourcegraph]] + +This is the [term assignment] operator for graph objects. It copies +the graph contained in the graph object [arg sourcegraph] over the +graph data in [arg graphName]. The old contents of [arg graphName] are +deleted by this operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg graphName] [method deserialize] [lb][arg sourcegraph] [method serialize][rb] +[example_end] + +[para] + +The operation assumes that the [arg sourcegraph] provides the method +[method serialize] and that this method returns a valid graph +serialization. + +[call [arg graphName] [method -->] [arg destgraph]] + +This is the [term {reverse assignment}] operator for graph objects. It +copies the graph contained in the graph object [arg graphName] over +the graph data in the object [arg destgraph]. + +The old contents of [arg destgraph] are deleted by this operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg destgraph] [method deserialize] [lb][arg graphName] [method serialize][rb] +[example_end] + +[para] + +The operation assumes that the [arg destgraph] provides the method +[method deserialize] and that this method takes a graph serialization. + +[call [arg graphName] [method append] [arg key] [arg value]] + +Appends a [arg value] to one of the keyed values associated with the graph. +Returns the new value given to the attribute [arg key]. + +[call [arg graphName] [method deserialize] [arg serialization]] + +This is the complement to [method serialize]. It replaces the graph +data in [arg graphName] with the graph described by the +[arg serialization] value. The old contents of [arg graphName] are +deleted by this operation. + +[call [arg graphName] [method destroy]] + +Destroys the graph, including its storage space and associated command. + +[call [arg graphName] [method {arc append}] [arg arc] [arg key] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +[arg arc]. Returns the new value given to the attribute [arg key]. + +[call [arg graphName] [method {arc attr}] [arg key]] +[call [arg graphName] [method {arc attr}] [arg key] [option -arcs] [arg list]] +[call [arg graphName] [method {arc attr}] [arg key] [option -glob] [arg globpattern]] +[call [arg graphName] [method {arc attr}] [arg key] [option -regexp] [arg repattern]] + +This method retrieves the value of the attribute named [arg key], for +all arcs in the graph (matching the restriction specified via one of +the possible options) and having the specified attribute. + +[para] + +The result is a dictionary mapping from arc names to the value of +attribute [arg key] at that arc. + +Arcs not having the attribute [arg key], or not passing a +specified restriction, are not listed in the result. + +[para] + +The possible restrictions are: + +[list_begin options] +[opt_def -arcs] + +The value is a list of arcs. Only the arcs mentioned in this list +are searched for the attribute. + +[opt_def -glob] + +The value is a glob pattern. Only the arcs in the graph whose names +match this pattern are searched for the attribute. + +[opt_def -regexp] + +The value is a regular expression. Only the arcs in the graph whose +names match this pattern are searched for the attribute. + +[list_end] +[para] + +[call [arg graphName] [method {arc delete}] [arg arc] [opt "[arg arc] ..."]] + +Remove the specified arcs from the graph. + +[call [arg graphName] [method {arc exists}] [arg arc]] + +Return true if the specified [arg arc] exists in the graph. + +[call [arg graphName] [method {arc flip}] [arg arc]] + +Reverses the direction of the named [arg arc], i.e. the source and +target nodes of the arc are exchanged with each other. + +[call [arg graphName] [method {arc get}] [arg arc] [arg key]] + +Returns the value associated with the key [arg key] for the [arg arc]. + +[call [arg graphName] [method {arc getall}] [arg arc] [opt [arg pattern]]] + +Returns a dictionary (suitable for use with [lb][cmd {array set}][rb]) +for the [arg arc]. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned dictionary. The pattern +is a [cmd glob] pattern. + +[call [arg graphName] [method {arc getunweighted}]] + +Returns a list containing the names of all arcs in the graph which +have no weight associated with them. + +[call [arg graphName] [method {arc getweight}] [arg arc]] + +Returns the weight associated with the [arg arc]. Throws an error if +the arc has no weight associated with it. + +[call [arg graphName] [method {arc keys}] [arg arc] [opt [arg pattern]]] + +Returns a list of keys for the [arg arc]. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned list. The pattern is a +[cmd glob] pattern. + +[call [arg graphName] [method {arc keyexists}] [arg arc] [arg key]] + +Return true if the specified [arg key] exists for the [arg arc]. + +[call [arg graphName] [method {arc insert}] [arg start] [arg end] [opt [arg child]]] + +Insert an arc named [arg child] into the graph beginning at the node +[arg start] and ending at the node [arg end]. If the name of the new +arc is not specified the system will generate a unique name of the +form [emph arc][arg x]. + +[call [arg graphName] [method {arc lappend}] [arg arc] [arg key] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg arc]. Returns the new value given to the +attribute [arg key]. + +[call [arg graphName] [method {arc rename}] [arg arc] [arg newname]] + +Renames the arc [arg arc] to [arg newname]. An error is thrown if +either the arc does not exist, or a arc with name [arg newname] does +exist. The result of the command is the new name of the arc. + +[call [arg graphName] [method {arc set}] [arg arc] [arg key] [opt [arg value]]] + +Set or get one of the keyed values associated with an arc. + +An arc may have any number of keyed values associated with it. +If [arg value] is not specified, this command returns the current value assigned to the key; +if [arg value] is specified, this command assigns that value to the key, and returns +that value. + +[call [arg graphName] [method {arc setunweighted}] [opt [arg weight]]] + +Sets the weight of all arcs without a weight to [arg weight]. Returns +the empty string as its result. If not present [arg weight] defaults +to [const 0]. + +[call [arg graphName] [method {arc setweight}] [arg arc] [arg weight]] + +Sets the weight of the [arg arc] to [arg weight]. Returns [arg weight]. + +[call [arg graphName] [method {arc unsetweight}] [arg arc]] + +Removes the weight of the [arg arc], if present. Does nothing +otherwise. Returns the empty string. + +[call [arg graphName] [method {arc hasweight}] [arg arc]] + +Determines if the [arg arc] has a weight associated with it. The +result is a boolean value, [const True] if a weight is defined, and +[const False] otherwise. + +[call [arg graphName] [method {arc source}] [arg arc]] + +Return the node the given [arg arc] begins at. + +[call [arg graphName] [method {arc target}] [arg arc]] + +Return the node the given [arg arc] ends at. + +[call [arg graphName] [method {arc nodes}] [arg arc]] + +Return the nodes the given [arg arc] begins and ends at, +as a two-element list. + +[call [arg graphName] [method {arc move-source}] [arg arc] [arg newsource]] + +Changes the source node of the arc to [arg newsource]. It can be said +that the arc rotates around its target node. + +[call [arg graphName] [method {arc move-target}] [arg arc] [arg newtarget]] + +Changes the target node of the arc to [arg newtarget]. It can be said +that the arc rotates around its source node. + +[call [arg graphName] [method {arc move}] [arg arc] [arg newsource] [arg newtarget]] + +Changes both source and target nodes of the arc to [arg newsource], +and [arg newtarget] resp. + +[call [arg graphName] [method {arc unset}] [arg arc] [arg key]] + +Remove a keyed value from the arc [arg arc]. The method will do +nothing if the [arg key] does not exist. + +[call [arg graphName] [method {arc weights}]] + +Returns a dictionary whose keys are the names of all arcs which have a +weight associated with them, and the values are these weights. + +[call [arg graphName] [method arcs] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-filter [arg cmdprefix]"] [opt "-in|-out|-adj|-inner|-embedding [arg {node node...}]"]] + +Returns a list of arcs in the graph. If no restriction is specified a +list containing all arcs is returned. Restrictions can limit the list +of returned arcs based on the nodes that are connected by the arc, on +the keyed values associated with the arc, or both. A general filter +command can be used as well. The restrictions that involve connected +nodes take a variable number of nodes as argument, specified after the +name of the restriction itself. + +[para] + +The restrictions imposed by either [option -in], [option -out], +[option -adj], [option -inner], or [option -embedded] are applied +first. Specifying more than one of them is illegal. + +[para] + +After that the restrictions set via [option -key] (and +[option -value]) are applied. Specifying more than one [option -key] +(and [option -value]) is illegal. Specifying [option -value] alone, +without [option -key] is illegal as well. + +[para] + +Any restriction set through [option -filter] is applied +last. Specifying more than one [option -filter] is illegal. + +[para] + +Coming back to the restrictions based on a set of nodes, the command +recognizes the following switches: + +[list_begin definitions] +[def [option -in]] + +Return a list of all arcs whose target is one of the nodes in the set +of nodes. I.e. it computes the union of all incoming arcs of the nodes +in the set. + +[def [option -out]] + +Return a list of all arcs whose source is one of the nodes in the set +of nodes. I.e. it computes the union of all outgoing arcs of the nodes +in the set. + +[def [option -adj]] + +Return a list of all arcs adjacent to at least one of the nodes in the +set. This is the union of the nodes returned by [option -in] and +[option -out]. + +[def [option -inner]] + +Return a list of all arcs which are adjacent to two of the nodes in +the set. This is the set of arcs in the subgraph spawned by the +specified nodes. + +[def [option -embedding]] + +Return a list of all arcs adjacent to exactly one of the nodes in the +set. This is the set of arcs connecting the subgraph spawned by the +specified nodes to the rest of the graph. + +[def "[option -key] [arg key]"] + +Limit the list of arcs that are returned to those arcs that have an +associated key [arg key]. + +[def "[option -value] [arg value]"] + +This restriction can only be used in combination with + +[option -key]. It limits the list of arcs that are returned to those +arcs whose associated key [arg key] has the value [arg value]. + +[def "[option -filter] [arg cmdrefix]"] + +Limit the list of arcs that are returned to those arcs that pass the +test. The command in [arg cmdprefix] is called with two arguments, the +name of the graph object, and the name of the arc in question. It is +executed in the context of the caller and has to return a boolean +value. Arcs for which the command returns [const false] are removed +from the result list before it is returned to the caller. + +[list_end] + +[call [arg graphName] [method lappend] [arg key] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with the graph. Returns the new value given to the +attribute [arg key]. + +[call [arg graphName] [method {node append}] [arg node] [arg key] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +[arg node]. Returns the new value given to the attribute [arg key]. + +[call [arg graphName] [method {node attr}] [arg key]] +[call [arg graphName] [method {node attr}] [arg key] [option -nodes] [arg list]] +[call [arg graphName] [method {node attr}] [arg key] [option -glob] [arg globpattern]] +[call [arg graphName] [method {node attr}] [arg key] [option -regexp] [arg repattern]] + +This method retrieves the value of the attribute named [arg key], for +all nodes in the graph (matching the restriction specified via one of +the possible options) and having the specified attribute. + +[para] + +The result is a dictionary mapping from node names to the value of +attribute [arg key] at that node. + +Nodes not having the attribute [arg key], or not passing a +specified restriction, are not listed in the result. + +[para] + +The possible restrictions are: + +[list_begin options] +[opt_def -nodes] + +The value is a list of nodes. Only the nodes mentioned in this list +are searched for the attribute. + +[opt_def -glob] + +The value is a glob pattern. Only the nodes in the graph whose names +match this pattern are searched for the attribute. + +[opt_def -regexp] + +The value is a regular expression. Only the nodes in the graph whose +names match this pattern are searched for the attribute. + +[list_end] +[para] + +[call [arg graphName] [method {node degree}] [opt -in|-out] [arg node]] + +Return the number of arcs adjacent to the specified [arg node]. If one +of the restrictions [option -in] or [option -out] is given only the +incoming resp. outgoing arcs are counted. + +[call [arg graphName] [method {node delete}] [arg node] [opt "[arg node]..."]] + +Remove the specified nodes from the graph. All of the nodes' arcs +will be removed as well to prevent unconnected arcs. + +[call [arg graphName] [method {node exists}] [arg node]] + +Return true if the specified [arg node] exists in the graph. + +[call [arg graphName] [method {node get}] [arg node] [arg key]] + +Return the value associated with the key [arg key] for the [arg node]. + +[call [arg graphName] [method {node getall}] [arg node] [opt [arg pattern]]] + +Returns a dictionary (suitable for use with [lb][cmd {array set}][rb]) +for the [arg node]. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned dictionary. The pattern +is a [cmd glob] pattern. + +[call [arg graphName] [method {node keys}] [arg node] [opt [arg pattern]]] + +Returns a list of keys for the [arg node]. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned list. The pattern is a +[cmd glob] pattern. + +[call [arg graphName] [method {node keyexists}] [arg node] [arg key]] + +Return true if the specified [arg key] exists for the [arg node]. + +[call [arg graphName] [method {node insert}] [opt [arg node]...]] + +Insert one or more nodes into the graph. The new nodes have no arcs +connected to them. If no node is specified one node will be inserted, +and the system will generate a unique name of the form +[emph node][arg x] for it. + +[call [arg graphName] [method {node lappend}] [arg node] [arg key] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg node]. Returns the new value given to the +attribute [arg key]. + +[call [arg graphName] [method {node opposite}] [arg node] [arg arc]] + +Return the node at the other end of the specified [arg arc], which has +to be adjacent to the given [arg node]. + +[call [arg graphName] [method {node rename}] [arg node] [arg newname]] + +Renames the node [arg node] to [arg newname]. An error is thrown if +either the node does not exist, or a node with name [arg newname] does +exist. The result of the command is the new name of the node. + +[call [arg graphName] [method {node set}] [arg node] [arg key] [opt [arg value]]] + +Set or get one of the keyed values associated with a node. A node may have any +number of keyed values associated with it. If [arg value] is not +specified, this command returns the current value assigned to the key; +if [arg value] is specified, this command assigns that value to the +key. + +[call [arg graphName] [method {node unset}] [arg node] [arg key]] + +Remove a keyed value from the node [arg node]. The method will do +nothing if the [arg key] does not exist. + +[call [arg graphName] [method nodes] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-filter [arg cmdprefix]"] [opt "-in|-out|-adj|-inner|-embedding [arg node] [arg node]..."]] + +Return a list of nodes in the graph. Restrictions can limit the list +of returned nodes based on neighboring nodes, or based on the keyed +values associated with the node. The restrictions that involve +neighboring nodes have a list of nodes as argument, specified after +the name of the restriction itself. + +[para] + +The possible restrictions are the same as for method +[method arcs]. The exact meanings change slightly, as they operate on +nodes instead of arcs. The command recognizes: + +[list_begin definitions] +[def [option -in]] + +Return a list of all nodes with at least one outgoing arc ending in a +node found in the specified set of nodes. Alternatively specified as +the set of source nodes for the [option -in] arcs of the node set. The +[term {incoming neighbours}]. + +[def [option -out]] + +Return a list of all nodes with at least one incoming arc starting in +a node found in the specified set of nodes. Alternatively specified as +the set of target nodes for the [option -out] arcs of the node +set. The [term {outgoing neighbours}]. + +[def [option -adj]] + +This is the union of the nodes returned by [option -in] and +[option -out]. The [term neighbours]. + +[def [option -inner]] + +The set of neighbours (see [option -adj] above) which are also in the +set of nodes. I.e. the intersection between the set of nodes and the +neighbours per [option -adj]. + +[def [option -embedding]] + +The set of neighbours (see [option -adj] above) which are not in the +set of nodes. I.e. the difference between the neighbours as per +[option -adj], and the set of nodes. + +[def "[option -key] [arg key]"] + +Limit the list of nodes that are returned to those nodes that have an +associated key [arg key]. + +[def "[option -value] [arg value]"] + +This restriction can only be used in combination with +[option -key]. It limits the list of nodes that are returned to those +nodes whose associated key [arg key] has the value [arg value]. + +[def "[option -filter] [arg cmdrefix]"] + +Limit the list of nodes that are returned to those nodes that pass the +test. The command in [arg cmdprefix] is called with two arguments, the +name of the graph object, and the name of the node in question. It is +executed in the context of the caller and has to return a boolean +value. Nodes for which the command returns [const false] are removed +from the result list before it is returned to the caller. + +[list_end] + +[call [arg graphName] [method get] [arg key]] + +Return the value associated with the key [arg key] for the graph. + +[call [arg graphName] [method getall] [opt [arg pattern]]] + +Returns a dictionary (suitable for use with [lb][cmd {array set}][rb]) +for the whole graph. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned dictionary. The pattern +is a [cmd glob] pattern. + +[call [arg graphName] [method keys] [opt [arg pattern]]] + +Returns a list of keys for the whole graph. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned list. The pattern is a +[cmd glob] pattern. + +[call [arg graphName] [method keyexists] [arg key]] + +Return true if the specified [arg key] exists for the whole graph. + +[call [arg graphName] [method serialize] [opt [arg node]...]] + +This method serializes the sub-graph spanned up by the [arg node]s. In +other words it returns a tcl value completely describing that +graph. If no nodes are specified the whole graph will be serialized. + +This allows, for example, the transfer of graph objects (or parts +thereof) over arbitrary channels, persistence, etc. + +This method is also the basis for both the copy constructor and +the assignment operator. + +[para] + +The result of this method has to be semantically identical over all +implementations of the graph interface. This is what will enable us to +copy graph data between different implementations of the same +interface. + +[para] + +The result is a list containing a multiple of three items, plus one! +In other words, '[lb]llength $serial[rb] % 3 == 1'. Valid values +include 1, 4, 7, ... + +[para] + +The last element of the list is a dictionary containing the attributes +associated with the whole graph. + +Regarding the other elements; each triple consists of + +[list_begin enumerated] +[enum] +The name of the node to be described, + +[enum] +A dictionary containing the attributes associated with the node, + +[enum] +And a list describing all the arcs starting at that node. +[list_end] +[para] + +The elements of the arc list are lists containing three or four +elements each, i.e. + +[list_begin enumerated] +[enum] +The name of the arc described by the element, + +[enum] + +A reference to the destination node of the arc. This reference is an +integer number given the index of that node in the main serialization +list. As that it is greater than or equal to zero, less than the +length of the serialization, and a multiple of three. + +[emph Note:] For internal consistency no arc name may be used twice, +whether in the same node, or at some other node. This is a global +consistency requirement for the serialization. + +[enum] +And a dictionary containing the attributes associated with the arc. + +[enum] +The weight associated with the arc. This value is optional. Its +non-presence means that the arc in question has no weight associated +with it. + +[para][emph Note:] This information is new, compared to the +serialization of [package graph] 2.3 and earlier. By making it an +optional element the new format is maximally compatible with the +old. This means that any graph not using weights will generate a +serialization which is still understood by the older graph package. A +serialization will not be understood any longer by the older packages +if, and only if the graph it was generated from actually has arcs with +weights. + +[list_end] +[para] + +For all attribute dictionaries they keys are the names of the +attributes, and the values are the values for each name. + +[para] + +[emph Note:] The order of the nodes in the serialization has no +relevance, nor has the order of the arcs per node. + +[example { + # A possible serialization for the graph structure + # + # d -----> %2 + # / ^ \\ + # / / \\ + # / b \\ + # / / \\ + # %1 <- a - %0 e + # ^ \\ / + # \\ c / + # \\ \\ / + # \\ v v + # f ------ %3 + # is + # + # %3 {} {{f 6 {}}} %0 {} {{a 6 {}} {b 9 {}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {} + # + # This assumes that the graph has neither attribute data nor weighted arcs. +}] +[para] + +[call [arg graphName] [method set] [arg key] [opt [arg value]]] + +Set or get one of the keyed values associated with a graph. A graph +may have any number of keyed values associated with it. If [arg value] +is not specified, this command returns the current value assigned to +the key; if [arg value] is specified, this command assigns that value +to the key. + +[call [arg graphName] [method swap] [arg node1] [arg node2]] + +Swap the position of [arg node1] and [arg node2] in the graph. + +[call [arg graphName] [method unset] [arg key]] + +Remove a keyed value from the graph. The method will do nothing if the +[arg key] does not exist. + +[call [arg graphName] [method walk] [arg node] \ + [opt "-order [arg order]"] \ + [opt "-type [arg type]"] \ + [opt "-dir [arg direction]"] \ + -command [arg cmd]] + +Perform a breadth-first or depth-first walk of the graph starting at +the node [arg node] going in either the direction of outgoing or +opposite to the incoming arcs. + +[para] + +The type of walk, breadth-first or depth-first, is determined by the +value of [arg type]; [const bfs] indicates breadth-first, + +[const dfs] indicates depth-first. Depth-first is the default. + +[para] + +The order of the walk, pre-order, post-order or both-order is +determined by the value of [arg order]; [const pre] indicates +pre-order, [const post] indicates post-order, [const both] indicates +both-order. Pre-order is the default. Pre-order walking means that a +node is visited before any of its neighbors (as defined by the + +[arg direction], see below). Post-order walking means that a parent is +visited after any of its neighbors. Both-order walking means that a +node is visited before [emph and] after any of its neighbors. The +combination of a breadth-first walk with post- or both-order is illegal. + +[para] + +The direction of the walk is determined by the value of [arg dir]; +[const backward] indicates the direction opposite to the incoming +arcs, [const forward] indicates the direction of the outgoing arcs. + +[para] + +As the walk progresses, the command [arg cmd] will be evaluated at +each node, with the mode of the call ([const enter] or +[const leave]) and values [arg graphName] and the name of the current +node appended. For a pre-order walk, all nodes are [const enter]ed, for a +post-order all nodes are left. In a both-order walk the first visit of +a node [const enter]s it, the second visit [const leave]s it. + +[list_end] + +[section {Changes for 2.0}] +The following noteworthy changes have occurred: + +[list_begin enumerated] +[enum] + +The API for accessing attributes and their values has been +simplified. + +[para] + +All functionality regarding the default attribute "data" has been +removed. This default attribute does not exist anymore. All accesses +to attributes have to specify the name of the attribute in +question. This backward [emph incompatible] change allowed us to +simplify the signature of all methods handling attributes. + +[para] + +Especially the flag [option -key] is not required anymore, even more, +its use is now forbidden. Please read the documentation for the arc +and node methods [method set], [method get], [method getall], + +[method unset], [method append], [method lappend], [method keyexists] +and [method keys] for a description of the new API's. + +[enum] + +The methods [method keys] and [method getall] now take an optional +pattern argument and will return only attribute data for keys matching +this pattern. + +[enum] + +Arcs and nodes can now be renamed. See the documentation for the +methods [method {arc rename}] and [method {node rename}]. + +[enum] + +The structure has been extended with API's for the serialization and +deserialization of graph objects, and a number of operations based on +them (graph assignment, copy construction). + +[para] + +Please read the documentation for the methods [method serialize], +[method deserialize], [method =], and [method -->], and the +documentation on the construction of graph objects. + +[para] + +Beyond the copying of whole graph objects these new API's also enable +the transfer of graph objects over arbitrary channels and for easy +persistence. + +[enum] + +A new method, [method attr], was added to both [method arc] and +[method node] allowing the query and retrieval of attribute data +without regard to arc and node relationships. + +[enum] + +Both methods [method arcs] and [method nodes] have been extended with +the ability to select arcs and nodes based on an arbitrary filtering +criterium. + +[list_end] + +[vset CATEGORY {struct :: graph}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/graph.tcl b/tcllib/modules/struct/graph.tcl new file mode 100644 index 0000000..95d579e --- /dev/null +++ b/tcllib/modules/struct/graph.tcl @@ -0,0 +1,180 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2005 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph.tcl,v 1.33 2009/09/24 16:23:47 andreas_kupries Exp $ + +# @mdgen EXCLUDE: graph_c.tcl + +package require Tcl 8.4 + +namespace eval ::struct::graph {} + +# ### ### ### ######### ######### ######### +## Management of graph implementations. + +# ::struct::graph::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::graph::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of graph requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::graph_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir graph_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::graph::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::graph::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::graph ::struct::graph_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::graph_$key ::struct::graph + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::graph::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::graph::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::graph::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::graph::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::graph::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::graph { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::graph { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export graph +} + +package provide struct::graph 2.4 diff --git a/tcllib/modules/struct/graph.test b/tcllib/modules/struct/graph.test new file mode 100644 index 0000000..98400ae --- /dev/null +++ b/tcllib/modules/struct/graph.test @@ -0,0 +1,49 @@ +# -*- tcl -*- +# graph.test: tests for the graph structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: graph.test,v 1.27 2007/04/12 03:01:54 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + useLocal list.tcl struct::list + + useAccel [useTcllibC] struct/sets.tcl struct::set + TestAccelInit struct::set + + useLocalFile graph/tests/Xsupport +} +testing { + useAccel [useTcllibC] struct/graph.tcl struct::graph + TestAccelInit struct::graph +} + +# ------------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in graph.testsuite) is expecting from the environment. + +TestAccelDo struct::set setimpl { + TestAccelDo struct::graph impl { + source [localPath graph/tests/Xcontrol] + } +} + +#---------------------------------------------------------------------- +TestAccelExit struct::graph +TestAccelExit struct::set +testsuiteCleanup diff --git a/tcllib/modules/struct/graph/arc.c b/tcllib/modules/struct/graph/arc.c new file mode 100644 index 0000000..017d957 --- /dev/null +++ b/tcllib/modules/struct/graph/arc.c @@ -0,0 +1,197 @@ +/* struct::tree - critcl - layer 1 declarations + * (b) Arc operations. + */ + +#include <arc.h> +#include <attr.h> +#include <graph.h> +#include <util.h> + +/* .................................................. */ + +static GL* gla_link (GA* a, GL* i, GN* n, GLA* na); +static void gla_unlink (GL* i, GLA* na); + +/* .................................................. */ + +GA* +ga_new (G* g, const char* name, GN* src, GN* dst) +{ + GA* a; + + if (Tcl_FindHashEntry (g->arcs.map, name) != NULL) { + Tcl_Panic ("struct::graph(c) ga_new - tried to use duplicate name for new arc"); + } + + a = ALLOC (GA); + + gc_setup ((GC*) a, &g->arcs, name, g); + gc_add ((GC*) a, &g->arcs); + + ga_shimmer_self (a); + + /* node / arc linkage */ + + a->start = gla_link (a, ALLOC (GL), src, &src->out); + a->end = gla_link (a, ALLOC (GL), dst, &dst->in); + a->weight = NULL; /* New arcs have no weight */ + + return a; +} + +/* .................................................. */ + +void +ga_delete (GA* a) +{ + gc_remove ((GC*) a, &a->base.graph->arcs); + gc_delete ((GC*) a); + + /* interlink removal */ + + gla_unlink (a->start, &a->start->n->out); + gla_unlink (a->end, &a->end->n->in); + + ckfree ((char*) a->start); a->start = NULL; + ckfree ((char*) a->end); a->end = NULL; + + if (a->weight) { + Tcl_DecrRefCount (a->weight); + a->weight = NULL; + } + + ckfree ((char*) a); +} + +/* .................................................. */ + +void +ga_mv_src (GA* a, GN* nsrc) +{ + GN* src = a->start->n; + + if (src == nsrc) return; + + gla_unlink (a->start, &src->out); + gla_link (a, a->start, nsrc, &nsrc->out); +} + +/* .................................................. */ + +void +ga_mv_dst (GA* a, GN* ndst) +{ + GN* dst = a->end->n; + + if (dst == ndst) return; + + gla_unlink (a->end, &dst->in); + gla_link (a, a->end, ndst, &ndst->in); +} + +/* .................................................. */ + +Tcl_Obj* +ga_serial (GA* a, Tcl_Obj* empty, int nodeId) +{ + Tcl_Obj* lv [4]; + + lv [0] = a->base.name; + lv [1] = Tcl_NewIntObj (nodeId); + lv [2] = g_attr_serial (a->base.attr, empty); + + if (a->weight) { + lv [3] = a->weight; + return Tcl_NewListObj (4, lv); + } else { + return Tcl_NewListObj (3, lv); + } +} + +/* .................................................. */ + +void +ga_err_duplicate (Tcl_Interp* interp, Tcl_Obj* a, Tcl_Obj* g) +{ + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "arc \"", -1); + Tcl_AppendObjToObj (err, a); + Tcl_AppendToObj (err, "\" already exists in graph \"", -1); + Tcl_AppendObjToObj (err, g); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); +} + +/* .................................................. */ + +void +ga_err_missing (Tcl_Interp* interp, Tcl_Obj* a, Tcl_Obj* g) +{ + Tcl_Obj* err = Tcl_NewObj (); + + /* Keep any prefix ... */ + Tcl_AppendObjToObj (err, Tcl_GetObjResult (interp)); + Tcl_AppendToObj (err, "arc \"", -1); + Tcl_AppendObjToObj (err, a); + Tcl_AppendToObj (err, "\" does not exist in graph \"", -1); + Tcl_AppendObjToObj (err, g); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); +} + +/* .................................................. */ + +static GL* +gla_link (GA* a, GL* il, GN* n, GLA* na) +{ + il->n = n; + il->a = a; + + if (na->first) { + na->first->prev = il; + } + + il->prev = NULL; + il->next = na->first; + + na->first = il; + na->n ++; + + return il; +} + +/* .................................................. */ + +static void +gla_unlink (GL* il, GLA* na) +{ + if (na->first == il) { + na->first = il->next; + } + if (il->next) { + il->next->prev = il->prev; + } + if (il->prev) { + il->prev->next = il->next; + } + + il->n = NULL; + il->a = NULL; + il->prev = NULL; + il->next = NULL; + + na->n --; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/arc.h b/tcllib/modules/struct/graph/arc.h new file mode 100644 index 0000000..b7485b7 --- /dev/null +++ b/tcllib/modules/struct/graph/arc.h @@ -0,0 +1,40 @@ +/* struct::graph - critcl - layer 1 declarations + * (b) Node operations. + */ + +#ifndef _G_ARC_H +#define _G_ARC_H 1 + +#include "tcl.h" +#include <ds.h> + +void ga_shimmer (Tcl_Obj* o, GA* a); +GA* ga_get_arc (G* g, Tcl_Obj* arc, Tcl_Interp* interp, Tcl_Obj* graph); + +#define ga_shimmer_self(a) \ + ga_shimmer ((a)->base.name, (a)) + +GA* ga_new (G* g, const char* name, GN* src, GN* dst); +GA* ga_dup (G* dst, GA* src); +void ga_delete (GA* a); + +void ga_arc (GA* a); +void ga_notarc (GA* a); + +void ga_mv_src (GA* a, GN* nsrc); +void ga_mv_dst (GA* a, GN* ndst); + +void ga_err_duplicate (Tcl_Interp* interp, Tcl_Obj* a, Tcl_Obj* g); +void ga_err_missing (Tcl_Interp* interp, Tcl_Obj* a, Tcl_Obj* g); + +Tcl_Obj* ga_serial (GA* a, Tcl_Obj* empty, int nodeId); + +#endif /* _G_ARC_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/arcshimmer.c b/tcllib/modules/struct/graph/arcshimmer.c new file mode 100644 index 0000000..e8322f7 --- /dev/null +++ b/tcllib/modules/struct/graph/arcshimmer.c @@ -0,0 +1,137 @@ +/* struct::graph - critcl - layer 1 definitions. + * (b) Arc operations. + * Tcl_ObjType for arcs, and shimmering to it. + */ + +#include <string.h> +#include <arc.h> + +/* .................................................. */ + +static void free_rep (Tcl_Obj* obj); +static void dup_rep (Tcl_Obj* obj, Tcl_Obj* dup); +static void string_rep (Tcl_Obj* obj); +static int from_any (Tcl_Interp* ip, Tcl_Obj* obj); + +static +Tcl_ObjType ga_type = { + "tcllib::struct::graph/critcl::arc", + free_rep, + dup_rep, + string_rep, + from_any +}; + +/* .................................................. */ + +static void +free_rep (Tcl_Obj* obj) +{ + /* Nothing to do. The rep is the GA in the G. */ +} + +static void +dup_rep (Tcl_Obj* obj, Tcl_Obj* dup) +{ + GA* a = (GA*) obj->internalRep.otherValuePtr; + + dup->internalRep.otherValuePtr = a; + dup->typePtr = &ga_type; +} + +static void +string_rep (Tcl_Obj* obj) +{ + Tcl_Obj* temp; + char* str; + GA* a = (GA*) obj->internalRep.otherValuePtr; + + obj->length = a->base.name->length; + obj->bytes = ckalloc (obj->length + 1); + + memcpy (obj->bytes, a->base.name->bytes, obj->length + 1); +} + +static int +from_any (Tcl_Interp* ip, Tcl_Obj* obj) +{ + Tcl_Panic ("Cannot create GA structure via regular shimmering."); + return TCL_ERROR; +} + +/* .................................................. */ + +void +ga_shimmer (Tcl_Obj* o, GA* a) +{ + /* Release an existing representation */ + + if (o->typePtr && o->typePtr->freeIntRepProc) { + o->typePtr->freeIntRepProc (o); + } + + o->typePtr = &ga_type; + o->internalRep.otherValuePtr = a; +} + +/* .................................................. */ + +GA* +ga_get_arc (G* g, Tcl_Obj* arc, Tcl_Interp* interp, Tcl_Obj* graph) +{ + GA* a = NULL; + Tcl_HashEntry* he; + + /* Check if we have a valid cached int.rep. */ + +#if 0 + /* [x] TODO */ + /* Caching of handles implies that the graphs have to */ + /* keep track of the tcl_obj pointing to them. So that */ + /* the int.rep can be invalidated upon graph deletion */ + + if (arc->typePtr == &ga_type) { + a = (GA*) arc->internalRep.otherValuePtr; + if (a->graph == g) { +#if 0 + fprintf (stderr, "cached: %p (%p - %p)\n", a, t, a->graph); + fflush(stderr); +#endif + return a; + } + } +#endif + /* Incompatible int.rep, or refering to a different + * graph. We go through the hash table. + */ + + he = Tcl_FindHashEntry (g->arcs.map, Tcl_GetString (arc)); + + if (he) { + a = (GA*) Tcl_GetHashValue (he); + + /* Shimmer the object, cache the arc information. + */ + + ga_shimmer (arc, a); + return a; + } + + /* Arc handle not found. Leave an error message, + * if possible. + */ + + if (interp != NULL) { + ga_err_missing (interp, arc, graph); + } + return NULL; +} + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/attr.c b/tcllib/modules/struct/graph/attr.c new file mode 100644 index 0000000..d6e56db --- /dev/null +++ b/tcllib/modules/struct/graph/attr.c @@ -0,0 +1,443 @@ +/* struct::graph - critcl - layer 1 definitions + * (c) Graph functions + */ + +#include <attr.h> +#include <util.h> + +/* .................................................. */ + +Tcl_Obj* +g_attr_serial (Tcl_HashTable* attr, Tcl_Obj* empty) +{ + int i; + Tcl_Obj* res; + int listc; + Tcl_Obj** listv; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + const char* key; + + if ((attr == NULL) || (attr->numEntries == 0)) { + return empty; + } + + listc = 2 * attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for(i = 0, he = Tcl_FirstHashEntry(attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (attr, he); + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i] = Tcl_NewStringObj (key, -1); i++; + listv [i] = (Tcl_Obj*) Tcl_GetHashValue(he); i++; + } + + res = Tcl_NewListObj (listc, listv); + ckfree ((char*) listv); + return res; +} + +/* .................................................. */ + +int +g_attr_serok (Tcl_Interp* interp, Tcl_Obj* aserial, const char* what) +{ + int lc; + Tcl_Obj** lv; + + if (Tcl_ListObjGetElements (interp, aserial, &lc, &lv) != TCL_OK) { + return 0; + } + if ((lc % 2) != 0) { + Tcl_AppendResult (interp, + "error in serialization: malformed ", + what, " attribute dictionary.", + NULL); + return 0; + } + return 1; +} + +/* .................................................. */ + +void +g_attr_deserial (Tcl_HashTable** Astar, Tcl_Obj* dict) +{ + Tcl_HashEntry* he; + CONST char* key; + Tcl_Obj* val; + int new, i; + int listc; + Tcl_Obj** listv; + Tcl_HashTable* attr; + + /* NULL can happen via 'g_attr_dup' */ + if (!dict) return; + + Tcl_ListObjGetElements (NULL, dict, &listc, &listv); + + if (!listc) return; + + g_attr_extend (Astar); + attr = *Astar; + + for (i = 0; i < listc; i+= 2) { + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + key = Tcl_GetString (listv [i]); + val = listv [i+1]; + + he = Tcl_CreateHashEntry(attr, key, &new); + + Tcl_IncrRefCount (val); + Tcl_SetHashValue (he, (ClientData) val); + } +} + +/* .................................................. */ + +void +g_attr_delete (Tcl_HashTable** Astar) +{ + Tcl_HashTable* A = *Astar; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + + if (!A) return; + Astar = NULL; + + for(he = Tcl_FirstHashEntry(A, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + } + Tcl_DeleteHashTable(A); + ckfree ((char*) A); +} + +/* .................................................. */ + +void +g_attr_keys (Tcl_HashTable* attr, Tcl_Interp* interp, int pc, Tcl_Obj* const* pv) +{ + int listc; + Tcl_Obj** listv; + Tcl_HashEntry* he; + Tcl_HashSearch hs; + const char* key; + int i; + const char* pattern; + int matchall = 0; + + if ((attr == NULL) || (attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return; + } + + listc = attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + if (pc) { + pattern = Tcl_GetString(pv[0]); + matchall = (strcmp (pattern, "*") == 0); + } + + if (!pc || matchall) { + /* Unpatterned retrieval, or pattern '*' */ + + for (i = 0, he = Tcl_FirstHashEntry(attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + ASSERT_BOUNDS (i, listc); + listv [i++] = Tcl_NewStringObj (Tcl_GetHashKey (attr, he), -1); + } + + ASSERT (i == listc, "Bad key retrieval"); + + } else { + /* Filtered retrieval, glob pattern */ + + for (i = 0, he = Tcl_FirstHashEntry(attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (attr, he); + if (Tcl_StringMatch(key, pattern)) { + ASSERT_BOUNDS (i, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + } + } + + ASSERT (i <= listc, "Bad key glob retrieval"); + listc = i; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); +} + +/* .................................................. */ + +void +g_attr_kexists (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key) +{ + Tcl_HashEntry* he; + const char* ky = Tcl_GetString (key); + + if ((attr == NULL) || (attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewIntObj (0)); + return; + } + + he = Tcl_FindHashEntry (attr, ky); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (he != NULL)); +} + +/* .................................................. */ + +int +g_attr_get (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* o, const char* sep) +{ + Tcl_Obj* av; + Tcl_HashEntry* he = (attr + ? Tcl_FindHashEntry (attr, Tcl_GetString (key)) + : NULL); + + if (!he) { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "invalid key \"", -1); + Tcl_AppendObjToObj (err, key); + Tcl_AppendToObj (err, sep, -1); + Tcl_AppendObjToObj (err, o); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + av = (Tcl_Obj*) Tcl_GetHashValue(he); + Tcl_SetObjResult (interp, av); + return TCL_OK; +} + +/* .................................................. */ + +void +g_attr_getall (Tcl_HashTable* attr, Tcl_Interp* interp, int pc, Tcl_Obj* const* pv) +{ + Tcl_HashEntry* he; + Tcl_HashSearch hs; + const char* key; + int i; + int listc; + Tcl_Obj** listv; + const char* pattern = NULL; + int matchall = 0; + + if ((attr == NULL) || (attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return; + } + + if (pc) { + pattern = Tcl_GetString (pv [0]); + matchall = (strcmp (pattern, "*") == 0); + } + + listc = 2 * attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + if (!pc || matchall) { + /* Unpatterned retrieval, or pattern '*' */ + + for (i = 0, he = Tcl_FirstHashEntry(attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (attr, he); + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + ASSERT (i == listc, "Bad attribute retrieval"); + } else { + /* Filtered retrieval, glob pattern */ + + for (i = 0, he = Tcl_FirstHashEntry(attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (attr, he); + + if (Tcl_StringMatch(key, pattern)) { + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + } + + ASSERT (i <= listc, "Bad attribute glob retrieval"); + listc = i; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); +} + +/* .................................................. */ + +void +g_attr_unset (Tcl_HashTable* attr, Tcl_Obj* key) +{ + const char* ky = Tcl_GetString (key); + + if (attr) { + Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky); + if (he) { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + Tcl_DeleteHashEntry (he); + } + } +} + +/* .................................................. */ + +void +g_attr_set (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value) +{ + const char* ky = Tcl_GetString (key); + Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky); + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(attr, ky, &new); + } else { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + } + + Tcl_IncrRefCount (value); + Tcl_SetHashValue (he, (ClientData) value); + Tcl_SetObjResult (interp, value); +} + +/* .................................................. */ + +void +g_attr_append (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value) +{ + const char* ky = Tcl_GetString (key); + Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky); + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(attr, ky, &new); + + Tcl_IncrRefCount (value); + Tcl_SetHashValue (he, (ClientData) value); + } else { + Tcl_Obj* av = (Tcl_Obj*) Tcl_GetHashValue(he); + + if (Tcl_IsShared (av)) { + Tcl_DecrRefCount (av); + av = Tcl_DuplicateObj (av); + Tcl_IncrRefCount (av); + + Tcl_SetHashValue (he, (ClientData) av); + } + + Tcl_AppendObjToObj (av, value); + value = av; + } + + Tcl_SetObjResult (interp, value); +} + +/* .................................................. */ + +void +g_attr_lappend (Tcl_HashTable* attr, Tcl_Interp* interp, Tcl_Obj* key, Tcl_Obj* value) +{ + const char* ky = Tcl_GetString (key); + Tcl_HashEntry* he = Tcl_FindHashEntry (attr, ky); + Tcl_Obj* av; + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(attr, ky, &new); + + av = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (av); + Tcl_SetHashValue (he, (ClientData) av); + + } else { + av = (Tcl_Obj*) Tcl_GetHashValue(he); + + if (Tcl_IsShared (av)) { + Tcl_DecrRefCount (av); + av = Tcl_DuplicateObj (av); + Tcl_IncrRefCount (av); + + Tcl_SetHashValue (he, (ClientData) av); + } + } + + Tcl_ListObjAppendElement (interp, av, value); + Tcl_SetObjResult (interp, av); +} + +/* .................................................. */ + +void +g_attr_extend (Tcl_HashTable** Astar) +{ + if (*Astar) return; + + *Astar = ALLOC (Tcl_HashTable); + Tcl_InitHashTable (*Astar, TCL_STRING_KEYS); +} + +/* .................................................. */ + +void +g_attr_dup (Tcl_HashTable** Astar, Tcl_HashTable* src) +{ + g_attr_deserial (Astar, + g_attr_serial (src, NULL)); +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/attr.h b/tcllib/modules/struct/graph/attr.h new file mode 100644 index 0000000..b896897 --- /dev/null +++ b/tcllib/modules/struct/graph/attr.h @@ -0,0 +1,49 @@ +/* struct::graph - critcl - layer 1 declarations + * (c) Graph functions + */ + +#ifndef _G_ATTR_H +#define _G_ATTR_H 1 +/* .................................................. */ + +#include "tcl.h" +#include <ds.h> + +/* .................................................. */ + +void g_attr_dup (Tcl_HashTable** Astar, Tcl_HashTable* src); +void g_attr_extend (Tcl_HashTable** Astar); +void g_attr_delete (Tcl_HashTable** Astar); +void g_attr_keys (Tcl_HashTable* attr, Tcl_Interp* interp, + int pc, Tcl_Obj* const* pv); +void g_attr_kexists (Tcl_HashTable* attr, Tcl_Interp* interp, + Tcl_Obj* key); +void g_attr_set (Tcl_HashTable* attr, Tcl_Interp* interp, + Tcl_Obj* key, Tcl_Obj* value); +void g_attr_append (Tcl_HashTable* attr, Tcl_Interp* interp, + Tcl_Obj* key, Tcl_Obj* value); +void g_attr_lappend (Tcl_HashTable* attr, Tcl_Interp* interp, + Tcl_Obj* key, Tcl_Obj* value); +int g_attr_get (Tcl_HashTable* attr, Tcl_Interp* interp, + Tcl_Obj* key, Tcl_Obj* o, const char* sep); +void g_attr_getall (Tcl_HashTable* attr, Tcl_Interp* interp, + int pc, Tcl_Obj* const* pv); +void g_attr_unset (Tcl_HashTable* attr, Tcl_Obj* key); +int gc_attr (GCC* gx, int mode, Tcl_Obj* detail, + Tcl_Interp* interp, Tcl_Obj* key, + GN_GET_GC* gf, G* g); +int g_attr_serok (Tcl_Interp* interp, Tcl_Obj* aserial, + const char* what); +Tcl_Obj* g_attr_serial (Tcl_HashTable* attr, Tcl_Obj* empty); +void g_attr_deserial (Tcl_HashTable** Astar, Tcl_Obj* dict); + +/* .................................................. */ +#endif /* _G_ATTR_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/ds.h b/tcllib/modules/struct/graph/ds.h new file mode 100644 index 0000000..047549c --- /dev/null +++ b/tcllib/modules/struct/graph/ds.h @@ -0,0 +1,178 @@ +/* struct::graph - critcl - layer 1 declarations + * (a) Data structures. + */ + +#ifndef _DS_H +#define _DS_H 1 + +#include "tcl.h" + +/* + * The data structures for a graph are mainly double-linked lists, combined + * with hash maps. + * + * We have a single structure per interpreter, -> GG. This structure holds + * the counter and string buffer for the generation of automatic graph names. + * + * We have one structure per graph, -> G. It holds a single hash map for the + * attributes, and two hash maps with associated lists for nodes and arcs. The + * maps are for retrieval by name, the lists when searches by various features + * are done. Beyond we have the counters and string buffer for the generation + * of automatic arc- and node-names. As the information for nodes and arcs are + * identical they are pulled together in their own common structure -> GCC. + * + * The basic information of both nodes and arcs themselves is the same as + * well, name and attributes, and the graph owning them. Pulled together in a + * common structure, -> GC. This also holds the prev/next linkage for the per + * graph lists starting in GCC. The node/arc structures are pseudo-derived + * from this structure. + * + * Each node manages two lists of arcs, incoming and outgoing ones. The list + * elements are -> GL structures, also called the interlinks, as they weld + * nodes and arcs together. Neither node nor arcs refer directly to each + * other, but go through these interlinks. The indirection allows the + * insertion, movement and removal of arcs without having to perform complex + * updates in the node and arc structures. Like shifting array elements, with + * O(n^2) effort. The list anchors are -> GLA structures, keeping track of the + * list length as well. + * + * Arcs manage their source/target directly, by refering to the relevant + * interlink structures. + */ + +/* + * Forward declarations of references to graphs, nodes, and arcs. + */ + +typedef struct GL* GLPtr; /* node/arc interlink */ +typedef struct GC* GCPtr; /* node/arc common */ +typedef struct GN* GNPtr; /* node */ +typedef struct GA* GAPtr; /* arc */ +typedef struct G* GPtr; /* graph */ +typedef struct GG* GGPtr; /* Per-interp (global) */ + +/* + * Chains of arcs, structure for interlinkage between nodes and arcs. + * Operations API & Impl. -> gl.[ch] + */ + +typedef struct GL { + GNPtr n; /* Node the interlink belongs to */ + GAPtr a; /* Arc the interlink belongs to */ + GLPtr prev; /* Previous interlink in chain */ + GLPtr next; /* Next interlink in chain */ +} GL; + +/* + * Data common to nodes and arcs + */ + +typedef struct GC { + /* Identity / handle */ + /* Internal rep should be of type */ + /* 'tcllib::struct::graph/critcl::{node,arc}'. */ + /* See below. */ + + Tcl_Obj* name; + Tcl_HashEntry* he; + + /* Node / Arc attributes */ + + Tcl_HashTable* attr; /* NULL if the entity has no attributes */ + + /* Basic linkage of node/arc to its graph */ + + GPtr graph; /* Graph the node/arc belongs to */ + GCPtr next; /* Double linked list of all */ + GCPtr prev; /* nodes/arc. See GGC for the head */ +} GC; + +/* + * Interlink chains, anchor structure + */ + +typedef struct GLA { + GL* first; /* First interlink */ + int n; /* Number of interlinks */ +} GLA; + +/* + * Node structure. + */ + +typedef struct GN { + GC base; /* Basics, common information */ + + /* Node navigation. Incoming/Outgoing arcs, via interlink chains. */ + + GLA in; + GLA out; +} GN; + +/* + * Arc structure. + */ + +typedef struct GA { + GC base; /* Basics, common information */ + + /* Arc navigation. Start/End node. Indirect specification through an + * interlink. + */ + + GL* start; /* Interlink to node where arc begins */ + GL* end; /* Interlink to node where arc ends */ + + Tcl_Obj* weight; /* If not NULL the weight of the arc */ +} GA; + +/* + * Helper structure for the lists and maps of nodes/arcs. + */ + +typedef struct GCC { + Tcl_HashTable* map; /* Mapping names -> structure */ + GC* first; /* Start of entity list */ + int n; /* Length of the list */ +} GCC; + +/* + * Graph structure. + */ + +typedef struct G { + Tcl_Command cmd; /* Token of the object command for * the graph */ + GCC nodes; /* All nodes */ + GCC arcs; /* All arcs */ + Tcl_HashTable* attr; /* Graph attributes. NULL if the graph has none */ + + /* Generation of node and arc handles. Graph local storage, makes the code + * thread oblivious. + */ + + char handle [50]; + int ncounter; /* Counter used by the generator of node names */ + int acounter; /* Counter used by the generator of arc names */ +} G; + +/* + * 'Global' management. One structure per interpreter. + */ + +typedef struct GG { + long int counter; /* Graph id generator */ + char buf [50]; /* Buffer for handle construction */ +} GG; + + +typedef GC* (GN_GET_GC) (G* g, Tcl_Obj* x, Tcl_Interp* interp, Tcl_Obj* graph); + +#endif /* _DS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/filter.c b/tcllib/modules/struct/graph/filter.c new file mode 100644 index 0000000..2775af6 --- /dev/null +++ b/tcllib/modules/struct/graph/filter.c @@ -0,0 +1,1209 @@ +/* struct::graph - critcl - layer 1 definitions + * (c) Graph functions + */ + +#include <nacommon.h> +#include <util.h> +#include <node.h> + +/* .................................................. */ + +typedef enum NA_MODE { + NA_ADJ, NA_EMBEDDING, NA_IN, NA_INNER, + NA_OUT, NA_NONE +} NA_MODE; + +typedef struct NA { + NA_MODE mode; + int nc; + Tcl_Obj** nv; + Tcl_Obj* key; + Tcl_Obj* value; + Tcl_Obj* filter; +} NA; + +typedef struct NARES { + int c; + Tcl_Obj** v; +} NARES; + +/* .................................................. */ + +static int filter_setup (NA* na, Tcl_Interp* interp, int oc, Tcl_Obj* const* ov, G* g); +static int filter_run (NA* na, Tcl_Interp* interp, int nodes, GCC* gx, GN_GET_GC* gf, + Tcl_Obj* go, G* g); +static void filter_none (Tcl_Interp* interp, GCC* gx, NARES* l); +static void filter_kv (Tcl_Interp* interp, GCC* gx, NARES* l, + GN_GET_GC* gf, G*g, Tcl_Obj* k, Tcl_Obj* v); +static void filter_k (Tcl_Interp* interp, GCC* gx, NARES* l, + GN_GET_GC* gf, G* g, Tcl_Obj* k); +static int filter_cmd (Tcl_Interp* interp, GCC* gx, NARES* l, + Tcl_Obj* cmd, Tcl_Obj* g); + +static void filter_mode_n (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_n_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_n_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_n_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_n_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_n_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); +static void filter_mode_a_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g); + +/* .................................................. */ + +int +gc_filter (int nodes, Tcl_Interp* interp, + int oc, Tcl_Obj* const* ov, + GCC* gx, GN_GET_GC* gf, G* g) +{ + NA na; + + if (filter_setup (&na, interp, oc, ov, g) != TCL_OK) { + return TCL_ERROR; + } + + return filter_run (&na, interp, nodes, gx, gf, ov [0], g); +} + +/* .................................................. */ + +static int +filter_setup (NA* na, Tcl_Interp* interp, int oc, Tcl_Obj* const* ov, G* g) +{ + /* Syntax: graph arcs | all arcs + * graph arcs -adj NODE... | arcs start|end in node in list + * graph arcs -embedding NODE... | arcs start^end in node in list + * graph arcs -filter CMDPREFIX | arcs for which CMD returns True. + * graph arcs -in NODE... | arcs end in node in list + * graph arcs -inner NODE... | arcs start&end in node in list + * graph arcs -key KEY | arcs have attribute KEY + * graph arcs -out NODE... | arcs start in node in list + * graph arcs -value VALUE | arcs have KEY and VALUE + * [0] [1] [2] [3] + */ + + static const char* restr [] = { + "-adj", "-embedding", "-filter", "-in", + "-inner", "-key", "-out", "-value", + NULL + }; + enum restr { + R_ADJ, R_EMB, R_CMD, R_IN, + R_INNER, R_KEY, R_OUT, R_VAL + }; + static const int mode [] = { + NA_ADJ, NA_EMBEDDING, -1, NA_IN, + NA_INNER, -1, NA_OUT, -1 + }; + + int ac = oc; + Tcl_Obj* const* av = ov; + int r; + + na->mode = NA_NONE; + na->nc = 0; + na->nv = NALLOC (oc, Tcl_Obj*); + na->key = NULL; + na->value = NULL; + na->filter = NULL; + + oc -= 2; /* Skip 'graph arcs' */ + ov += 2; + + while (oc) { + if ('-' == Tcl_GetString (ov[0])[0]) { + if (Tcl_GetIndexFromObj (interp, ov [0], restr, + "restriction", 0, &r) != TCL_OK) { + goto abort; + } + switch (r) { + case R_ADJ: + case R_EMB: + case R_IN: + case R_INNER: + case R_OUT: + if (na->mode != NA_NONE) { + Tcl_SetObjResult (interp, + Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"", -1)); + goto abort; + } + na->mode = mode [r]; + break; + case R_CMD: + if (oc < 2) goto wrongargs; + if (na->filter) { + Tcl_SetObjResult (interp, + Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-filter\"", -1)); + goto abort; + } + na->filter = ov [1]; + oc --; + ov ++; + break; + case R_KEY: + if (oc < 2) goto wrongargs; + if (na->key) { + Tcl_SetObjResult (interp, + Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-key\"", -1)); + goto abort; + } + na->key = ov [1]; + oc --; + ov ++; + break; + case R_VAL: + if (oc < 2) goto wrongargs; + if (na->value) { + Tcl_SetObjResult (interp, + Tcl_NewStringObj ("invalid restriction: illegal multiple use of \"-value\"", -1)); + goto abort; + } + na->value = ov [1]; + oc --; + ov ++; + break; + } + oc --; + ov ++; + } else { + /* Save non-options for the list of nodes */ + ASSERT_BOUNDS (na->nc, ac); + na->nv [na->nc] = ov[0]; + na->nc ++; + oc --; + ov ++; + } + } + + if (na->value && !na->key) { + Tcl_SetObjResult (interp, + Tcl_NewStringObj ("invalid restriction: use of \"-value\" without \"-key\"", -1)); + goto abort; + } + + if ((na->mode != NA_NONE) && !na->nc) { + wrongargs: + Tcl_WrongNumArgs (interp, 2, av, + "?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?"); + goto abort; + } + + if (!na->nc) { + ckfree((char*) na->nv); + na->nv = NULL; + } else { + /* Check that the nodes exist, and + * remove duplicates in the same pass + */ + + int i, j, new; + Tcl_HashTable cn; + GN* n; + + Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS); + + j=0; + for (i=0; i < na->nc; i++) { + ASSERT_BOUNDS(i, na->nc); + n = gn_get_node (g, na->nv[i], interp, av[0]); + if (!n) { + Tcl_DeleteHashTable(&cn); + goto abort; + } + if (Tcl_FindHashEntry (&cn, (char*) n)) continue; + ASSERT_BOUNDS(j, na->nc); + Tcl_CreateHashEntry (&cn, (char*) n, &new); + if (j < i) { na->nv[j] = na->nv[i]; } + j ++; + } + + Tcl_DeleteHashTable(&cn); + na->nc = j; + } + return TCL_OK; + + abort: + ckfree((char*) na->nv); + return TCL_ERROR; +} + +/* .................................................. */ + +static int +filter_run (NA* na, Tcl_Interp* interp, int nodes, GCC* gx, GN_GET_GC* gf, Tcl_Obj* go, G* g) +{ + NARES l; + + if (!gx->n) { + /* Nothing to filter, ignore the filters */ + + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return TCL_OK; + } + + l.c = -1; + l.v = NALLOC (gx->n, Tcl_Obj*); + + if (!na->key && + !na->filter && + (na->mode == NA_NONE)) { + filter_none (interp, gx, &l); + } else { + if (na->mode != NA_NONE) { + if (nodes) { + filter_mode_n (na->mode, gx, &l, na->nc, na->nv, g); + } else { + filter_mode_a (na->mode, gx, &l, na->nc, na->nv, g); + } + } + if (na->key && na->value) { + filter_kv (interp, gx, &l, gf, g, na->key, na->value); + } else if (na->key) { + filter_k (interp, gx, &l, gf, g, na->key); + } + if (na->filter) { + if (filter_cmd (interp, gx, &l, na->filter, go) != TCL_OK) { + ckfree ((char*) l.v); + return TCL_ERROR; + } + } + } + + ASSERT(l.c > -1, "No filters applied"); + Tcl_SetObjResult (interp, Tcl_NewListObj (l.c, l.v)); + ckfree ((char*) l.v); + return TCL_OK; +} + +/* .................................................. */ + +static void +filter_none (Tcl_Interp* interp, GCC* gx, NARES* l) +{ + int i; + GC* iter; + + for (i = 0, iter = gx->first; + iter != NULL; + iter = iter->next, i++) { + ASSERT_BOUNDS (i, gx->n); + l->v [i] = iter->name; + } + + ASSERT (i == gx->n, "Bad list of nodes"); + l->c = i; +} + +/* .................................................. */ + +static void +filter_mode_a (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NS = {node ...}, a set of nodes + * + * ARC/in (NS) := { a | target(a) in NS } "Arcs going into the node set" + * ARC/out (NS) := { a | source(a) in NS } "Arcs coming from the node set" + * ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) "Arcs touching the node set" + * ARC/inn (NS) := ARC/in (NS) * ARC/out (NS) "Arcs connecting nodes in the set" + * ARC/emb (NS) := ARC/adj (NS) - ARC/inn (NS) "Arcs touching, yet not connecting" + * = ARC/in (NS) / ARc/out (NS) 'symmetric difference' + * + * Note: None of the iterations has to be concerned about space. It is + * bounded by the number of arcs in the graph, and the list has enough + * slots. + */ + + switch (mode) { + case NA_ADJ: filter_mode_a_adj (gx, l, nc, nv, g); break; + case NA_EMBEDDING: filter_mode_a_emb (gx, l, nc, nv, g); break; + case NA_IN: filter_mode_a_in (gx, l, nc, nv, g); break; + case NA_INNER: filter_mode_a_inn (gx, l, nc, nv, g); break; + case NA_OUT: filter_mode_a_out (gx, l, nc, nv, g); break; + } +} + +/* .................................................. */ + +static void +filter_mode_a_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) + * "Arcs touching the node set" + */ + + /* Iterate over the nodes and collect all incoming and outgoing arcs. We + * use a hash table to prevent us from entering arcs twice. If we find + * that all arcs are in the result we stop immediately. + */ + + int i, j, new; + GL* il; + Tcl_HashTable ht; + GN* n; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a, &new); + l->v[j] = il->a->base.name; + j ++; + } + } + + ASSERT(j <= gx->n, "Overrun"); + + if (j < gx->n) { + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + /* Skip if already present - union */ + if (Tcl_FindHashEntry (&ht, (char*) il->a)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a, &new); + l->v[j] = il->a->base.name; + j ++; + } + if (j == gx->n) break; + } + } + + ASSERT(j <= gx->n, "Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); +} + +/* .................................................. */ + +static void +filter_mode_a_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* ARC/emb (NS) := ARC/adj (NS) - ARC/inn (NS) + * = ARC/in (NS) / ARc/out (NS) + * "Arcs touching, yet not connecting" + */ + + /* For the embedding we have to iterate several times. First to collect + * the relevant arcs in hashtables, then a last time using the hashtables + * to weed out the inner arcs, i.e the intersection, and collect the + * others. + */ + + int i, j, new; + GL* il; + Tcl_HashTable hti; + Tcl_HashTable hto; + GN* n; + + Tcl_InitHashTable (&hti, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable (&hto, TCL_ONE_WORD_KEYS); + + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + Tcl_CreateHashEntry (&hti, (char*) il->a, &new); + } + } + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + Tcl_CreateHashEntry (&hto, (char*) il->a, &new); + } + } + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + /* Incoming arcs, skip if also outgoing */ + if (Tcl_FindHashEntry (&hto, (char*) il->a)) continue; + ASSERT_BOUNDS(j, gx->n); + l->v[j] = il->a->base.name; + j ++; + } + } + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + /* Outgoing arcs, skip if also incoming */ + if (Tcl_FindHashEntry (&hti, (char*) il->a)) continue; + ASSERT_BOUNDS(j, gx->n); + l->v[j] = il->a->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&hti); + Tcl_DeleteHashTable(&hto); +} + +/* .................................................. */ + +static void +filter_mode_a_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* ARC/in (NS) := { a | target(a) in NS } + * "Arcs going into the node set" + */ + + /* Iterate over the nodes and collect all incoming arcs. */ + + int i, j; + GL* il; + GN* n; + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + ASSERT_BOUNDS(j, gx->n); + l->v[j] = il->a->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; +} + +/* .................................................. */ + +static void +filter_mode_a_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* ARC/inn (NS) := ARC/in (NS) * ARC/out (NS) + * "Arcs connecting nodes in the set" + */ + + /* Iterate over the nodes and collect all incoming arcs first, in a + * hashtable. Then iterate a second time to find all outgoing arcs which + * are also incoming. We skip the second iteration if the first one found all + * arcs, because then the intersection will remove nothing. + */ + + int i, j, new; + GL* il; + Tcl_HashTable ht; + GN* n; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + Tcl_CreateHashEntry (&ht, (char*) il->a, &new); + } + } + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + /* Note the !. This is the intersect */ + if (!Tcl_FindHashEntry (&ht, (char*) il->a)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a, &new); + l->v[j] = il->a->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); +} + +/* .................................................. */ + +static void +filter_mode_a_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* ARC/out (NS) := { a | source(a) in NS } + * "Arcs coming from the node set" + */ + + /* Iterate over the nodes and collect all outcoming arcs. */ + + int i, j; + GL* il; + GN* n; + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + ASSERT_BOUNDS(j, gx->n); + l->v[j] = il->a->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; +} + +/* .................................................. */ + +static void +filter_mode_n (NA_MODE mode, GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/in (NS) = { source(a) | a in ARC/in (NS) } + * NODES/out (NS) = { target(a) | a in ARC/out (NS) } + * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS) + * NODES/inn (NS) = NODES/adj (NS) * NS + * NODES/emb (NS) = NODES/adj (NS) - NS + */ + + switch (mode) { + case NA_ADJ: filter_mode_n_adj (gx, l, nc, nv, g); break; + case NA_EMBEDDING: filter_mode_n_emb (gx, l, nc, nv, g); break; + case NA_IN: filter_mode_n_in (gx, l, nc, nv, g); break; + case NA_INNER: filter_mode_n_inn (gx, l, nc, nv, g); break; + case NA_OUT: filter_mode_n_out (gx, l, nc, nv, g); break; + } +} + +/* .................................................. */ + +static void +filter_mode_n_adj (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS) + * + * using: + * NODES/in (NS) = { source(a) | a in ARC/in (NS) } + * NODES/out (NS) = { target(a) | a in ARC/out (NS) } + */ + + /* Iterate over the nodes and collect all incoming and outgoing nodes. We + * use a hash table to prevent us from entering nodes twice. Should we + * find that all nodes are in the result during the iteration we stop + * immediately, it cannot get better. + */ + + int i, j, new; + GL* il; + Tcl_HashTable ht; + GN* n; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + /* foreach n in cn */ + + for (il = n->in.first; il != NULL; il = il->next) { + /* foreach a in ARC/in (n) */ + /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */ + + if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new); + l->v[j] = il->a->start->n->base.name; + j ++; + } + if (j == gx->n) break; + for (il = n->out.first; il != NULL; il = il->next) { + /* foreach a in ARC/out (n) */ + /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */ + + if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new); + l->v[j] = il->a->end->n->base.name; + j ++; + } + if (j == gx->n) break; + } + + ASSERT(j <= gx->n, "Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); +} + +/* .................................................. */ + +static void +filter_mode_n_emb (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/emb (NS) = NODES/adj (NS) - NS + * + * using: + * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS) + * + * using: + * NODES/in (NS) = { source(a) | a in ARC/in (NS) } + * NODES/out (NS) = { target(a) | a in ARC/out (NS) } + */ + + /* Iterate over the nodes and collect all incoming and outgoing nodes. We + * use a hash table to prevent us from entering nodes twice. A second hash + * table is used to skip over the nodes in the set itself. + */ + + int i, j, new; + GL* il; + Tcl_HashTable ht; + Tcl_HashTable cn; + GN* n; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS); + + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + /* foreach n in cn */ + Tcl_CreateHashEntry (&cn, (char*) n, &new); + } + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + /* foreach n in cn */ + + for (il = n->in.first; il != NULL; il = il->next) { + /* foreach a in ARC/in (n) */ + /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */ + /* - NS */ + + if (Tcl_FindHashEntry (&cn, (char*) il->a->start->n)) continue; + if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new); + l->v[j] = il->a->start->n->base.name; + j ++; + } + if (j == gx->n) break; + for (il = n->out.first; il != NULL; il = il->next) { + /* foreach a in ARC/out (n) */ + /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */ + /* - NS */ + + if (Tcl_FindHashEntry (&cn, (char*) il->a->end->n)) continue; + if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new); + l->v[j] = il->a->end->n->base.name; + j ++; + } + if (j == gx->n) break; + } + + ASSERT(j <= gx->n, "Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); + Tcl_DeleteHashTable(&cn); +} + +/* .................................................. */ + +static void +filter_mode_n_in (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/in (NS) = { source(a) | a in ARC/in (NS) } + */ + + int i, j, new; + GL* il; + GN* n; + Tcl_HashTable ht; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->in.first; il != NULL; il = il->next) { + /* il->a in INa (NS) => il->a->start in INn (NS), + * modulo already recorded + */ + if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new); + l->v[j] = il->a->start->n->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); +} + +/* .................................................. */ + +static void +filter_mode_n_inn (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/inn (NS) = NODES/adj (NS) * NS + * + * using: + * NODES/adj (NS) = NODES/in (NS) + NODES/out (NS) + * + * using: + * NODES/in (NS) = { source(a) | a in ARC/in (NS) } + * NODES/out (NS) = { target(a) | a in ARC/out (NS) } + */ + + /* Iterate over the nodes and collect all incoming and outgoing nodes. We + * use a hash table to prevent us from entering nodes twice. A second hash + * table is used to skip over the nodes _not_ in the set itself. + */ + + int i, j, new; + GL* il; + Tcl_HashTable ht; + Tcl_HashTable cn; + GN* n; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS); + + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + /* foreach n in cn */ + Tcl_CreateHashEntry (&cn, (char*) n, &new); + } + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + /* foreach n in cn */ + + for (il = n->in.first; il != NULL; il = il->next) { + /* foreach a in ARC/in (n) */ + /* il->a in ARC/in (NS) => il->a->start->n in NODES/in (NS) */ + /* * NS */ + + if (!Tcl_FindHashEntry (&cn, (char*) il->a->start->n)) continue; + if (Tcl_FindHashEntry (&ht, (char*) il->a->start->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->start->n, &new); + l->v[j] = il->a->start->n->base.name; + j ++; + } + if (j == gx->n) break; + for (il = n->out.first; il != NULL; il = il->next) { + /* foreach a in ARC/out (n) */ + /* il->a in ARC/out (NS) => il->a->end->n in NODES/out (NS) */ + /* * NS */ + + if (!Tcl_FindHashEntry (&cn, (char*) il->a->end->n)) continue; + if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new); + l->v[j] = il->a->end->n->base.name; + j ++; + } + if (j == gx->n) break; + } + + ASSERT(j <= gx->n, "Overrun"); + l->c = j; + + Tcl_DeleteHashTable(&ht); + Tcl_DeleteHashTable(&cn); +} + +/* .................................................. */ + +static void +filter_mode_n_out (GCC* gx, NARES* l, int nc, Tcl_Obj* const* nv, G* g) +{ + /* + * NODES/out (NS) = { target(a) | a in ARC/out (NS) } + */ + + int i, j, new; + GL* il; + GN* n; + Tcl_HashTable ht; + + Tcl_InitHashTable (&ht, TCL_ONE_WORD_KEYS); + + j = 0; + for (i=0; i < nc; i++) { + ASSERT_BOUNDS(i, nc); + n = gn_get_node (g, nv[i], NULL, NULL); + for (il = n->out.first; il != NULL; il = il->next) { + /* il->a in OUTa (NS) => il->a->end in OUTn (NS), + * modulo already recorded + */ + if (Tcl_FindHashEntry (&ht, (char*) il->a->end->n)) continue; + ASSERT_BOUNDS(j, gx->n); + Tcl_CreateHashEntry (&ht, (char*) il->a->end->n, &new); + l->v[j] = il->a->end->n->base.name; + j ++; + } + } + + ASSERT(j <= gx->n,"Overrun"); + l->c = j; + + Tcl_DeleteHashTable (&ht); +} + +/* .................................................. */ + +static void +filter_kv (Tcl_Interp* interp, GCC* gx, NARES* l, GN_GET_GC* gf, G* g, Tcl_Obj* k, Tcl_Obj* v) +{ + /* 2 modes: + * (a) l->c == -1 => Fill with matching entities + * (b) l->c == 0 => Nothing to do. + * (c) otherwise => Filter found entities + */ + + Tcl_HashEntry* he; + const char* key; + const char* value; + int vlen; + const char* cmp; + int clen; + + /* Skip the step if there is nothing which can be filtered. */ + if (l->c == 0) return; + + key = Tcl_GetString (k); + value = Tcl_GetStringFromObj (v, &vlen); + + if (l->c > 0) { + /* Filter an existing set of nodes/arcs down to the set of nodes/arcs + * passing the filter. + */ + + int src, dst; + GC* c; + + for (src = 0, dst = 0; src < l->c; src++) { + c = gf (g, l->v [src], NULL, NULL); + + if (!c->attr) continue; + if (!c->attr->numEntries) continue; + he = Tcl_FindHashEntry (c->attr, key); + if (!he) continue; + cmp = Tcl_GetStringFromObj ((Tcl_Obj*) Tcl_GetHashValue(he), &clen); + if ((vlen != clen) || + (strcmp(value, cmp) != 0)) continue; + + ASSERT_BOUNDS (dst, l->c); + ASSERT_BOUNDS (src, l->c); + + l->v [dst] = l->v [src]; + dst++; + } + + ASSERT (dst <= l->c, "Overrun"); + l->c = dst; + + } else { + /* There is no set, iterate over nodes/arcs and fill the result with + * all nodes/arcs passing the filter. + */ + + int i; + GC* iter; + + for (i = 0, iter = gx->first; + iter != NULL; + iter = iter->next) { + ASSERT_BOUNDS (i, gx->n); + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + cmp = Tcl_GetStringFromObj ((Tcl_Obj*) Tcl_GetHashValue(he), &clen); + if ((vlen != clen) || + (strcmp(value, cmp) != 0)) continue; + + ASSERT_BOUNDS (i, gx->n); + l->v [i] = iter->name; + i++; + } + + ASSERT (i <= gx->n, "Overrun"); + l->c = i; + } +} + +/* .................................................. */ + +static void +filter_k (Tcl_Interp* interp, GCC* gx, NARES* l, GN_GET_GC* gf, G* g, Tcl_Obj* k) +{ + /* 2 modes: + * (a) l->c == -1 => Fill with matching entities + * (b) l->c == 0 => Nothing to do. + * (c) otherwise => Filter found entities + */ + + Tcl_HashEntry* he; + const char* key; + + /* Skip the step if there is nothing which can be filtered. */ + if (l->c == 0) return; + + key = Tcl_GetString (k); + + if (l->c > 0) { + /* Filter an existing set of nodes/arcs down to the set of nodes/arcs + * passing the filter. + */ + + int src, dst; + GC* c; + + for (src = 0, dst = 0; src < l->c; src++) { + c = gf (g, l->v [src], NULL, NULL); + + if (!c->attr) continue; + if (!c->attr->numEntries) continue; + he = Tcl_FindHashEntry (c->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (dst, l->c); + ASSERT_BOUNDS (src, l->c); + + l->v [dst] = l->v [src]; + dst++; + } + + ASSERT (dst <= l->c, "Overrun"); + l->c = dst; + + } else { + /* There is no set, iterate over nodes/arcs and fill the result with + * all nodes/arcs passing the filter. + */ + + int i; + GC* iter; + + for (i = 0, iter = gx->first; + iter != NULL; + iter = iter->next) { + ASSERT_BOUNDS (i, gx->n); + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (i, gx->n); + l->v [i] = iter->name; + i++; + } + + ASSERT (i <= gx->n, "Overrun"); + l->c = i; + } +} + +/* .................................................. */ + +static int +filter_cmd (Tcl_Interp* interp, GCC* gx, NARES* l, Tcl_Obj* cmd, Tcl_Obj* g) +{ + /* 2 modes: + * (a) l->c == -1 => Fill with matching entities + * (b) l->c == 0 => Nothing to do. + * (c) otherwise => Filter found entities + */ + + int cmdc; + Tcl_Obj** cmdv; + int code = TCL_ERROR; + int ec; + Tcl_Obj** ev; + int flag; + int res; + int i; + + if (Tcl_ListObjGetElements (interp, cmd, &cmdc, &cmdv) != TCL_OK) { + return TCL_ERROR; + } + + /* Skip the step if there is nothing which can be filtered. */ + if (l->c == 0) { + return TCL_OK; + } + + /* -------------------- */ + /* Set up the command vector for the callback. Two placeholders for graph + * and node/arc arguments. + */ + + ec = cmdc + 2; + ev = NALLOC (ec, Tcl_Obj*); + + for (i = 0; i < cmdc; i++) { + ASSERT_BOUNDS (i, ec); + ev [i] = cmdv [i]; + Tcl_IncrRefCount (ev [i]); + } + + ASSERT_BOUNDS (cmdc, ec); + ev [cmdc] = g; /* Graph */ + Tcl_IncrRefCount (ev [cmdc]); + + /* -------------------- */ + + if (l->c > 0) { + /* Filter an existing set of nodes/arcs down to the set of nodes/arcs + * passing the filter. + */ + + int src, dst; + + for (src = 0, dst = 0; src < l->c; src++) { + /* Fill the placeholders */ + + ASSERT_BOUNDS (cmdc+1, ec); + ASSERT_BOUNDS (src, l->c); + ev [cmdc+1] = l->v [src]; /* Node/Arc */ + + /* Run the callback */ + Tcl_IncrRefCount (ev [cmdc+1]); + res = Tcl_EvalObjv (interp, ec, ev, 0); + Tcl_DecrRefCount (ev [cmdc+1]); + + /* Process the result */ + if (res != TCL_OK) { + goto abort; + } + if (Tcl_GetBooleanFromObj (interp, + Tcl_GetObjResult (interp), + &flag) != TCL_OK) { + goto abort; + } + + /* Result is valid, use this to decide retain/write over */ + if (!flag) continue; + + ASSERT_BOUNDS (dst, l->c); + ASSERT_BOUNDS (src, l->c); + + l->v [dst] = l->v [src]; + dst++; + } + + ASSERT (dst <= l->c, "Overrun"); + l->c = dst; + + } else { + /* There is no set, iterate over nodes/arcs and fill the result with + * all nodes/arcs passing the filter. + */ + + int i; + GC* iter; + + for (i = 0, iter = gx->first; + iter != NULL; + iter = iter->next) { + ASSERT_BOUNDS (i, gx->n); + + /* Fill the placeholders */ + + ASSERT_BOUNDS (cmdc+1, ec); + ev [cmdc+1] = iter->name; /* Node/Arc */ + + /* Run the callback */ + Tcl_IncrRefCount (ev [cmdc+1]); + res = Tcl_EvalObjv (interp, ec, ev, 0); + Tcl_DecrRefCount (ev [cmdc+1]); + + /* Process the result */ + if (res != TCL_OK) { + goto abort; + } + if (Tcl_GetBooleanFromObj (interp, + Tcl_GetObjResult (interp), + &flag) != TCL_OK) { + goto abort; + } + + /* Result is valid, use this to decide retain/write over */ + if (!flag) continue; + + ASSERT_BOUNDS (i, gx->n); + l->v [i] = iter->name; + i++; + } + + ASSERT (i <= gx->n, "Overrun"); + l->c = i; + } + + /* -------------------- */ + /* Cleanup state */ + + Tcl_ResetResult (interp); + code = TCL_OK; + + abort: + /* We do not reset the interp result. It either contains the non-boolean + * result, or the error message. + */ + + for (i = 0; i < cmdc; i++) { + ASSERT_BOUNDS (i, ec); + Tcl_DecrRefCount (ev [i]); + } + + ASSERT_BOUNDS (cmdc, ec); + Tcl_DecrRefCount (ev [cmdc]); /* Graph */ + ckfree ((char*) ev); + + /* -------------------- */ + return code; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/global.c b/tcllib/modules/struct/graph/global.c new file mode 100644 index 0000000..f884b78 --- /dev/null +++ b/tcllib/modules/struct/graph/global.c @@ -0,0 +1,49 @@ +/* struct::tree - critcl - global declarations + */ + +#include <global.h> +#include <util.h> + +static void release (ClientData cd, Tcl_Interp* interp); + +#define KEY "tcllib/struct::graph/critcl" + +/* .................................................. */ + +const char* +gg_new (Tcl_Interp* interp) +{ + Tcl_InterpDeleteProc* proc = release; + GG* gg = Tcl_GetAssocData (interp, KEY, &proc); + + if (gg == NULL) { + gg = ALLOC (GG); + gg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, (ClientData) gg); + } + + gg->counter ++; + sprintf (gg->buf, "graph%d", gg->counter); + return gg->buf; +} + +/* .................................................. */ + +static void +release (ClientData cd, Tcl_Interp* interp) +{ + /* ClientData cd <=> GG* gg */ + ckfree((char*) cd); +} + +/* .................................................. */ + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/global.h b/tcllib/modules/struct/graph/global.h new file mode 100644 index 0000000..23192c0 --- /dev/null +++ b/tcllib/modules/struct/graph/global.h @@ -0,0 +1,20 @@ +/* struct::graph - critcl - global declarations + */ + +#ifndef _G_GLOBAL_H +#define _G_GLOBAL_H 1 + +#include "tcl.h" +#include <ds.h> + +const char* gg_new (Tcl_Interp* interp); + +#endif /* _G_GLOBAL_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/graph.c b/tcllib/modules/struct/graph/graph.c new file mode 100644 index 0000000..c4fb004 --- /dev/null +++ b/tcllib/modules/struct/graph/graph.c @@ -0,0 +1,706 @@ +/* struct::graph - critcl - layer 1 definitions + * (c) Graph functions + */ + +#include <arc.h> +#include <attr.h> +#include <graph.h> +#include <node.h> +#include <objcmd.h> +#include <util.h> + +/* .................................................. */ + +static void swap (G* dst, G* src); +static G* dup (G* src); + +/* .................................................. */ + +G* +g_new (void) +{ + G* g = ALLOC (G); + + g->nodes.map = ALLOC (Tcl_HashTable); + g->arcs.map = ALLOC (Tcl_HashTable); + + Tcl_InitHashTable (g->nodes.map, TCL_STRING_KEYS); + Tcl_InitHashTable (g->arcs.map, TCL_STRING_KEYS); + + g->nodes.first = NULL; + g->nodes.n = 0; + g->arcs.first = NULL; + g->arcs.n = 0; + + g->attr = NULL; + + g->cmd = NULL; + g->ncounter = 0; + g->acounter = 0; + + return g; +} + +/* .................................................. */ + +void +g_delete (G* g) +{ + /* Delete a graph in toto. Deletes all arcs first, then all nodes. This + * also handles the nodes/arcs lists. Then the name -> node/arc mapping, + * and the object name. + */ + + while (g->arcs.first) { ga_delete ((GA*) g->arcs.first); } + while (g->nodes.first) { gn_delete ((GN*) g->nodes.first); } + + Tcl_DeleteHashTable (g->arcs.map); + Tcl_DeleteHashTable (g->nodes.map); + + ckfree ((char*) g->arcs.map); + ckfree ((char*) g->nodes.map); + + g->arcs.map = NULL; + g->nodes.map = NULL; + + g->cmd = NULL; + + g_attr_delete (&g->attr); + ckfree ((char*) g); +} + +/* .................................................. */ + +const char* +g_newnodename (G* g) +{ + int ok; + Tcl_HashEntry* he; + + do { + g->ncounter ++; + sprintf (g->handle, "node%d", g->ncounter); + + /* Check that there is no node using that name already */ + he = Tcl_FindHashEntry (g->nodes.map, g->handle); + ok = (he == NULL); + } while (!ok); + + return g->handle; +} + +/* .................................................. */ + +const char* +g_newarcname (G* g) +{ + int ok; + Tcl_HashEntry* he; + + do { + g->acounter ++; + sprintf (g->handle, "arc%d", g->acounter); + + /* Check that there is no node using that name already */ + he = Tcl_FindHashEntry (g->arcs.map, g->handle); + ok = (he == NULL); + } while (!ok); + + return g->handle; +} + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * g_ms_serialize -- + * + * Generates Tcl value from graph, serialized graph data. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +g_ms_serialize (Tcl_Interp* interp, Tcl_Obj* go, G* g, int oc, Tcl_Obj* const* ov) +{ + Tcl_Obj* ser; + Tcl_Obj* empty; + + int lc = 1 + 3 * (oc ? oc : g->nodes.n); + Tcl_Obj** lv = NALLOC (lc, Tcl_Obj*); + + Tcl_HashTable cn; + int k, new; + GN* n; + + /* Enumerate the nodes for the references used in arcs. FUTURE, TODO: Skip + * this step if there are no arcs! We cannot skip testing the validity of + * the nodes however, if the set is explicit. In that case we also check + * and remove duplicates. */ + + Tcl_InitHashTable (&cn, TCL_ONE_WORD_KEYS); + + if (oc) { + /* Enumerate the specified nodes, remove duplicates along the way */ + Tcl_HashEntry* he; + int i, j, new; + + j = 0; + for (i=0; i < oc; i++) { + ASSERT_BOUNDS(i, oc); + n = gn_get_node (g, ov[i], interp, go); + if (!n) { + goto abort; + } + if (Tcl_FindHashEntry (&cn, (char*) n)) continue; + ASSERT_BOUNDS(j, lc-1); + he = Tcl_CreateHashEntry (&cn, (char*) n, &new); + lv [j] = n->base.name; + Tcl_SetHashValue (he, (ClientData) j); + j += 3; + } + lc = j + 1; + } else { + /* Enumerate all nodes */ + Tcl_HashEntry* he; + int j, new; + + j = 0; + for (n = (GN*) g->nodes.first; + n != NULL; + n = (GN*) n->base.next) { + + ASSERT_BOUNDS(j, lc-1); + he = Tcl_CreateHashEntry (&cn, (char*) n, &new); + lv [j] = n->base.name; + Tcl_SetHashValue (he, (ClientData) j); + j += 3; + } + lc = j + 1; + } + + empty = Tcl_NewObj (); + Tcl_IncrRefCount (empty); + + /* Fill in the arcs, attributes per node, and graph attributes */ + + for (k=0; k < lc-1; k++) { + ASSERT_BOUNDS(k, lc-1); + n = gn_get_node (g, lv[k], NULL, NULL); + k ++; + + ASSERT_BOUNDS(k, lc-1); + lv [k] = g_attr_serial (n->base.attr, empty); + k ++; + + ASSERT_BOUNDS(k, lc-1); + lv [k] = gn_serial_arcs (n, empty, &cn); + } + + ASSERT_BOUNDS(k, lc); + lv [k] = g_attr_serial (g->attr, empty); + + /* Put everything together, release scratch space */ + + ser = Tcl_NewListObj (lc, lv); + + Tcl_DecrRefCount (empty); + Tcl_DeleteHashTable(&cn); + ckfree ((char*) lv); + + return ser; + + abort: + Tcl_DeleteHashTable(&cn); + ckfree ((char*) lv); + return NULL; +} + + +/* .................................................. */ + +int +g_deserialize (G* dst, Tcl_Interp* interp, Tcl_Obj* src) +{ + /* + * SV = { NODE ATTR/node ARCS ... ATTR/graph } + * + * using: + * ATTR/x = { key value ... } + * ARCS = { { NAME targetNODEref ATTR/arc } ... } + * + * Basic checks: + * - Is the input a list ? + * - Is its length a multiple of three modulo 1 ? + */ + + int lc, i, j, k; + Tcl_Obj** lv; + int ac; + Tcl_Obj** av; + int axc, nref; + Tcl_Obj** axv; + int nodes; + G* new; + GN* n; + GN* ndst; + GA* a; + int code = TCL_ERROR; + + if (Tcl_ListObjGetElements (interp, src, &lc, &lv) != TCL_OK) { + return TCL_ERROR; + } + if ((lc % 3) != 1) { + Tcl_AppendResult (interp, + "error in serialization: list length not 1 mod 3.", + NULL); + return TCL_ERROR; + } + + nodes = (lc-1)/3; + + /* Iteration 1. Check the overall structure of the incoming value (node + * attributes, arcs, arc attributes, graph attributes). + */ + + if (!g_attr_serok (interp, lv[lc-1], "graph")) { + return TCL_ERROR; + } + + for (i=0; i < (lc-1); ) { + /* Skip node name */ + ASSERT_BOUNDS (i, lc-1); + i ++ ; + /* Check node attributes */ + if (!g_attr_serok (interp, lv[i], "node")) { + return TCL_ERROR; + } + /* Go to the arc information block for the node */ + ASSERT_BOUNDS (i, lc-1); + i ++; + /* Check arc information */ + if (Tcl_ListObjGetElements (interp, lv[i], &ac, &av) != TCL_OK) { + return TCL_ERROR; + } + for (k=0; k < ac; k++) { + ASSERT_BOUNDS (k, ac); + /* Check each arc */ + if (Tcl_ListObjGetElements (interp, av[k], &axc, &axv) != TCL_OK) { + return TCL_ERROR; + } + if ((axc != 3) && (axc != 4)) { + Tcl_AppendResult (interp, + "error in serialization: arc information length not 3 or 4.", + NULL); + return TCL_ERROR; + } + /* Check arc attributes */ + if (!g_attr_serok (interp, axv[2], "arc")) { + return TCL_ERROR; + } + /* Check node reference for arc destination */ + if ((Tcl_GetIntFromObj (interp, axv[1], &nref) != TCL_OK) || + (nref % 3) || (nref < 0) || (nref >= lc)) { + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "error in serialization: bad arc destination reference \"", + Tcl_GetString (axv[1]), + "\".", NULL); + return TCL_ERROR; + } + } + /* Go to the next node */ + ASSERT_BOUNDS (i, lc-1); + i ++; + } + + /* We now know that the value is structurally sound, i.e. lists, of the + * specified lengths, fixed, and proper multiples, and that references are + * kept inside to the proper locations. We can now go over the information + * again and use it to build up a graph. At that time we can also do the + * more complex semantic checks (dup nodes, dup arcs). + * + * The information is collected directly into a graph structure. We have + * no better place where to put it. In case of problems we can tear it + * down again easily, and otherwise we can swap with the actual graph and + * then tear that one down, effectively replacing it with the new graph. + */ + + new = g_new (); + + /* I. Import the nodes */ + + for (i=0; i < (lc-1); i += 3) { + ASSERT_BOUNDS (i, lc-1); + n = gn_get_node (new, lv[i], NULL, NULL); + if (n) { + Tcl_AppendResult (interp, + "error in serialization: duplicate node names.", + NULL); + goto done; + } + gn_new (new, Tcl_GetString (lv [i])); + } + + /* II. Import the arcs */ + + for (i=2; i < (lc-1); i += 3) { + ASSERT_BOUNDS (i, lc-1); + n = gn_get_node (new, lv[i-2], NULL, NULL); + Tcl_ListObjGetElements (interp, lv[i], &ac, &av); + + for (k=0; k < ac; k++) { + ASSERT_BOUNDS (k, ac); + Tcl_ListObjGetElements (interp, av[k], &axc, &axv); + a = ga_get_arc (new, axv[0], NULL, NULL); + if (a) { + Tcl_AppendResult (interp, + "error in serialization: duplicate definition of arc \"", + Tcl_GetString (axv[0]),"\".", NULL); + goto done; + } + Tcl_GetIntFromObj (interp, axv[1], &nref); + ndst = gn_get_node (new, lv[nref], NULL, NULL); + a = ga_new (new, Tcl_GetString (axv[0]), n, ndst); + + if (axc == 4) { + a->weight = axv[3]; + Tcl_IncrRefCount (a->weight); + } + } + } + + /* III. Import the various attributes */ + + for (i=0; i < (lc-1); ) { + ASSERT_BOUNDS (i, lc-1); + n = gn_get_node (new, lv[i], NULL, NULL); + /* Goto node attributes */ + i ++ ; + /* Import node attributes */ + ASSERT_BOUNDS (i, lc-1); + g_attr_deserial (&n->base.attr, lv[i]); + /* Go to the arc information block for the node */ + ASSERT_BOUNDS (i, lc-1); + i ++; + /* Check arc information */ + Tcl_ListObjGetElements (interp, lv[i], &ac, &av); + for (k=0; k < ac; k++) { + ASSERT_BOUNDS (k, ac); + Tcl_ListObjGetElements (interp, av[k], &axc, &axv); + a = ga_get_arc (new, axv[0], NULL, NULL); + g_attr_deserial (&a->base.attr, axv[2]); + } + /* Go to the next node */ + ASSERT_BOUNDS (i, lc-1); + i ++; + } + + g_attr_deserial (&new->attr, lv[lc-1]); + + /* swap dst <-> new. This puts the collected information into the graph + * associated with the command, and the old information is put into the + * scratch structure scheduled for destruction, making cleanup automatic. + */ + + swap (dst, new); + code = TCL_OK; + + done: + g_delete (new); + return code; +} + +/* .................................................. */ + +int +g_assign (G* dst, G* src) +{ + G* new = dup (src); + swap (dst, new); + g_delete (new); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * g_ms_assign -- + * + * Copies the argument graph over into this one. Uses direct + * access to internal data structures for matching graph objects, and + * goes through a serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +g_ms_assign (Tcl_Interp* interp, G* g, Tcl_Obj* src) +{ + Tcl_CmdInfo srcInfo; + + if (!Tcl_GetCommandInfo(interp, Tcl_GetString (src), &srcInfo)) { + Tcl_AppendResult (interp, "invalid command name \"", + Tcl_GetString (src), "\"", NULL); + return TCL_ERROR; + } + + if (srcInfo.objProc == g_objcmd) { + /* The source graph object is managed by this code also. We can + * retrieve and copy the data directly. + */ + + G* gsrc = (G*) srcInfo.objClientData; + + return g_assign (g, gsrc); + + } else { + /* The source graph is not managed by this package. Use + * (de)serialization to transfer the information We do not invoke the + * command proc directly + */ + + int res; + Tcl_Obj* ser; + Tcl_Obj* cmd [2]; + + /* Phase 1: Obtain a serialization by invoking the relevant object + * method + */ + + cmd [0] = src; + cmd [1] = Tcl_NewStringObj ("serialize", -1); + + Tcl_IncrRefCount (cmd [0]); + Tcl_IncrRefCount (cmd [1]); + + res = Tcl_EvalObjv (interp, 2, cmd, 0); + + Tcl_DecrRefCount (cmd [0]); + Tcl_DecrRefCount (cmd [1]); + + if (res != TCL_OK) { + return TCL_ERROR; + } + + ser = Tcl_GetObjResult (interp); + Tcl_IncrRefCount (ser); + Tcl_ResetResult (interp); + + /* Phase 2: Copy the serializtion into ourselves using the regular + * deserialization functionality + */ + + res = g_deserialize (g, interp, ser); + Tcl_DecrRefCount (ser); + return res; + } +} + +/* + *--------------------------------------------------------------------------- + * + * g_ms_set -- + * + * Copies this graph over into the argument graph. Uses direct access to + * internal data structures for matching graph objects, and goes through a + * serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +g_ms_set (Tcl_Interp* interp, Tcl_Obj* go, G* g, Tcl_Obj* dst) +{ + Tcl_CmdInfo dstInfo; + + if (!Tcl_GetCommandInfo(interp, Tcl_GetString (dst), &dstInfo)) { + Tcl_AppendResult (interp, "invalid command name \"", + Tcl_GetString (dst), "\"", NULL); + return TCL_ERROR; + } + + if (dstInfo.objProc == g_objcmd) { + /* The destination graph object is managed by this code also We can + * retrieve and copy the data directly. + */ + + G* gdest = (G*) dstInfo.objClientData; + + return g_assign (gdest, g); + + } else { + /* The destination graph is not managed by this package. Use + * (de)serialization to transfer the information We do not invoke the + * command proc directly. + */ + + int res; + Tcl_Obj* ser; + Tcl_Obj* cmd [3]; + + /* Phase 1: Obtain our serialization */ + + ser = g_ms_serialize (interp, go, g, 0, NULL); + + /* Phase 2: Copy into destination by invoking the regular + * deserialization method + */ + + cmd [0] = dst; + cmd [1] = Tcl_NewStringObj ("deserialize", -1); + cmd [2] = ser; + + Tcl_IncrRefCount (cmd [0]); + Tcl_IncrRefCount (cmd [1]); + Tcl_IncrRefCount (cmd [2]); + + res = Tcl_EvalObjv (interp, 3, cmd, 0); + + Tcl_DecrRefCount (cmd [0]); + Tcl_DecrRefCount (cmd [1]); + Tcl_DecrRefCount (cmd [2]); /* == ser, is gone now */ + + if (res != TCL_OK) { + return TCL_ERROR; + } + + Tcl_ResetResult (interp); + return TCL_OK; + } + return TCL_ERROR; +} + + +/* .................................................. */ + +static void +swap (G* dst, G* src) +{ + GC* c; + G tmp; + + /* Swap the main information */ + + tmp = *dst; + *dst = *src; + *src = tmp; + + /* Swap the cmd right back, because this part of the dst structure has to + * be kept. + */ + + tmp.cmd = dst->cmd; + dst->cmd = src->cmd; + src->cmd = tmp.cmd; + + /* At last fix the node/arc ownership in both structures, or else g_delete + * will access and destroy the newly created information, and a future + * delete of the graph accesses long gone memory. + */ + + for (c = src->nodes.first; c != NULL; c = c->next) { + c->graph = src; + } + for (c = src->arcs.first; c != NULL; c = c->next) { + c->graph = src; + } + + for (c = dst->nodes.first; c != NULL; c = c->next) { + c->graph = dst; + } + for (c = dst->arcs.first; c != NULL; c = c->next) { + c->graph = dst; + } +} + +/* .................................................. */ + +static G* +dup (G* src) +{ + G* new = g_new (); + GN* no; GN* n; + GA* ao; GA* a; + GC* c; + + /* I. Duplicate nodes. NOTE. In the list of nodes in src we break the chain + * of prev references and use that to point from each src node to its + * duplicate. This is then used during the duplication of arcs (-> II.) to + * quickly locate the nodes to connect. After that is done the chain can + * and is restored. + */ +#define ORIG base.prev + + for (no = (GN*) src->nodes.first; + no != NULL; + no = (GN*) no->base.next) { + + n = gn_new (new, Tcl_GetString(no->base.name)); + no->ORIG = (GC*) n; + g_attr_dup (&n->base.attr, no->base.attr); + } + + /* II. Duplicate the arcs */ + + for (ao = (GA*) src->arcs.first; + ao != NULL; + ao = (GA*) ao->base.next) { + a = ga_new (new, Tcl_GetString(ao->base.name), + (GN*) ao->start->n->ORIG, + (GN*) ao->end->n->ORIG); + g_attr_dup (&a->base.attr, ao->base.attr); + + if (ao->weight) { + a->weight = ao->weight; + Tcl_IncrRefCount (a->weight); + } + } + +#undef ORIG + + /* III. Re-chain the nodes in the original */ + + c = src->nodes.first; + if (c) { + c->prev = NULL; + c = c->next; + + for (; c != NULL; c = c->next) { + if (!c->next) break; + c->next->prev = c; + } + } + + g_attr_dup (&new->attr, src->attr); + return new; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/graph.h b/tcllib/modules/struct/graph/graph.h new file mode 100644 index 0000000..35035a5 --- /dev/null +++ b/tcllib/modules/struct/graph/graph.h @@ -0,0 +1,40 @@ +/* struct::graph - critcl - layer 1 declarations + * (c) Graph functions + */ + +#ifndef _G_GRAPH_H +#define _G_GRAPH_H 1 +/* .................................................. */ + +#include "tcl.h" +#include <ds.h> + +/* .................................................. */ + +G* g_new (void); +void g_delete (G* g); + +const char* g_newnodename (G* g); +const char* g_newarcname (G* g); + +Tcl_Obj* g_serialize (Tcl_Interp* interp, Tcl_Obj* go, + G* g, int oc, Tcl_Obj* const* ov); +int g_deserialize (G* dst, Tcl_Interp* interp, Tcl_Obj* src); +int g_assign (G* dst, G* src); + +Tcl_Obj* g_ms_serialize (Tcl_Interp* interp, Tcl_Obj* go, G* g, + int oc, Tcl_Obj* const* ov); +int g_ms_set (Tcl_Interp* interp, Tcl_Obj* go, G* g, + Tcl_Obj* dst); +int g_ms_assign (Tcl_Interp* interp, G* g, Tcl_Obj* src); + +/* .................................................. */ +#endif /* _G_GRAPH_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/methods.c b/tcllib/modules/struct/graph/methods.c new file mode 100644 index 0000000..4ab1016 --- /dev/null +++ b/tcllib/modules/struct/graph/methods.c @@ -0,0 +1,2914 @@ +/* struct::tree - critcl - layer 3 definitions. + * + * -> Method functions. + * Implementations for all tree methods. + */ + +#include <string.h> +#include <arc.h> +#include <graph.h> +#include <methods.h> +#include <nacommon.h> +#include <node.h> +#include <util.h> +#include <walk.h> + +/* .................................................. + * Handling of all indices, numeric and 'end-x' forms. Copied straight out of + * the Tcl core as this is not exported through the public API. + */ + +static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, + int endValue, int* indexPtr); + +/* .................................................. */ + +#define FAIL(x) if (!(x)) { return TCL_ERROR; } + +/* .................................................. */ +/* + *--------------------------------------------------------------------------- + * + * gm_GASSIGN -- + * + * Copies the argument graph over into this graph object. Uses direct + * access to internal data structures for matching graph objects, and + * goes through a serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +gm_GASSIGN (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph = source + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "source"); + return TCL_ERROR; + } + + return g_ms_assign (interp, g, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_GSET -- + * + * Copies this graph over into the argument graph. Uses direct access to + * internal data structures for matching graph objects, and goes through a + * serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +gm_GSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph --> dest(ination) + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "dest"); + return TCL_ERROR; + } + + return g_ms_set (interp, objv[0], g, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_APPEND -- + * + * Appends a value to an attribute of the graph. + * May create the attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph append key value + * [0] [1] [2] [3] + */ + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "key value"); + return TCL_ERROR; + } + + g_attr_extend (&g->attr); + g_attr_append (g->attr, interp, objv[2], objv[3]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_ARCS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_ARCS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arcs | all arcs + * graph arcs -in NODE... | arcs end in node in list + * graph arcs -out NODE... | arcs start in node in list + * graph arcs -adj NODE... | arcs start|end in node in list + * graph arcs -inner NODE... | arcs start&end in node in list + * graph arcs -embedding NODE... | arcs start^end in node in list + * graph arcs -key KEY | arcs have attribute KEY + * graph arcs -value VALUE | arcs have KEY and VALUE + * graph arcs -filter CMDPREFIX | arcs for which CMD returns True. + * [0] [1] [2] [3] + * + * -value requires -key. + * -in/-out/-adj/-inner/-embedding are exclusive. + * Each option can be used at most once. + */ + + return gc_filter (0, interp, objc, objv, &g->arcs, + (GN_GET_GC*) ga_get_arc, g); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_APPEND -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc append ARC KEY VALUE + * [0] [1] [2] [3] [4] [5] + */ + + GA* a; + + if (objc != 6) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key value"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_extend (&a->base.attr); + g_attr_append (a->base.attr, interp, objv[4], objv[5]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_GETUNWEIGH -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_GETUNWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc getunweighted + * [0] [1] [2] + */ + + GA* a; + Tcl_Obj** rv; + int rc; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 3, objv, NULL); + return TCL_ERROR; + } + + rv = NALLOC (g->arcs.n, Tcl_Obj*); + rc = 0; + + for (a = (GA*) g->arcs.first; a ; a = (GA*) a->base.next) { + if (a->weight) continue; + + ASSERT_BOUNDS (rc, g->arcs.n); + + rv [rc++] = a->base.name; + } + + Tcl_SetObjResult (interp, Tcl_NewListObj (rc, rv)); + + ckfree ((char*) rv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_GETWEIGHT -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_GETWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc getweight ARC + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + if (!a->weight) { + Tcl_AppendResult (interp, + "arc \"", Tcl_GetString (a->base.name), "\" has no weight", + NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, a->weight); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_SETUNWEIGH -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_SETUNWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc setunweighted ?weight? + * [0] [1] [2] [3] + */ + + GA* a; + Tcl_Obj* weight; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs (interp, 3, objv, "?weight?"); + return TCL_ERROR; + } + + if (objc == 4) { + weight = objv [3]; + } else { + weight = Tcl_NewIntObj (0); + } + + for (a = (GA*) g->arcs.first; a ; a = (GA*) a->base.next) { + if (a->weight) continue; + + a->weight = weight; + Tcl_IncrRefCount (weight); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_SETWEIGHT -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_SETWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc setweight ARC WEIGHT + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc weight"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + if (a->weight) { + Tcl_DecrRefCount (a->weight); + } + + a->weight = objv [4]; + Tcl_IncrRefCount (a->weight); + + Tcl_SetObjResult (interp, a->weight); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_UNSETWEIGH -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_UNSETWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc unsetweight ARC + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + if (a->weight) { + Tcl_DecrRefCount (a->weight); + a->weight = NULL; + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_HASWEIGHT -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_HASWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc hasweight ARC + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (a->weight != NULL)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_WEIGHTS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_WEIGHTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc weights + * [0] [1] [2] + */ + + GA* a; + Tcl_Obj** rv; + int rc, rcmax; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 3, objv, NULL); + return TCL_ERROR; + } + + rcmax = 2 * g->arcs.n; + rv = NALLOC (rcmax, Tcl_Obj*); + rc = 0; + + for (a = (GA*) g->arcs.first; a ; a = (GA*) a->base.next) { + if (!a->weight) continue; + + ASSERT_BOUNDS (rc, rcmax); + ASSERT_BOUNDS (rc+1, rcmax); + + rv [rc++] = a->base.name; + rv [rc++] = a->weight; + } + + Tcl_SetObjResult (interp, Tcl_NewListObj (rc, rv)); + + ckfree ((char*) rv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_ATTR -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc attr KEY + * graph arc attr KEY -arcs LIST + * graph arc attr KEY -glob PATTERN + * graph arc attr KEY -regexp PATTERN + * [0] [1] [2] [3] [4] [5] + */ + + static const char* types [] = { + "-arcs", "-glob","-regexp", NULL + }; + int modes [] = { + A_LIST, A_GLOB, A_REGEXP + }; + + int mode; + Tcl_Obj* detail; + + if ((objc != 4) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 3, objv, + "key ?-arcs list|-glob pattern|-regexp pattern?"); + return TCL_ERROR; + } + + if (objc != 6) { + detail = NULL; + mode = A_NONE; + } else { + detail = objv [5]; + if (Tcl_GetIndexFromObj (interp, objv [4], types, "type", + 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + mode = modes [mode]; + } + + return gc_attr (&g->arcs, mode, detail, interp, objv[3], + (GN_GET_GC*) ga_get_arc, g); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_DELETE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc delete ARC ARC... + * [0] [1] [2] [3] [4+] + */ + + GA* a; + int i; + + if (objc < 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc arc..."); + return TCL_ERROR; + } + + for (i=3; i<objc; i++) { + a = ga_get_arc (g, objv[i], interp, objv[0]); + FAIL (a); + } + + for (i=3; i<objc; i++) { + a = ga_get_arc (g, objv[i], interp, objv[0]); + ga_delete (a); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_EXISTS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc exists NAME + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], NULL, NULL); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (a != NULL)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_FLIP -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_FLIP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc flip ARC + * [0] [1] [2] [3] + */ + + GA* a; + GN* src; + GN* dst; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + src = a->start->n; + dst = a->end->n; + + if (src != dst) { + ga_mv_src (a, dst); + ga_mv_dst (a, src); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_GET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc get ARC KEY + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + return g_attr_get (a->base.attr, interp, objv[4], + objv [3], "\" for arc \""); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_GETALL -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc getall ARC ?PATTERN? + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_getall (a->base.attr, interp, objc-4, objv+4); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_INSERT -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc insert SOURCE TARGET ?ARC? + * [0] [1] [2] [3] [4] [5] + */ + + GN* src; + GN* dst; + GA* a; + const char* name; + + if ((objc != 5) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 3, objv, "source target ?arc?"); + return TCL_ERROR; + } + + Tcl_AppendResult (interp, "source ", NULL); + src = gn_get_node (g, objv [3], interp, objv[0]); + FAIL (src); + Tcl_ResetResult (interp); + + Tcl_AppendResult (interp, "target ", NULL); + dst = gn_get_node (g, objv [4], interp, objv[0]); + FAIL (dst); + Tcl_ResetResult (interp); + + if (objc == 6) { + /* Explicit arc name, must not exist */ + + if (ga_get_arc (g, objv [5], NULL, NULL)) { + ga_err_duplicate (interp, objv[5], objv[0]); + return TCL_ERROR; + } + + /* No matching arc found */ + /* Create arc with specified name, */ + /* then insert it */ + + name = Tcl_GetString (objv [5]); + + } else { + /* Create a single new node with a generated name, */ + /* then insert it. */ + + name = g_newarcname (g); + } + + a = ga_new (g, name, src, dst); + Tcl_SetObjResult (interp, Tcl_NewListObj (1, &a->base.name)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_KEYEXISTS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc keyexists ARC KEY + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_kexists (a->base.attr, interp, objv[4]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_KEYS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc keys ARC ?PATTERN? + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_keys (a->base.attr, interp, objc-4, objv+4); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_LAPPEND -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc lappend ARC KEY VALUE + * [0] [1] [2] [3] [4] [5] + */ + + GA* a; + + if (objc != 6) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key value"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_extend (&a->base.attr); + g_attr_lappend (a->base.attr, interp, objv[4], objv[5]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_MOVE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_MOVE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc move ARC NEWSRC NEWDST + * [0] [1] [2] [3] [4] [5] + */ + + GA* a; + GN* nsrc; + GN* ndst; + + if (objc != 6) { + Tcl_WrongNumArgs (interp, 3, objv, "arc newsource newtarget"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + nsrc = gn_get_node (g, objv [4], interp, objv [0]); + FAIL (nsrc); + + ndst = gn_get_node (g, objv [5], interp, objv [0]); + FAIL (ndst); + + ga_mv_src (a, nsrc); + ga_mv_dst (a, ndst); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_MOVE_SRC -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_MOVE_SRC (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc move ARC NEWSRC + * [0] [1] [2] [3] [4] + */ + + GA* a; + GN* nsrc; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc newsource"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + nsrc = gn_get_node (g, objv [4], interp, objv [0]); + FAIL (nsrc); + + ga_mv_src (a, nsrc); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_MOVE_TARG -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_MOVE_TARG (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc move ARC NEWDST + * [0] [1] [2] [3] [4] + */ + + GA* a; + GN* ndst; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc newtarget"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + ndst = gn_get_node (g, objv [4], interp, objv [0]); + FAIL (ndst); + + ga_mv_dst (a, ndst); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_RENAME -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc rename ARC NEW + * [0] [1] [2] [3] [4] + */ + + GC* c; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc newname"); + return TCL_ERROR; + } + + c = (GC*) ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (c); + + if (ga_get_arc (g, objv [4], NULL, NULL)) { + ga_err_duplicate (interp, objv[4], objv[0]); + return TCL_ERROR; + } + + gc_rename (c, &g->arcs, objv[4], interp); + ga_shimmer_self ((GA*) c); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_SET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc set ARC KEY ?VALUE? + * [0] [1] [2] [3] [4] [5] + */ + + GA* a; + + if ((objc != 5) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key ?value?"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + if (objc == 5) { + return g_attr_get (a->base.attr, interp, objv[4], + objv [3], "\" for arc \""); + } else { + g_attr_extend (&a->base.attr); + g_attr_set (a->base.attr, interp, objv[4], objv[5]); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_SOURCE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_SOURCE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc source ARC + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + Tcl_SetObjResult (interp, a->start->n->base.name); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_TARGET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_TARGET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc target ARC + * [0] [1] [2] [3] + */ + + GA* a; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + Tcl_SetObjResult (interp, a->end->n->base.name); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_NODES -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_NODES (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc target ARC + * [0] [1] [2] [3] + */ + + GA* a; + Tcl_Obj* nv[2]; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "arc"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + nv[0] = a->start->n->base.name; + nv[1] = a->end->n->base.name; + + Tcl_SetObjResult (interp, Tcl_NewListObj (2, nv)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_arc_UNSET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_arc_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc unset ARC KEY + * [0] [1] [2] [3] [4] + */ + + GA* a; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "arc key"); + return TCL_ERROR; + } + + a = ga_get_arc (g, objv [3], interp, objv [0]); + FAIL (a); + + g_attr_unset (a->base.attr, objv [4]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_DESERIALIZE -- + * + * Parses a Tcl value containing a serialized graph and copies it over + * the existing graph. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_DESERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph deserialize serial + * [0] [1] [2] + * + * SV = { NODE ATTR/node ARCS ... ATTR/graph } + * + * using: + * ATTR/x = { key value ... } + * ARCS = { { NAME targetNODEref ATTR/arc } ... } + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "serial"); + return TCL_ERROR; + } + + return g_deserialize (g, interp, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_DESTROY -- + * + * Destroys the whole graph object. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Releases memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_DESTROY (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph destroy + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DeleteCommandFromToken(interp, g->cmd); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_GET -- + * + * Returns the value of the named attribute in the graph. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph get key + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "key"); + return TCL_ERROR; + } + + return g_attr_get (g->attr, interp, objv[2], + objv [0], "\" for graph \""); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_GETALL -- + * + * Returns a dictionary containing all attributes and their values of + * the graph. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph getall ?pattern? + * [0] [1] [2] + */ + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + g_attr_getall (g->attr, interp, objc-2, objv+2); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_KEYEXISTS -- + * + * Returns a boolean value signaling whether the graph has the + * named attribute or not. True implies that the attribute exists. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph keyexists key + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "key"); + return TCL_ERROR; + } + + g_attr_kexists (g->attr, interp, objv[2]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_KEYS -- + * + * Returns a list containing all attribute names matching the pattern + * for the attributes of the graph. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph keys ?pattern? + * [0] [1] [2] + */ + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + g_attr_keys (g->attr, interp, objc-2, objv+2); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_LAPPEND -- + * + * Appends a value as list element to an attribute of the graph. + * May create the attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph lappend key value + * [0] [1] [2] [3] + */ + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "key value"); + return TCL_ERROR; + } + + g_attr_extend (&g->attr); + g_attr_lappend (g->attr, interp, objv[2], objv[3]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_NODES -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_NODES (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* nwa = nodes with arc, st = starting, en = ending + * + * Syntax: graph nodes | all nodes + * graph nodes -in NODE... | nwa en in node in list + * graph nodes -out NODE... | nwa st in node in list + * graph nodes -adj NODE... | nwa st|en in node in list + * graph nodes -inner NODE... | nwa st&en in node in list + * graph nodes -embedding NODE... | nwa st^en in node in list + * graph nodes -key KEY | nodes have attribute KEY + * graph nodes -value VALUE | nodes have KEY and VALUE + * graph nodes -filter CMDPREFIX | nodes for which CMD returns True. + * [0] [1] [2] [3] + * + * -in/-out/-adj/-inner/-embedding are exclusive. + * -value requires -key. + * Each option can be used at most once. + */ + + return gc_filter (1, interp, objc, objv, &g->nodes, + (GN_GET_GC*) gn_get_node, g); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_APPEND -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node append NODE KEY VALUE + * [0] [1] [2] [3] [4] [5] + */ + + GN* n; + + if (objc != 6) { + Tcl_WrongNumArgs (interp, 3, objv, "node key value"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + g_attr_extend (&n->base.attr); + g_attr_append (n->base.attr, interp, objv[4], objv[5]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_ATTR -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node attr KEY + * graph node attr KEY -nodes LIST + * graph node attr KEY -glob PATTERN + * graph node attr KEY -regexp PATTERN + * [0] [1] [2] [3] [4] [5] + */ + + static const char* types [] = { + "-glob", "-nodes", "-regexp", NULL + }; + int modes [] = { + A_GLOB, A_LIST, A_REGEXP + }; + + int mode; + Tcl_Obj* detail; + + if ((objc != 4) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 3, objv, + "key ?-nodes list|-glob pattern|-regexp pattern?"); + return TCL_ERROR; + } + + if (objc != 6) { + detail = NULL; + mode = A_NONE; + } else { + detail = objv [5]; + if (Tcl_GetIndexFromObj (interp, objv [4], types, "type", + 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + mode = modes [mode]; + } + + return gc_attr (&g->nodes, mode, detail, interp, objv[3], + (GN_GET_GC*) gn_get_node, g); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_DEGREE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_DEGREE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node degree -in|-out NODE + * [0] [1] [2] [3] [4] + * + * graph node degree NODE + * [0] [1] [2] [3] + */ + + GN* n; + int dmode; + int degree; + Tcl_Obj* node; + + static const char* dmode_s [] = { + "-in", "-out", NULL + }; + enum dmode_e { + D_IN, D_OUT, D_ALL + }; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 3, objv, "?-in|-out? node"); + return TCL_ERROR; + } + + if (objc == 5) { + if (Tcl_GetIndexFromObj (interp, objv [3], dmode_s, + "option", 0, &dmode) != TCL_OK) { + return TCL_ERROR; + } + + node = objv [4]; + } else { + dmode = D_ALL; + node = objv [3]; + } + + n = gn_get_node (g, node, interp, objv [0]); + FAIL (n); + + switch (dmode) { + case D_IN: degree = n->in.n; break; + case D_OUT: degree = n->out.n; break; + case D_ALL: degree = n->in.n + n->out.n; break; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (degree)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_DELETE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node delete NODE NODE... + * [0] [1] [2] [3] [4+] + */ + + int i; + GN* n; + + if (objc < 4) { + Tcl_WrongNumArgs (interp, 3, objv, "node node..."); + return TCL_ERROR; + } + + for (i=3; i< objc; i++) { + n = gn_get_node (g, objv [i], interp, objv [0]); + FAIL (n); + } + + for (i=3; i< objc; i++) { + n = gn_get_node (g, objv [i], interp, objv [0]); + gn_delete (n); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_EXISTS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node exists NAME + * [0] [1] [2] [3] + */ + + GN* n; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 3, objv, "node"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], NULL, NULL); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (n != NULL)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_GET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node get ARC KEY + * [0] [1] [2] [3] [4] + */ + + GN* n; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "node key"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + return g_attr_get (n->base.attr, interp, objv[4], + objv [3], "\" for node \""); +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_GETALL -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph arc getall ARC ?PATTERN? + * [0] [1] [2] [3] [4] + */ + + GN* n; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + g_attr_getall (n->base.attr, interp, objc-4, objv+4); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_INSERT -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node insert ?NODE...? + * [0] [1] [2] [3] + */ + + GN* n; + + if (objc < 3) { + Tcl_WrongNumArgs (interp, 3, objv, "?node...?"); + return TCL_ERROR; + } + + if (objc >= 4) { + int lc, i; + Tcl_Obj** lv; + + /* Explicit node names, must not exist */ + + for (i=3; i<objc; i++) { + if (gn_get_node (g, objv [i], NULL, NULL)) { + gn_err_duplicate (interp, objv[i], objv[0]); + return TCL_ERROR; + } + } + + /* No matching nodes found. Create nodes with specified name, then + * insert them + */ + + lc = objc-3; + lv = NALLOC (lc, Tcl_Obj*); + + for (i=3; i<objc; i++) { + n = gn_new (g, Tcl_GetString (objv [i])); + lv [i-3] = n->base.name; + } + + Tcl_SetObjResult (interp, Tcl_NewListObj (lc, lv)); + ckfree ((char*) lv); + + } else { + /* Create a single new node with a generated name, then insert it. */ + + n = gn_new (g, g_newnodename (g)); + Tcl_SetObjResult (interp, Tcl_NewListObj (1, &n->base.name)); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_KEYEXISTS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node keyexists ARC KEY + * [0] [1] [2] [3] [4] + */ + + GN* n; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "node key"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + g_attr_kexists (n->base.attr, interp, objv[4]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_KEYS -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node keys NODE ?PATTERN? + * [0] [1] [2] [3] [4] + */ + + GN* n; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + g_attr_keys (n->base.attr, interp, objc-4, objv+4); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_LAPPEND -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node lappend NODE KEY VALUE + * [0] [1] [2] [3] [4] [5] + */ + + GN* n; + + if (objc != 6) { + Tcl_WrongNumArgs (interp, 3, objv, "node key value"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + g_attr_extend (&n->base.attr); + g_attr_lappend (n->base.attr, interp, objv[4], objv[5]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_OPPOSITE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_OPPOSITE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node opposite NODE ARC + * [0] [1] [2] [3] [4] + */ + + GN* n; + GA* a; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "node arc"); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (n); + + a = ga_get_arc (g, objv [4], interp, objv [0]); + FAIL (a); + + if (a->start->n == n) { + Tcl_SetObjResult (interp, a->end->n->base.name); + } else if (a->end->n == n) { + Tcl_SetObjResult (interp, a->start->n->base.name); + } else { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, n->base.name); + Tcl_AppendToObj (err, "\" and arc \"", -1); + Tcl_AppendObjToObj (err, a->base.name); + Tcl_AppendToObj (err, "\" are not connected in graph \"", -1); + Tcl_AppendObjToObj (err, objv [0]); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_RENAME -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node rename NODE NEW + * [0] [1] [2] [3] [4] + */ + + GC* c; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "node newname"); + return TCL_ERROR; + } + + c = (GC*) gn_get_node (g, objv [3], interp, objv [0]); + FAIL (c); + + if (gn_get_node (g, objv [4], NULL, NULL)) { + gn_err_duplicate (interp, objv[4], objv[0]); + return TCL_ERROR; + } + + gc_rename (c, &g->nodes, objv[4], interp); + gn_shimmer_self ((GN*) c); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_SET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node set NODE KEY ?VALUE? + * [0] [1] [2] [3] [4] [5] + */ + + GC* c; + + if ((objc != 5) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 3, objv, "node key ?value?"); + return TCL_ERROR; + } + + c = (GC*) gn_get_node (g, objv [3], interp, objv [0]); + FAIL (c); + + if (objc == 5) { + return g_attr_get (c->attr, interp, objv[4], + objv [3], "\" for node \""); + } else { + g_attr_extend (&c->attr); + g_attr_set (c->attr, interp, objv[4], objv[5]); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * gm_node_UNSET -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_node_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph node unset NODE KEY + * [0] [1] [2] [3] [4] + */ + + GC* c; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 3, objv, "node key"); + return TCL_ERROR; + } + + c = (GC*) gn_get_node (g, objv [3], interp, objv [0]); + FAIL (c); + + g_attr_unset (c->attr, objv [4]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_SERIALIZE -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_SERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph serialize NODE... + * [0] [1] [2] + * + * SV = { NODE ATTR/node ARCS ... ATTR/graph } + * + * using: + * ATTR/x = { key value ... } + * ARCS = { { NAME targetNODEref ATTR/arc } ... } + */ + + Tcl_Obj* sv = g_ms_serialize (interp, objv[0], g, objc-2, objv+2); + + if (!sv) { + return TCL_ERROR; + } + Tcl_SetObjResult (interp, sv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_SET -- + * + * Adds an attribute and its value to the graph. May replace an + * existing value. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph set key ?value? + * [0] [1] [2] [3] + */ + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs (interp, 2, objv, "key ?value?"); + return TCL_ERROR; + } + + if (objc == 3) { + return g_attr_get (g->attr, interp, objv[2], + objv [0], "\" for graph \""); + } else { + g_attr_extend (&g->attr); + g_attr_set (g->attr, interp, objv[2], objv[3]); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * gm_SWAP -- + * + * Swap the names of two nodes. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +gm_SWAP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph swap a b + * [0] [1] [2] [3] + */ + + GN* na; + GN* nb; + const char* key; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "node1 node2"); + return TCL_ERROR; + } + + na = gn_get_node (g, objv [2], interp, objv [0]); + FAIL (na); + + nb = gn_get_node (g, objv [3], interp, objv [0]); + FAIL (nb); + + if (na == nb) { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "cannot swap node \"", -1); + Tcl_AppendObjToObj (err, objv [2]); + Tcl_AppendToObj (err, "\" with itself", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + { +#define SWAP(a,b,t) t = a; a = b ; b = t +#define SWAPS(x,t) SWAP(na->x,nb->x,t) + + /* The two nodes flip all structural information around to trade places */ + /* It might actually be easier to flip the non-structural data */ + /* name, he, attr, data in the node map */ + + Tcl_Obj* to; + Tcl_HashTable* ta; + Tcl_HashEntry* th; + + SWAPS (base.name, to); + SWAPS (base.attr, ta); + SWAPS (base.he, th); + + Tcl_SetHashValue (na->base.he, (ClientData) na); + Tcl_SetHashValue (nb->base.he, (ClientData) nb); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_UNSET -- + * + * Removes an attribute and its value from the graph. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph unset key + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "key"); + return TCL_ERROR; + } + + g_attr_unset (g->attr, objv [2]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * gm_WALK -- + * + * + * + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +gm_WALK (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv) +{ + /* Syntax: graph walk NODE ?-type TYPE? ?-order ORDER? ?-dir DIR? -command CMD + * [0] [1] [2] [3] [4] [5] [6] [7] [8] [9] [10] + * + * TYPE bfs|dfs + * ORDER pre|post|both + * DIR backward|forward + * + * bfs => !post && !both + */ + + int cc, type, order, dir; + Tcl_Obj** cv; + GN* n; + + if (objc < 5) { + Tcl_WrongNumArgs (interp, 2, objv, W_USAGE); + return TCL_ERROR; + } + + n = gn_get_node (g, objv [2], interp, objv [0]); + FAIL(n); + + if (g_walkoptions (interp, objc, objv, + &type, &order, &dir, + &cc, &cv) != TCL_OK) { + return TCL_ERROR; + } + + return g_walk (interp, objv[0], n, type, order, dir, cc, cv); +} + + +/* .................................................. */ +/* .................................................. */ + +/* + * Handling of all indices, numeric and 'end-x' forms. Copied straight out of + * the Tcl core as this is not exported through the public API. + * + * I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several + * supporting functions and macros internal to the core. :( + * + * To avoid clashing with the object type in the core the object type here has + * been given a different name. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); +static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* objPtr)); + +static int TclCheckBadOctal (Tcl_Interp *interp, const char *value); +static int TclFormatInt (char *buffer, long n); + + +Tcl_ObjType EndOffsetTypeGraph = { + "tcllib/struct::graph/end-offset", /* name */ + (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ + UpdateStringOfEndOffset, /* updateStringProc */ + SetEndOffsetFromAny +}; + +static int +TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr) +{ + if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) { + return TCL_OK; + } + + if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { + /* + * If the object is already an offset from the end of the + * list, or can be converted to one, use it. + */ + + *indexPtr = endValue + objPtr->internalRep.longValue; + + } else { + /* + * Report a parse error. + */ + + if (interp != NULL) { + char *bytes = Tcl_GetString(objPtr); + /* + * The result might not be empty; this resets it which + * should be both a cheap operation, and of little problem + * because this is an error-generation path anyway. + */ + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); + if (!strncmp(bytes, "end-", 3)) { + bytes += 3; + } + TclCheckBadOctal(interp, bytes); + } + + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfEndOffset -- + * + * Update the string rep of a Tcl object holding an "end-offset" + * expression. + * + * Results: + * None. + * + * Side effects: + * Stores a valid string in the object's string rep. + * + * This procedure does NOT free any earlier string rep. If it is + * called on an object that already has a valid string rep, it will + * leak memory. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfEndOffset(objPtr) + register Tcl_Obj* objPtr; +{ + char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; + register int len; + + strcpy(buffer, "end"); + len = sizeof("end") - 1; + if (objPtr->internalRep.longValue != 0) { + buffer[len++] = '-'; + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + } + objPtr->bytes = ckalloc((unsigned) (len+1)); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * SetEndOffsetFromAny -- + * + * Look for a string of the form "end-offset" and convert it + * to an internal representation holding the offset. + * + * Results: + * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * + * Side effects: + * If interp is not NULL, stores an error message in the + * interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +SetEndOffsetFromAny(interp, objPtr) + Tcl_Interp* interp; /* Tcl interpreter or NULL */ + Tcl_Obj* objPtr; /* Pointer to the object to parse */ +{ + int offset; /* Offset in the "end-offset" expression */ + Tcl_ObjType* oldTypePtr = objPtr->typePtr; + /* Old internal rep type of the object */ + register char* bytes; /* String rep of the object */ + int length; /* Length of the object's string rep */ + + /* If it's already the right type, we're fine. */ + + if (objPtr->typePtr == &EndOffsetTypeGraph) { + return TCL_OK; + } + + /* Check for a string rep of the right form. */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be end?-integer?", + (char*) NULL); + } + return TCL_ERROR; + } + + /* Convert the string rep */ + + if (length <= 3) { + offset = 0; + } else if ((length > 4) && (bytes[3] == '-')) { + /* + * This is our limited string expression evaluator. Pass everything + * after "end-" to Tcl_GetInt, then reverse for offset. + */ + if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + return TCL_ERROR; + } + offset = -offset; + } else { + /* + * Conversion failed. Report the error. + */ + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); + } + return TCL_ERROR; + } + + /* + * The conversion succeeded. Free the old internal rep and set + * the new one. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = offset; + objPtr->typePtr = &EndOffsetTypeGraph; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckBadOctal -- + * + * This procedure checks for a bad octal value and appends a + * meaningful error to the interp's result. + * + * Results: + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. + * + *---------------------------------------------------------------------- + */ + +static int +TclCheckBadOctal(interp, value) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + const char *value; /* String to check. */ +{ + register const char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted + * leading zero. Try to generate a meaningful error message. + */ + + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + /* Reached end of string */ + if (interp != NULL) { + /* + * Don't reset the result here because we want this result + * to be added to an existing error message as extra info. + */ + Tcl_AppendResult(interp, " (looks like invalid octal number)", + (char *) NULL); + } + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclFormatInt -- + * + * This procedure formats an integer into a sequence of decimal digit + * characters in a buffer. If the integer is negative, a minus sign is + * inserted at the start of the buffer. A null character is inserted at + * the end of the formatted characters. It is the caller's + * responsibility to ensure that enough storage is available. This + * procedure has the effect of sprintf(buffer, "%d", n) but is faster. + * + * Results: + * An integer representing the number of characters formatted, not + * including the terminating \0. + * + * Side effects: + * The formatted characters are written into the storage pointer to + * by the "buffer" argument. + * + *---------------------------------------------------------------------- + */ + +static int +TclFormatInt(buffer, n) + char *buffer; /* Points to the storage into which the + * formatted characters are written. */ + long n; /* The integer to format. */ +{ + long intVal; + int i; + int numFormatted, j; + char *digits = "0123456789"; + + /* + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } + + /* + * Check whether "n" is the maximum negative value. This is + * -2^(m-1) for an m-bit word, and has no positive equivalent; + * negating it produces the same value. + */ + + if (n == -n) { + sprintf(buffer, "%ld", n); + return strlen(buffer); + } + + /* + * Generate the characters of the result backwards in the buffer. + */ + + intVal = (n < 0? -n : n); + i = 0; + buffer[0] = '\0'; + do { + i++; + buffer[i] = digits[intVal % 10]; + intVal = intVal/10; + } while (intVal > 0); + if (n < 0) { + i++; + buffer[i] = '-'; + } + numFormatted = i; + + /* + * Now reverse the characters. + */ + + for (j = 0; j < i; j++, i--) { + char tmp = buffer[i]; + buffer[i] = buffer[j]; + buffer[j] = tmp; + } + return numFormatted; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/methods.h b/tcllib/modules/struct/graph/methods.h new file mode 100644 index 0000000..c8f31f3 --- /dev/null +++ b/tcllib/modules/struct/graph/methods.h @@ -0,0 +1,76 @@ +/* struct::graph - critcl - layer 3 declarations + * Method functions. + */ + +#ifndef _G_METHODS_H +#define _G_METHODS_H 1 + +#include "tcl.h" +#include <ds.h> + +int gm_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_ARCS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_DESERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_DESTROY (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_GASSIGN (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_GSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_NODES (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_SERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_SWAP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_WALK (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); + +int gm_arc_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_GETUNWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_GETWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_HASWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_SETUNWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_SETWEIGHT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_SOURCE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_TARGET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_UNSETWEIGH (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_arc_WEIGHTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); + +int gm_node_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_DEGREE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_OPPOSITE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); +int gm_node_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv); + +#endif /* _G_METHODS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/nacommon.c b/tcllib/modules/struct/graph/nacommon.c new file mode 100644 index 0000000..05c66ee --- /dev/null +++ b/tcllib/modules/struct/graph/nacommon.c @@ -0,0 +1,289 @@ +/* struct::graph - critcl - layer 1 definitions + * (c) Graph functions + */ + +#include <nacommon.h> +#include <util.h> +#include <node.h> + +/* .................................................. */ + +void +gc_add (GC* c, GCC* gx) +{ + GC* first = gx->first; + + gx->n ++; + + c->next = first; + c->prev = NULL; + gx->first = c; + + if (!first) return; + first->prev = c; +} + +/* .................................................. */ + +void +gc_remove (GC* c, GCC* gx) +{ + if ((gx->first == c) || c->prev || c->next) { + + if (gx->first == c) { + gx->first = c->next; + } + + if (c->prev) { c->prev->next = c->next; } + if (c->next) { c->next->prev = c->prev; } + + c->prev = NULL; + c->next = NULL; + + gx->n --; + } +} + +/* .................................................. */ + +void +gc_setup (GC* c, GCC* gx, const char* name, G* g) +{ + int new; + + c->name = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (c->name); + + c->he = Tcl_CreateHashEntry(gx->map, name, &new); + Tcl_SetHashValue (c->he, (ClientData) c); + + c->graph = g; + c->attr = NULL; +} + +/* .................................................. */ + +void +gc_delete (GC* c) +{ + Tcl_DecrRefCount (c->name); c->name = NULL; + Tcl_DeleteHashEntry (c->he); c->he = NULL; + g_attr_delete (&c->attr); + c->graph = NULL; + + /* next/prev are not handled here, but via + * gc_remove, as type-dependent information + * is manipulated (node/arc data in the graph). + */ +} + +/* .................................................. */ + +void +gc_rename (GC* c, GCC* gx, Tcl_Obj* newname, Tcl_Interp* interp) +{ + int nnew; + + /* Release current name, ... */ + Tcl_DecrRefCount (c->name); + + /* ... and create a new one, by taking the argument and shimmering it */ + + c->name = newname; + Tcl_IncrRefCount (c->name); + + /* Update the global name mapping as well */ + + Tcl_DeleteHashEntry (c->he); + c->he = Tcl_CreateHashEntry(gx->map, Tcl_GetString (c->name), &nnew); + Tcl_SetHashValue (c->he, (ClientData) c); + + Tcl_SetObjResult (interp, c->name); +} + +/* .................................................. */ + +int +gc_attr (GCC* gx, int mode, Tcl_Obj* detail, Tcl_Interp* interp, Tcl_Obj* key, + GN_GET_GC* gf, G* g) +{ + const char* ky = Tcl_GetString (key); + int listc; + Tcl_Obj** listv; + + /* Allocate result space, max needed: All nodes */ + + ASSERT (gx->map->numEntries == gx->n, "Inconsistent #elements in graph"); + + switch (mode) { + case A_GLOB: { + /* Iterate over all nodes. Ignore nodes without attributes. Ignore + * nodes not matching the pattern (glob). Ignore nodes not having the + * attribute. + */ + + int i; + GC* iter; + const char* pattern = Tcl_GetString (detail); + Tcl_HashEntry* he; + + listc = 2 * gx->map->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = gx->first; + iter != NULL; + iter= iter->next) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + if (!Tcl_StringMatch(Tcl_GetString (iter->name), pattern)) continue; + + he = Tcl_FindHashEntry (iter->attr, ky); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + + case A_LIST: { + /* Iterate over the specified nodes. Ignore nodes which are not known. + * Ignore nodes without attributes. Ignore nodes not having the + * attribute. Many occurrences of the same node cause repeated + * results. + */ + + GC* iter; + int ec; + Tcl_Obj** ev; + int i, j; + Tcl_HashEntry* he; + + if (Tcl_ListObjGetElements (interp, detail, &ec, &ev) != TCL_OK) { + return TCL_ERROR; + } + + listc = 2 * ((ec > gx->n) ? ec : gx->n); + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, j = 0; i < ec; i++) { + ASSERT_BOUNDS (i, ec); + + iter = (*gf) (g, ev [i], NULL, NULL); + + if (iter == NULL) continue; + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + + he = Tcl_FindHashEntry (iter->attr, ky); + if (!he) continue; + + ASSERT_BOUNDS (j, listc); + ASSERT_BOUNDS (j+1, listc); + + listv [j++] = iter->name; + listv [j++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = j; + } + break; + + case A_REGEXP: { + /* Iterate over all nodes. Ignore nodes without attributes. Ignore + * nodes not matching the pattern (re). Ignore nodes not having the + * attribute. + */ + + int i; + GC* iter; + const char* pattern = Tcl_GetString (detail); + Tcl_HashEntry* he; + + listc = 2 * gx->map->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = gx->first; + iter != NULL; + iter= iter->next) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + if (Tcl_RegExpMatch(interp, Tcl_GetString (iter->name), pattern) < 1) continue; + + he = Tcl_FindHashEntry (iter->attr, ky); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + + case A_NONE: { + /* Iterate over all nodes. Ignore nodes without attributes. Ignore + * nodes not having the attribute. + */ + + int i; + GC* iter; + Tcl_HashEntry* he; + + listc = 2 * gx->map->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = gx->first; + iter != NULL; + iter= iter->next) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + + he = Tcl_FindHashEntry (iter->attr, ky); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + default: + Tcl_Panic ("Bad attr search mode"); + break; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); + return TCL_OK; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/nacommon.h b/tcllib/modules/struct/graph/nacommon.h new file mode 100644 index 0000000..7b23604 --- /dev/null +++ b/tcllib/modules/struct/graph/nacommon.h @@ -0,0 +1,39 @@ +/* struct::graph - critcl - layer 1 declarations + * (c) Graph functions + */ + +#ifndef _G_NACOMMON_H +#define _G_NACOMMON_H 1 +/* .................................................. */ + +#include "tcl.h" +#include <ds.h> + +/* .................................................. */ + +typedef enum attr_mode { + A_LIST, A_GLOB, A_REGEXP, A_NONE +} attr_mode; + +/* .................................................. */ + +void gc_add (GC* c, GCC* gx); +void gc_remove (GC* c, GCC* gx); +void gc_setup (GC* c, GCC* gx, const char* name, G* g); +void gc_delete (GC* c); +void gc_rename (GC* c, GCC* gx, Tcl_Obj* newname, Tcl_Interp* interp); + +int gc_filter (int nodes, Tcl_Interp* interp, + int oc, Tcl_Obj* const* ov, + GCC* gx, GN_GET_GC* gf, G* g); + +/* .................................................. */ +#endif /* _G_NACOMMON_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/node.c b/tcllib/modules/struct/graph/node.c new file mode 100644 index 0000000..711e907 --- /dev/null +++ b/tcllib/modules/struct/graph/node.c @@ -0,0 +1,136 @@ +/* struct::graph - critcl - layer 1 declarations + * (b) Node operations. + */ + +#include <arc.h> +#include <node.h> +#include <util.h> + +/* .................................................. */ + +GN* +gn_new (G* g, const char* name) +{ + GN* n; + int new; + + if (Tcl_FindHashEntry (g->nodes.map, name) != NULL) { + Tcl_Panic ("struct::graph(c) gn_new - tried to use duplicate name for new node"); + } + + n = ALLOC (GN); + + gc_setup ((GC*) n, &g->nodes, name, g); + gc_add ((GC*) n, &g->nodes); + + gn_shimmer_self (n); + + n->in.first = NULL; n->in.n = 0; + n->out.first = NULL; n->out.n = 0; + + return n; +} + +void +gn_delete (GN* n) +{ + /* We assume that the node may still have incoming and outgoing arcs. They + * are deleted recursively. + */ + + gc_remove ((GC*) n, &n->base.graph->nodes); + gc_delete ((GC*) n); + + while (n->in.first) { ga_delete (n->in.first->a); } + while (n->out.first) { ga_delete (n->out.first->a); } + + n->in.first = NULL; n->in.n = 0; + n->out.first = NULL; n->out.n = 0; + + ckfree ((char*) n); +} + +/* .................................................. */ + +void +gn_err_duplicate (Tcl_Interp* interp, Tcl_Obj* n, Tcl_Obj* g) +{ + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, n); + Tcl_AppendToObj (err, "\" already exists in graph \"", -1); + Tcl_AppendObjToObj (err, g); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); +} + +void +gn_err_missing (Tcl_Interp* interp, Tcl_Obj* n, Tcl_Obj* g) +{ + Tcl_Obj* err = Tcl_NewObj (); + + /* Keep any prefix ... */ + Tcl_AppendObjToObj (err, Tcl_GetObjResult (interp)); + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, n); + Tcl_AppendToObj (err, "\" does not exist in graph \"", -1); + Tcl_AppendObjToObj (err, g); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); +} + +/* .................................................. */ + +Tcl_Obj* +gn_serial_arcs (GN* n, Tcl_Obj* empty, Tcl_HashTable* cn) +{ + int lc; + Tcl_Obj** lv; + Tcl_Obj* arcs; + GL* il; + GA* a; + int i, id; + Tcl_HashEntry* he; + + /* Quick return if node has no outgoing arcs */ + + if (!n->out.n) return empty; + + lc = n->out.n; + lv = NALLOC (lc, Tcl_Obj*); + + for (i=0, il = n->out.first; + il != NULL; + il = il->next) { + a = il->a; + he = Tcl_FindHashEntry (cn, (char*) a->end->n); + + /* Ignore arcs which lead out of the subgraph spanned up by the nodes + * in 'cn'. + */ + + if (!he) continue; + ASSERT_BOUNDS(i, lc); + id = (int) Tcl_GetHashValue (he); + lv [i] = ga_serial (a, empty, id); + i++; + } + lc = i; + + arcs = Tcl_NewListObj (lc, lv); + ckfree ((char*) lv); + return arcs; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/node.h b/tcllib/modules/struct/graph/node.h new file mode 100644 index 0000000..88d024a --- /dev/null +++ b/tcllib/modules/struct/graph/node.h @@ -0,0 +1,34 @@ +/* struct::graph - critcl - layer 1 declarations + * (b) Node operations. + */ + +#ifndef _G_NODE_H +#define _G_NODE_H 1 + +#include "tcl.h" +#include <ds.h> + +void gn_shimmer (Tcl_Obj* o, GN* n); +GN* gn_get_node (G* g, Tcl_Obj* node, Tcl_Interp* interp, Tcl_Obj* graph); + +#define gn_shimmer_self(n) \ + gn_shimmer ((n)->base.name, (n)) + +GN* gn_new (G* g, const char* name); +GN* gn_dup (G* dst, GN* src); +void gn_delete (GN* n); + +void gn_err_duplicate (Tcl_Interp* interp, Tcl_Obj* n, Tcl_Obj* g); +void gn_err_missing (Tcl_Interp* interp, Tcl_Obj* n, Tcl_Obj* g); + +Tcl_Obj* gn_serial_arcs (GN* n, Tcl_Obj* empty, Tcl_HashTable* cn); + +#endif /* _G_NODE_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/nodeshimmer.c b/tcllib/modules/struct/graph/nodeshimmer.c new file mode 100644 index 0000000..98df261 --- /dev/null +++ b/tcllib/modules/struct/graph/nodeshimmer.c @@ -0,0 +1,137 @@ +/* struct::graph - critcl - layer 1 definitions. + * (b) Node operations. + * Tcl_ObjType for nodes, and shimmering to it. + */ + +#include <string.h> +#include <node.h> + +/* .................................................. */ + +static void free_rep (Tcl_Obj* obj); +static void dup_rep (Tcl_Obj* obj, Tcl_Obj* dup); +static void string_rep (Tcl_Obj* obj); +static int from_any (Tcl_Interp* ip, Tcl_Obj* obj); + +static +Tcl_ObjType gn_type = { + "tcllib::struct::graph/critcl::node", + free_rep, + dup_rep, + string_rep, + from_any +}; + +/* .................................................. */ + +static void +free_rep (Tcl_Obj* obj) +{ + /* Nothing to do. The rep is the GN in the G. */ +} + +static void +dup_rep (Tcl_Obj* obj, Tcl_Obj* dup) +{ + GN* n = (GN*) obj->internalRep.otherValuePtr; + + dup->internalRep.otherValuePtr = n; + dup->typePtr = &gn_type; +} + +static void +string_rep (Tcl_Obj* obj) +{ + Tcl_Obj* temp; + char* str; + GN* n = (GN*) obj->internalRep.otherValuePtr; + + obj->length = n->base.name->length; + obj->bytes = ckalloc (obj->length + 1); + + memcpy (obj->bytes, n->base.name->bytes, obj->length + 1); +} + +static int +from_any (Tcl_Interp* ip, Tcl_Obj* obj) +{ + Tcl_Panic ("Cannot create GDN structure via regular shimmering."); + return TCL_ERROR; +} + +/* .................................................. */ + +void +gn_shimmer (Tcl_Obj* o, GN* n) +{ + /* Release an existing representation */ + + if (o->typePtr && o->typePtr->freeIntRepProc) { + o->typePtr->freeIntRepProc (o); + } + + o->typePtr = &gn_type; + o->internalRep.otherValuePtr = n; +} + +/* .................................................. */ + +GN* +gn_get_node (G* g, Tcl_Obj* node, Tcl_Interp* interp, Tcl_Obj* graph) +{ + GN* n = NULL; + Tcl_HashEntry* he; + + /* Check if we have a valid cached int.rep. */ + +#if 0 + /* [x] TODO */ + /* Caching of handles implies that the graphs have to */ + /* keep track of the tcl_obj pointing to them. So that */ + /* the int.rep can be invalidated upon graph deletion */ + + if (node->typePtr == &gn_type) { + n = (GN*) node->internalRep.otherValuePtr; + if (n->graph == g) { +#if 0 + fprintf (stderr, "cached: %p (%p - %p)\n", n, t, n->graph); + fflush(stderr); +#endif + return n; + } + } +#endif + /* Incompatible int.rep, or refering to a different + * graph. We go through the hash table. + */ + + he = Tcl_FindHashEntry (g->nodes.map, Tcl_GetString (node)); + + if (he != NULL) { + n = (GN*) Tcl_GetHashValue (he); + + /* Shimmer the object, cache the node information. + */ + + gn_shimmer (node, n); + return n; + } + + /* Node handle not found. Leave an error message, + * if possible. + */ + + if (interp != NULL) { + gn_err_missing (interp, node, graph); + } + return NULL; +} + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/objcmd.c b/tcllib/modules/struct/graph/objcmd.c new file mode 100644 index 0000000..f27ddc3 --- /dev/null +++ b/tcllib/modules/struct/graph/objcmd.c @@ -0,0 +1,178 @@ +/* struct::graph - critcl - layer 2 definitions + * + * -> Support for the graph methods in layer 3. + */ + +#include <methods.h> +#include <objcmd.h> + +/* + *--------------------------------------------------------------------------- + * + * g_objcmd -- + * + * Implementation of graph objects, the main dispatcher function. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the called methods. + * + *--------------------------------------------------------------------------- + */ + +int +g_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + G* g = (G*) cd; + int m; + + static CONST char* methods [] = { + "-->", "=", "append", "arc", "arcs", "deserialize", + "destroy", "get", "getall", "keyexists", "keys", "lappend", + "node", "nodes", "serialize", "set", "swap", "unset", + "walk", + NULL + }; + enum methods { + M_GSET, M_GASSIGN, M_APPEND, M_ARC, M_ARCS, M_DESERIALIZE, + M_DESTROY, M_GET, M_GETALL, M_KEYEXISTS, M_KEYS, M_LAPPEND, + M_NODE, M_NODES, M_SERIALIZE, M_SET, M_SWAP, M_UNSET, + M_WALK + }; + + static CONST char* a_methods [] = { + "append", "attr", "delete", "exists", "flip", + "get", "getall", "getunweighted", "getweight", "hasweight", "insert", + "keyexists", "keys", "lappend", "move", "move-source", + "move-target", "nodes", "rename", "set", "setunweighted", "setweight", + "source", "target", "unset", "unsetweight", "weights", + NULL + }; + enum a_methods { + MA_APPEND, MA_ATTR, MA_DELETE, MA_EXISTS, MA_FLIP, + MA_GET, MA_GETALL, MA_GETUNWEIGHTED, MA_GETWEIGHT, MA_HASWEIGHT, + MA_INSERT, MA_KEYEXISTS, MA_KEYS, MA_LAPPEND, MA_MOVE, + MA_MOVE_SOURCE, MA_MOVE_TARGET, MA_NODES, MA_RENAME, MA_SET, MA_SETUNWEIGHTED, + MA_SETWEIGHT, MA_SOURCE, MA_TARGET, MA_UNSET, MA_UNSETWEIGHT, + MA_WEIGHTS + }; + + static CONST char* n_methods [] = { + "append", "attr", "degree", "delete", "exists", + "get", "getall", "insert", "keyexists", "keys", + "lappend", "opposite", "rename", "set", "unset", + NULL + }; + enum n_methods { + MN_APPEND, MN_ATTR, MN_DEGREE, MN_DELETE, MN_EXISTS, + MN_GET, MN_GETALL, MN_INSERT, MN_KEYEXISTS, MN_KEYS, + MN_LAPPEND, MN_OPPOSITE, MN_RENAME, MN_SET, MN_UNSET + }; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case M_GSET: return gm_GSET (g, interp, objc, objv); + case M_GASSIGN: return gm_GASSIGN (g, interp, objc, objv); + case M_APPEND: return gm_APPEND (g, interp, objc, objv); + case M_ARC: + if (objc < 3) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [2], a_methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + switch (m) { + case MA_APPEND: return gm_arc_APPEND (g, interp, objc, objv); + case MA_ATTR: return gm_arc_ATTR (g, interp, objc, objv); + case MA_DELETE: return gm_arc_DELETE (g, interp, objc, objv); + case MA_EXISTS: return gm_arc_EXISTS (g, interp, objc, objv); + case MA_FLIP: return gm_arc_FLIP (g, interp, objc, objv); + case MA_GET: return gm_arc_GET (g, interp, objc, objv); + case MA_GETALL: return gm_arc_GETALL (g, interp, objc, objv); + case MA_GETUNWEIGHTED: return gm_arc_GETUNWEIGH (g, interp, objc, objv); + case MA_GETWEIGHT: return gm_arc_GETWEIGHT (g, interp, objc, objv); + case MA_HASWEIGHT: return gm_arc_HASWEIGHT (g, interp, objc, objv); + case MA_INSERT: return gm_arc_INSERT (g, interp, objc, objv); + case MA_KEYEXISTS: return gm_arc_KEYEXISTS (g, interp, objc, objv); + case MA_KEYS: return gm_arc_KEYS (g, interp, objc, objv); + case MA_LAPPEND: return gm_arc_LAPPEND (g, interp, objc, objv); + case MA_MOVE: return gm_arc_MOVE (g, interp, objc, objv); + case MA_MOVE_SOURCE: return gm_arc_MOVE_SRC (g, interp, objc, objv); + case MA_MOVE_TARGET: return gm_arc_MOVE_TARG (g, interp, objc, objv); + case MA_NODES: return gm_arc_NODES (g, interp, objc, objv); + case MA_RENAME: return gm_arc_RENAME (g, interp, objc, objv); + case MA_SET: return gm_arc_SET (g, interp, objc, objv); + case MA_SETUNWEIGHTED: return gm_arc_SETUNWEIGH (g, interp, objc, objv); + case MA_SETWEIGHT: return gm_arc_SETWEIGHT (g, interp, objc, objv); + case MA_SOURCE: return gm_arc_SOURCE (g, interp, objc, objv); + case MA_TARGET: return gm_arc_TARGET (g, interp, objc, objv); + case MA_UNSET: return gm_arc_UNSET (g, interp, objc, objv); + case MA_UNSETWEIGHT: return gm_arc_UNSETWEIGH (g, interp, objc, objv); + case MA_WEIGHTS: return gm_arc_WEIGHTS (g, interp, objc, objv); + } + break; + case M_ARCS: return gm_ARCS (g, interp, objc, objv); + case M_DESERIALIZE: return gm_DESERIALIZE (g, interp, objc, objv); + case M_DESTROY: return gm_DESTROY (g, interp, objc, objv); + case M_GET: return gm_GET (g, interp, objc, objv); + case M_GETALL: return gm_GETALL (g, interp, objc, objv); + case M_KEYEXISTS: return gm_KEYEXISTS (g, interp, objc, objv); + case M_KEYS: return gm_KEYS (g, interp, objc, objv); + case M_LAPPEND: return gm_LAPPEND (g, interp, objc, objv); + case M_NODE: + if (objc < 3) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [2], n_methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + switch (m) { + case MN_APPEND: return gm_node_APPEND (g, interp, objc, objv); + case MN_ATTR: return gm_node_ATTR (g, interp, objc, objv); + case MN_DEGREE: return gm_node_DEGREE (g, interp, objc, objv); + case MN_DELETE: return gm_node_DELETE (g, interp, objc, objv); + case MN_EXISTS: return gm_node_EXISTS (g, interp, objc, objv); + case MN_GET: return gm_node_GET (g, interp, objc, objv); + case MN_GETALL: return gm_node_GETALL (g, interp, objc, objv); + case MN_INSERT: return gm_node_INSERT (g, interp, objc, objv); + case MN_KEYEXISTS: return gm_node_KEYEXISTS (g, interp, objc, objv); + case MN_KEYS: return gm_node_KEYS (g, interp, objc, objv); + case MN_LAPPEND: return gm_node_LAPPEND (g, interp, objc, objv); + case MN_OPPOSITE: return gm_node_OPPOSITE (g, interp, objc, objv); + case MN_RENAME: return gm_node_RENAME (g, interp, objc, objv); + case MN_SET: return gm_node_SET (g, interp, objc, objv); + case MN_UNSET: return gm_node_UNSET (g, interp, objc, objv); + } + break; + case M_NODES: return gm_NODES (g, interp, objc, objv); + case M_SERIALIZE: return gm_SERIALIZE (g, interp, objc, objv); + case M_SET: return gm_SET (g, interp, objc, objv); + case M_SWAP: return gm_SWAP (g, interp, objc, objv); + case M_UNSET: return gm_UNSET (g, interp, objc, objv); + case M_WALK: return gm_WALK (g, interp, objc, objv); + } + /* Not coming to this place */ +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/objcmd.h b/tcllib/modules/struct/graph/objcmd.h new file mode 100644 index 0000000..ddc3029 --- /dev/null +++ b/tcllib/modules/struct/graph/objcmd.h @@ -0,0 +1,20 @@ +/* struct::graph - critcl - layer 2 declarations + * Support for graph methods. + */ + +#ifndef _G_OBJCMD_H +#define _G_OBJCMD_H 1 + +#include "tcl.h" + +int g_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _G_OBJCMD_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/tests/XOpsControl b/tcllib/modules/struct/graph/tests/XOpsControl new file mode 100644 index 0000000..3c9f73a --- /dev/null +++ b/tcllib/modules/struct/graph/tests/XOpsControl @@ -0,0 +1,60 @@ +# -*- tcl -*- +# graph.testsuite: tests for the graph operations. +# +# Copyright (c) 2008-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# +# RCS: @(#) $Id: XOpsControl,v 1.22 2009/09/24 19:30:11 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +set SELF [file dirname [info script]] + +# ------------------------------------------------------------------------- + +source ${SELF}/Xsetup +source ${SELF}/Xsupport +source ${SELF}/XOpsSetup + +source ${SELF}/ops/adjmatrix.test ; # Adjacency matrix +source ${SELF}/ops/kruskal.test ; # Minimum spanning tree/forest by Kruskal +source ${SELF}/ops/prim.test ; # Minimum spanning tree/forest by Prim +source ${SELF}/ops/bipartite.test ; # Compute bi-partitions. +## source ${SELF}/ops/maxmatching.test ; # Compute maximal matching from bipartitions. +source ${SELF}/ops/tarjan.test ; # Compute SCCs via Tarjan. +source ${SELF}/ops/components.test ; # Compute connected components. +source ${SELF}/ops/componentof.test ; # Compute connected components II. +source ${SELF}/ops/connected.test ; # Graph connected ? +source ${SELF}/ops/cutvertex.test ; # Node a cut vertex? +source ${SELF}/ops/bridge.test ; # Arc a bridge? +source ${SELF}/ops/eulertour.test ; # Eulerian graphs +source ${SELF}/ops/eulerpath.test ; # Semi-eulerian graphs +source ${SELF}/ops/dijkstra.test ; # Node distances by Dijkstra + +source ${SELF}/ops/distance.test ; # Node distances +source ${SELF}/ops/eccentricity.test ; # Node eccentricity +source ${SELF}/ops/radius.test ; # Graph radius +source ${SELF}/ops/diameter.test ; # Graph diameter + +source ${SELF}/ops/adjlist.test ; # Adjacency lists +source ${SELF}/ops/bellmanford.test ; # Distances by Bellman-Ford +source ${SELF}/ops/bfs.test ; # Breadth-First Searching. +source ${SELF}/ops/busackergowen.test; # Minimum-Cost Maximum-Flow by Busacker-Gowen +source ${SELF}/ops/christofides.test ; # mTSP by Christofides, 3/2-approximation algorithm +source ${SELF}/ops/dinicblockingflow.test ; # Blocking-Flow by Dinic +source ${SELF}/ops/dinicmaximumflow.test ; # Maximum-Flow by Dinic +source ${SELF}/ops/edmondskarp.test ; # Maximum-Flow by Edmonds-Karp +source ${SELF}/ops/floydwarshall.test; # Distances by Floyd-Warshall +source ${SELF}/ops/johnsons.test ; # Distances by Johnsons +source ${SELF}/ops/kcenter.test ; # Metric K-Center, 2-approximation algorithm +source ${SELF}/ops/maxcut.test ; # Maximum Cut, 2-approximation algorithm +source ${SELF}/ops/mdst.test ; # Minimum Diameter/Degree Spanning Trees +source ${SELF}/ops/metrictsp.test ; # Metric Travelling Salesman Problem (mTSP) +# # 2-approximation algorithm. +source ${SELF}/ops/mkmblockingflow.test ; # Blocking Flow by Malhotra, Kumar and Maheshwari +source ${SELF}/ops/tspheuristics.test; # Heuristics of local searching for TSP +# # 2- and 3-approximation algorithms +source ${SELF}/ops/verticescover.test; # Vertex Cover, 2-approximation algorithm +source ${SELF}/ops/weightedkcenter.test ; # Weighted Metric K-Center, 3-approximation algorithm + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/XOpsSetup b/tcllib/modules/struct/graph/tests/XOpsSetup new file mode 100644 index 0000000..ddf46fe --- /dev/null +++ b/tcllib/modules/struct/graph/tests/XOpsSetup @@ -0,0 +1,2750 @@ +# -*- tcl -*- +# graphops.testsuite.setup: Setting up implementation specific definitions. +# +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# +# RCS: @(#) $Id: XOpsSetup,v 1.13 2009/11/03 17:38:30 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +# Place holder for future setup / helper actions. + + +proc SETUP_A {} { + # Used by kruskal, prim tests + + struct::graph mygraph + mygraph node insert 'node0' + mygraph node insert 'node1' + mygraph node insert 'node2' + mygraph node insert 'node3' + mygraph node insert 'node4' + mygraph node insert 'node5' + mygraph node insert 'node6' + + mygraph arc insert 'node0' 'node1' 'arc0_1' + mygraph arc insert 'node0' 'node3' 'arc0_3' + mygraph arc insert 'node1' 'node3' 'arc1_3' + mygraph arc insert 'node1' 'node4' 'arc1_4' + mygraph arc insert 'node2' 'node0' 'arc2_0' + mygraph arc insert 'node2' 'node5' 'arc2_5' + mygraph arc insert 'node3' 'node4' 'arc3_4' + mygraph arc insert 'node3' 'node6' 'arc3_6' + mygraph arc insert 'node3' 'node2' 'arc3_2' + mygraph arc insert 'node3' 'node5' 'arc3_5' + mygraph arc insert 'node4' 'node6' 'arc4_6' + mygraph arc insert 'node6' 'node5' 'arc6_5' + + mygraph arc setweight 'arc0_1' 2 + mygraph arc setweight 'arc0_3' 1 + mygraph arc setweight 'arc1_3' 3 + mygraph arc setweight 'arc1_4' 10 + mygraph arc setweight 'arc2_0' 4 + mygraph arc setweight 'arc2_5' 5 + mygraph arc setweight 'arc3_4' 2 + mygraph arc setweight 'arc3_6' 4 + mygraph arc setweight 'arc3_2' 2 + mygraph arc setweight 'arc3_5' 8 + mygraph arc setweight 'arc4_6' 6 + mygraph arc setweight 'arc6_5' 1 + + # 2 --/4/--> 0 --/2/--> 1 + # |^ | /| + # - \ - / - + # 5 -|2|- 1 -/3/- 10 + # - \ - / - + # | \ | / | + # V \VV V + # 5 <--/8/-- 3 --/2/--> 4 + # ^ | / + # \ - / + # -|1|- 4 -/6/- + # \ - / + # \ | / + # \VV + # 6 + + return +} + +proc SETUP_A2 {} { + SETUP_A + mygraph arc insert 'node0' 'node2' 'arc0_2' + mygraph arc insert 'node0' 'node4' 'arc0_4' + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_B {} { + # Predefined Graph for testing on: + # - isConnected? + # - connectedComponents + # - prim + # - isEulerian? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + # Graph's nodes definition + mygraph node insert S + mygraph node insert A + mygraph node insert B + mygraph node insert C + mygraph node insert D + mygraph node insert E + + # setup arcs and it's weights + mygraph arc insert S A S_A ; mygraph arc setweight S_A 3 + mygraph arc insert A C A_C ; mygraph arc setweight A_C 2 + mygraph arc insert S B S_B ; mygraph arc setweight S_B 1 + mygraph arc insert A B A_B ; mygraph arc setweight A_B 1 + mygraph arc insert B C B_C ; mygraph arc setweight B_C 3 + mygraph arc insert B D B_D ; mygraph arc setweight B_D 5 + mygraph arc insert C D C_D ; mygraph arc setweight C_D 1 + mygraph arc insert D E D_E ; mygraph arc setweight D_E 1 + mygraph arc insert C E C_E ; mygraph arc setweight C_E 3 + + # S --/3/--> A --/2/--> C --/3/--> E + # \ | /^| /-^ + # \ - / - / + # -|1| 1 -|3|- 1 -|1|- + # \ - / - / + # \ V/ V/ + # > B --/5/--> D + # + + return +} + +proc SETUP_B2 {} { + struct::graph mygraph + + mygraph node insert A B C D E F G + + mygraph arc insert A B + mygraph arc insert A E + mygraph arc insert B D + mygraph arc insert B F + mygraph arc insert C A + mygraph arc insert D C + mygraph arc insert E B + mygraph arc insert E F + mygraph arc insert F A + mygraph arc insert F G + mygraph arc insert G E + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_C {} { + # Predefined Graph for testing on: + # - isConnected? + # - isEulerian? + # - isBipartite? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + mygraph node insert A + mygraph node insert B + mygraph node insert C + mygraph node insert D + mygraph node insert E + mygraph node insert F + + mygraph arc insert A B A_B + mygraph arc insert B D B_D + mygraph arc insert D C D_C + mygraph arc insert C A C_A + mygraph arc insert A E A_E + mygraph arc insert E F E_F + + mygraph arc setweight A_B 9 + mygraph arc setweight B_D 10 + mygraph arc setweight D_C 4 + mygraph arc setweight C_A 3 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_D {} { + # Predefined Graph for testing on: + # - isConnected? + # - isEulerian? + # - isBipartite? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + mygraph node insert a + mygraph node insert b + mygraph node insert c + mygraph node insert d + + mygraph node insert f + mygraph node insert g + mygraph node insert h + + mygraph node insert i + mygraph node insert j + + mygraph arc insert d f + mygraph arc insert h j + mygraph arc insert i j + mygraph arc insert f g + mygraph arc insert g h + mygraph arc insert h f + mygraph arc insert a b + mygraph arc insert b c + mygraph arc insert c d + mygraph arc insert d a + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_E {} { + # Predefined Graph for testing on: + # - isBipartite? + # - maxMatching + # - isEulerian? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + mygraph node insert 1w + mygraph node insert 1b + mygraph node insert 2w + mygraph node insert 2b + mygraph node insert 3w + mygraph node insert 3b + mygraph node insert 4w + mygraph node insert 4b + mygraph node insert 5w + mygraph node insert 5b + mygraph node insert 6w + mygraph node insert 6b + mygraph node insert 7w + mygraph node insert 7b + mygraph node insert 8w + mygraph node insert 8b + + mygraph arc insert 1b 1w + mygraph arc insert 1b 2w + mygraph arc insert 2b 1w + mygraph arc insert 2b 2w + mygraph arc insert 2b 3w + mygraph arc insert 2b 4w + mygraph arc insert 3b 2w + mygraph arc insert 3b 3w + mygraph arc insert 3b 5w + mygraph arc insert 3w 4b + mygraph arc insert 4b 3w + mygraph arc insert 4b 4w + mygraph arc insert 4b 6w + mygraph arc insert 4w 5b + mygraph arc insert 4w 7b + mygraph arc insert 5b 5w + mygraph arc insert 5b 6w + mygraph arc insert 5w 6b + mygraph arc insert 6b 6w + mygraph arc insert 6w 7b + mygraph arc insert 6w 8b + mygraph arc insert 7b 7w + mygraph arc insert 7w 8b + mygraph arc insert 8b 8w + mygraph arc insert 8w 7b + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_F {} { + # Predefined Graph for testing on: + # - isBipartite? + # - maxMatching + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + struct::graph mygraph + + mygraph node insert 1w + mygraph node insert 1b + mygraph node insert 2w + mygraph node insert 2b + mygraph node insert 3w + mygraph node insert 3b + mygraph node insert 4w + mygraph node insert 4b + + mygraph arc insert 1b 2w + mygraph arc insert 1b 3w + mygraph arc insert 1b 4w + mygraph arc insert 1w 3b + mygraph arc insert 2b 1w + mygraph arc insert 2b 3w + mygraph arc insert 3b 2w + mygraph arc insert 3w 4b + mygraph arc insert 4b 1w + mygraph arc insert 4b 2w + mygraph arc insert 4w 2b + mygraph arc insert 4w 3b + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_G {} { + # Predefined Graph for testing on: + # - isBipartite? + # - maxMatching + # - isBridge? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + + mygraph node insert 1w + mygraph node insert 1b + mygraph node insert 2w + mygraph node insert 2b + mygraph node insert 3w + mygraph node insert 3b + mygraph node insert 4w + mygraph node insert 4b + mygraph node insert 5w + mygraph node insert 5b + + mygraph arc insert 1b 5w bridge1 + mygraph arc insert 2b 4w + mygraph arc insert 2w 4b + mygraph arc insert 2w 5b + mygraph arc insert 3b 4w + mygraph arc insert 3w 4b + mygraph arc insert 3w 5b + mygraph arc insert 4b 4w bridge2 + mygraph arc insert 5b 1w bridge3 + mygraph arc insert 5w 2b + mygraph arc insert 5w 3b nobridge + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_H {} { + # Predefined Graph for testing on: + # - isConnected? + # - isEulerian? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + mygraph node insert A + mygraph node insert B + mygraph node insert C + mygraph node insert D + mygraph node insert E + + mygraph arc insert A B A_B ; mygraph arc setweight A_B 10 + mygraph arc insert B C B_C ; mygraph arc setweight B_C 8 + mygraph arc insert D C D_C ; mygraph arc setweight D_C 2 + mygraph arc insert B D B_D ; mygraph arc setweight B_D 7 + mygraph arc insert C D C_D ; mygraph arc setweight C_D 1 + mygraph arc insert D E D_E ; mygraph arc setweight D_E 6 + mygraph arc insert E A E_A ; mygraph arc setweight E_A 4 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_I {} { + # Predefined Graph for testing on: + # isConnected? + # isEulerian? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + + mygraph node insert N1 + mygraph node insert N2 + mygraph node insert N3 + mygraph node insert N4 + mygraph node insert N5 + + mygraph arc insert N1 N5 N1_N5 + mygraph arc insert N2 N5 N2_N5 + mygraph arc insert N3 N5 N3_N5 + mygraph arc insert N4 N5 N4_N5 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_J {} { + # Predefined Graph for testing on: + # isConnected? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + + mygraph node insert 1 + mygraph node insert 2 + mygraph node insert 3 + mygraph node insert 4 + mygraph node insert 5 + mygraph node insert 6 + mygraph node insert 7 + + mygraph arc insert 7 6 + mygraph arc insert 6 7 + mygraph arc insert 1 4 + mygraph arc insert 4 5 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_K {} { + # Predefined Graph for testing on: + # isConnected? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + + mygraph node insert No1 + mygraph node insert No2 + mygraph node insert No3 + mygraph node insert No4 + mygraph node insert No5 + + mygraph arc insert No1 No2 a + mygraph arc insert No2 No3 b + mygraph arc insert No3 No4 c + mygraph arc insert No4 No2 d + + mygraph arc insert No5 No5 e + return +} + +proc SETUP_K2 {} { + SETUP_K + mygraph arc insert No5 No1 f + mygraph arc insert No5 No2 g + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_L {} { + # Koenigsberg. + + struct::graph mygraph + mygraph node insert a b c d + mygraph arc insert a c + mygraph arc insert a d + mygraph arc insert b a + mygraph arc insert b c + mygraph arc insert c a + mygraph arc insert d a + mygraph arc insert d b + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_M {} { + # penta-hex-something + + struct::graph mygraph + mygraph node insert 1 2 3 4 5 6 + mygraph arc insert 1 2 + mygraph arc insert 2 3 + mygraph arc insert 3 4 + mygraph arc insert 4 5 + mygraph arc insert 5 1 + mygraph arc insert 1 6 + mygraph arc insert 6 2 + mygraph arc insert 2 5 + mygraph arc insert 5 6 + mygraph arc insert 6 3 + mygraph arc insert 3 1 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_N {} { + # Predefined Graph for testing on: + # isConnected? + # Author: Alejandro Eduardo Cruz Paz + # 28 August 2008 + + struct::graph mygraph + + mygraph node insert 0 1 2 a b c d e f + mygraph arc insert 0 1 + mygraph arc insert 1 2 + mygraph arc insert 2 0 + + mygraph arc insert a b + mygraph arc insert b 0 + mygraph arc insert 0 a + + mygraph arc insert c d + mygraph arc insert d 1 + mygraph arc insert 1 c + + mygraph arc insert e f + mygraph arc insert f 2 + mygraph arc insert 2 e + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BELLMANFORD_1 {} { + #Graph for testing Bellman's Ford algorithm (and also other pathfinding algorithms) + #Used for: + #Bellman's-Ford + #Floyd-Warshall's + #Basic test + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node3 node4 edge34 + mygraph arc insert node4 node1 edge41 + + mygraph arc setunweighted 1 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BELLMANFORD_2 {} { + #Graph for testing Bellman-Ford's Algorithm + #More complex test case + #Used by: + #Bellman-Ford's Algorithm + #Floyd-Warshall's Algorithm + #Shortest Pathfinding by BFS algorithm + #BFS Algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 8 + mygraph arc insert node1 node3 edge13 + mygraph arc setweight edge13 6 + mygraph arc insert node2 node4 edge24 + mygraph arc setweight edge24 -1 + mygraph arc insert node3 node2 edge32 + mygraph arc setweight edge32 3 + mygraph arc insert node3 node5 edge35 + mygraph arc setweight edge35 -2 + mygraph arc insert node4 node3 edge43 + mygraph arc setweight edge43 -2 + mygraph arc insert node4 node6 edge46 + mygraph arc setweight edge46 3 + mygraph arc insert node5 node6 edge56 + mygraph arc setweight edge56 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_POSITIVEWEIGHTED_K4 {} { + SETUP_UNWEIGHTED_K4 + mygraph arc setunweighted 2 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_NEGATIVECYCLE_1 {} { + #Graph containing cycle with negative sum of weights + #Used for testing: + #Bellman-Ford's Algorithm + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 -1 + mygraph arc insert node2 node3 edge23 + mygraph arc setweight edge23 -2 + mygraph arc insert node3 node1 edge31 + mygraph arc setweight edge31 -3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_NEGATIVECYCLE_2 {} { + #Graph containing cycle with negative sum of weights + #Used for testing: + #Bellman-Ford's Algorithm + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node6 + mygraph arc insert node6 node5 + mygraph arc insert node5 node4 + mygraph arc insert node4 node3 + mygraph arc insert node3 node2 + mygraph arc insert node2 node1 + mygraph arc insert node6 node2 edge62 + mygraph arc setweight edge62 -5 + mygraph arc setunweighted 1 + + return + +} + +# ------------------------------------------------------------------------- + +proc SETUP_NEGATIVECYCLE_3 {} { + #Graph containing cycle with negative sum of weights + #Used for testing: + #Bellman-Ford's Algorithm + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 6 + mygraph arc insert node1 node5 edge15 + mygraph arc setweight edge15 7 + mygraph arc insert node2 node4 edge24 + mygraph arc setweight edge24 -4 + mygraph arc insert node2 node5 edge25 + mygraph arc setweight edge25 2 + mygraph arc insert node3 node2 edge32 + mygraph arc setweight edge32 -2 + mygraph arc insert node4 node3 edge43 + mygraph arc setweight edge43 7 + mygraph arc insert node4 node1 edge41 + mygraph arc setweight edge41 2 + mygraph arc insert node5 node3 edge53 + mygraph arc setweight edge53 -3 + mygraph arc insert node5 node4 edge54 + mygraph arc setweight edge54 9 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_K4 {} { + #Complete graph with 4 nodes + #Here without one edge - test for directed graphs + #Used by: + #For distance searches: Johnson's and Bellman-Ford's + #Vertices Cover + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 1 + mygraph arc insert node1 node3 edge13 + mygraph arc setweight edge13 1 + mygraph arc insert node1 node4 edge14 + mygraph arc setweight edge14 1 + + mygraph arc insert node2 node1 edge21 + mygraph arc setweight edge21 1 + mygraph arc insert node2 node3 edge23 + mygraph arc setweight edge23 1 + mygraph arc insert node2 node4 edge24 + mygraph arc setweight edge24 1 + + mygraph arc insert node3 node1 edge31 + mygraph arc setweight edge31 1 + mygraph arc insert node3 node2 edge32 + mygraph arc setweight edge32 1 + mygraph arc insert node3 node4 edge34 + mygraph arc setweight edge34 1 + + mygraph arc insert node4 node1 edge41 + mygraph arc setweight edge41 2 + mygraph arc insert node4 node2 edge42 + mygraph arc setweight edge42 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_PARTIALLYCONNECTED_1 {} { + + #Graph where their does not exists a path between each pair of vertices + #Used for testing: + #Bellman-Ford's Algorithm (Causes appearing of Inf values as a result) + #Johnson's Algorithm (Causes appearing of Inf values as a result) + #Metric Travelling Salesman 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + + mygraph arc insert node1 node5 + mygraph arc insert node2 node5 + mygraph arc insert node3 node5 + mygraph arc insert node4 node5 + + mygraph arc setunweighted 1 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_JOHNSONS_1 {} { + #Graph for testing Johnson's Algorithm + #Used by: + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + # + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + + mygraph arc insert node1 node3 edge13 + mygraph arc setweight edge13 1 + mygraph arc insert node1 node4 edge14 + mygraph arc setweight edge14 7 + + mygraph arc insert node2 node1 edge21 + mygraph arc setweight edge21 4 + + mygraph arc insert node3 node2 edge32 + mygraph arc setweight edge32 -5 + mygraph arc insert node3 node5 edge35 + mygraph arc setweight edge35 2 + + mygraph arc insert node4 node3 edge43 + mygraph arc setweight edge43 6 + + mygraph arc insert node5 node1 edge51 + mygraph arc setweight edge51 3 + mygraph arc insert node5 node2 edge52 + mygraph arc setweight edge52 8 + mygraph arc insert node5 node4 edge54 + mygraph arc setweight edge54 -4 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_JOHNSONS_2 {} { + #Graph for testing Johnson's Algorithm + #Used by: + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 8 + mygraph arc insert node1 node6 edge16 + mygraph arc setweight edge16 6 + mygraph arc insert node2 node3 edge23 + mygraph arc setweight edge23 -1 + mygraph arc insert node3 node4 edge34 + mygraph arc setweight edge34 3 + mygraph arc insert node3 node6 edge36 + mygraph arc setweight edge36 -2 + mygraph arc insert node5 node4 edge54 + mygraph arc setweight edge54 2 + mygraph arc insert node6 node2 edge62 + mygraph arc setweight edge62 3 + mygraph arc insert node6 node5 edge65 + mygraph arc setweight edge65 -2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_UNWEIGHTED_K4 {} { + #Unweighted directed complete graph K4 + #Used by: + #Bellman's-Ford + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + #Metric Travelling Salesman 2-approximation algorithm + #Christofides Algorithm + #Greedy Maximum Independent Set algorithm + #Unweighted k-center 2-approximation algorithm + #Weighted k-center 3-approximation algorithm + #Greedy Weighted Maximum Independent Set algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + + mygraph arc insert node1 node2 + mygraph arc insert node1 node3 + mygraph arc insert node1 node4 + mygraph arc insert node2 node3 + mygraph arc insert node2 node4 + mygraph arc insert node2 node1 + mygraph arc insert node3 node1 + mygraph arc insert node3 node2 + mygraph arc insert node3 node4 + mygraph arc insert node4 node1 + mygraph arc insert node4 node2 + mygraph arc insert node4 node3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_UNDIRECTED_K4 {} { + #Undirected complete graph K4 + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + #Vertices Cover + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + + mygraph arc insert node1 node2 edge12 + mygraph arc insert node1 node3 edge13 + mygraph arc insert node1 node4 edge14 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node2 node4 edge24 + mygraph arc insert node3 node4 edge34 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_PARTIALLYWEIGHTED_K4 {} { + #complete graph K4 with some weights set on edges + #Used by: + #Bellman's-Ford + #Johnson's Algorithm + SETUP_UNWEIGHTED_K4 + + mygraph arc setweight arc1 1 + mygraph arc setweight arc2 2 + mygraph arc setweight arc3 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_NOEDGES_1 {} { + #Graph containing only nodes + #Used by: + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + #Metric Travelling Salesman 2-approximation algorithm + #Christofides Algorithm + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_ZEROWEIGHTED_K4 {} { + #K4 graph with all edge's weights set to 0 + #Used by: + #Bellman's-Ford + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + SETUP_UNWEIGHTED_K4 + mygraph arc setunweighted + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_PARTIALLYZEROWEIGHTED {} { + #graph with some weights of edges set to 0 (others set to 1) + #Used by: + #Bellman's-Ford + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + SETUP_BELLMANFORD_1 + + mygraph arc setweight edge12 0 + mygraph arc setweight edge23 0 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_PARTIALLYZEROWEIGHTED_K4 {} { + #K4 graph with some weights of edges set to 0 + #Used by: + #Bellman's-Ford + #Johnson's Algorithm + #Floyd-Warshall's Algorithm + + SETUP_ZEROWEIGHTED_K4 + + mygraph arc setweight arc1 1 + mygraph arc setweight arc2 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_ADJACENCYLIST_K4 {} { + #special undirected K4 case where we have two arcs between two nodes + #with different sources and targets + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + + mygraph arc insert node1 node2 + mygraph arc insert node1 node3 + mygraph arc insert node1 node4 edge14 + mygraph arc insert node2 node3 + mygraph arc insert node3 node4 + mygraph arc insert node4 node1 edge41 + + return +} +# ------------------------------------------------------------------------- + +proc SETUP_ADJACENCYLIST_K4_WEIGHTED {} { + #weighted version of upper graph + SETUP_ADJACENCYLIST_K4 + + mygraph arc setunweighted 1 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_ADJACENCYLIST_K4_WEIGHTED_DIRECTED {} { + #directed case, with mixed weights at crucial edges + SETUP_ADJACENCYLIST_K4_WEIGHTED + + mygraph arc setweight edge14 2 + mygraph arc setweight edge41 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_ADJACENCYLIST_1 {} { + #undirected and unweighted graph for Adjacency List Testing + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 + mygraph arc insert node1 node6 + mygraph arc insert node2 node3 + mygraph arc insert node3 node6 + mygraph arc insert node4 node5 + mygraph arc insert node4 node6 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TSP_1 {} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 + mygraph arc insert node2 node3 + mygraph arc insert node3 node4 + mygraph arc insert node4 node5 + mygraph arc insert node5 node1 + mygraph arc insert node6 node1 + mygraph arc insert node6 node2 + mygraph arc insert node6 node3 + mygraph arc insert node6 node4 + mygraph arc insert node6 node5 + mygraph arc setunweighted 1 + mygraph arc insert node1 node3 + mygraph arc insert node1 node4 + mygraph arc insert node2 node4 + mygraph arc insert node2 node5 + mygraph arc insert node3 node5 + mygraph arc setunweighted 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TSP_2 {} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + mygraph arc insert node1 node2 + mygraph arc insert node2 node3 + mygraph arc insert node3 node4 + mygraph arc insert node4 node1 + mygraph arc insert node5 node1 + mygraph arc insert node5 node2 + mygraph arc insert node5 node3 + mygraph arc insert node5 node4 + mygraph arc setunweighted 1 + mygraph arc insert node2 node4 + mygraph arc insert node1 node3 + mygraph arc setunweighted 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TSP_3 {} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node2 + mygraph arc insert node3 node2 + mygraph arc insert node3 node4 + mygraph arc insert node4 node1 + mygraph arc insert node2 node1 edge21 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node4 node3 edge43 + mygraph arc insert node1 node4 edge14 + mygraph arc setunweighted 1 + mygraph arc insert node1 node3 + mygraph arc insert node2 node4 + mygraph arc setunweighted 3 + mygraph arc setweight edge23 5 + mygraph arc setweight edge21 4 + mygraph arc setweight edge43 6 + mygraph arc setweight edge14 7 + + return +} + + +# ------------------------------------------------------------------------- + +proc SETUP_MAXCUT_1 {} { + #Graph representing Tight Example for Maximum Cut problem + #In this case algorithm should find right solution. + #Used by: + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node1 node4 edge14 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node3 node4 edge34 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MAXCUT_2 {} { + #Graph representing Tight Example for Maximum Cut problem + #In this case algorithm should find solution, with maximum aproximation factor : ALG = 2 * OPT + #Used by: + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node3 edge13 + mygraph arc insert node1 node4 edge14 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node2 node4 edge24 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MAXCUT_3 {} { + + #Used by: + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node3 + mygraph arc insert node1 node6 + mygraph arc insert node2 node4 + mygraph arc insert node2 node5 + mygraph arc insert node3 node4 + mygraph arc insert node3 node5 + mygraph arc insert node4 node6 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MAXCUT_4 {} { + + #Used by: + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node2 node1 edge21 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node3 node2 edge32 + mygraph arc insert node1 node4 edge14 + mygraph arc insert node4 node5 edge45 + mygraph arc insert node5 node4 edge54 + mygraph arc insert node5 node6 edge56 + mygraph arc insert node6 node5 edge65 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MAXCUT_5 {} { + + #Used by: + #Max Cut 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 + mygraph arc insert node1 node3 + mygraph arc insert node3 node1 + mygraph arc insert node4 node2 + mygraph arc insert node2 node4 + mygraph arc insert node4 node6 + mygraph arc insert node6 node4 + mygraph arc insert node5 node3 + mygraph arc insert node3 node5 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_COUNTEDGES_1 {U V} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node3 + mygraph arc insert node1 node4 + mygraph arc insert node4 node1 + mygraph arc insert node3 node2 + + set varU "node1 node2" + set varV "node3 node4" + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_COUNTEDGES_2 {U V} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node3 + mygraph arc insert node1 node4 + mygraph arc insert node4 node1 + mygraph arc insert node3 node2 + mygraph arc insert node1 node1 + mygraph arc insert node1 node2 + mygraph arc insert node4 node3 + + set varU "node1 node2" + set varV "node3 node4" + return +} +# ------------------------------------------------------------------------- + +proc SETUP_COUNTEDGES_3 {U V} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node1 + mygraph arc insert node1 node2 + mygraph arc insert node4 node3 + + set varU "node1 node2" + set varV "node3 node4" + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_COUNTEDGES_4 {U V} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV + SETUP_COUNTEDGES_2 varU varV + + set varU "node1 node3" + set varV "node2 node4" + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_CUT_1 {U V param} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV param varParam + SETUP_MAXCUT_3 + + set varU "node1 node5 node4" + set varV "node2 node3 node6" + set varParam 7 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_CUT_2 {U V param} { + + #Used by: + #Max Cut 2-approximation algorithm (subprocedure) + + upvar 1 U varU V varV param varParam + SETUP_CUT_1 varU varV varParam + + set varU "node1 node3 node5" + set varV "node2 node4 node6" + set varParam 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_CREATETGRAPH_1 {E} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + upvar 1 E edges + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 1 + mygraph arc insert node1 node3 edge13 + mygraph arc setweight edge13 2 + mygraph arc insert node1 node4 edge14 + mygraph arc setweight edge14 3 + mygraph arc insert node4 node1 edge41 + mygraph arc setweight edge41 4 + + set edges "edge12 edge14" + return + +} + +# ------------------------------------------------------------------------- + +proc SETUP_CREATETGRAPH_2 {E} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + SETUP_NOEDGES_1 + upvar 1 E edges + + set edges "edge1 edge2" + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_CREATETGRAPH_3 {E} { + + #Graph object for Metric Travelling Salesman problems testing + #Used by: + #Metric Travelling Salesman 2-approximation algorithm + + upvar 1 E edges + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 + mygraph arc insert node1 node2 edge12 + mygraph arc setweight edge12 1 + mygraph arc insert node1 node3 edge13 + mygraph arc setweight edge13 2 + mygraph arc insert node1 node4 edge14 + mygraph arc setweight edge14 3 + mygraph arc insert node4 node1 edge41 + mygraph arc setweight edge41 4 + + set edges {edge14 edge41 edge13} + return + +} + +# ------------------------------------------------------------------------- + +proc SETUP_CHRISTO_1 {} { + + #Used by: + #Christofides Algorithm (Tight Example) + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 node7 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node1 node3 edge13 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node2 node4 edge24 + mygraph arc insert node3 node4 edge34 + mygraph arc insert node3 node5 edge35 + mygraph arc insert node4 node5 edge45 + mygraph arc insert node4 node6 edge46 + mygraph arc insert node5 node6 edge56 + mygraph arc insert node5 node7 edge57 + mygraph arc insert node6 node7 edge67 + mygraph arc setunweighted 1 + mygraph arc insert node7 node1 edge71 + mygraph arc setunweighted 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_VC_1 {} { + + #Used by: + #Vertices Cover + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node1 node3 edge13 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node3 node4 edge34 + mygraph arc insert node3 node5 edge35 + mygraph arc insert node3 node6 edge36 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_VC_1_2 {} { + + #Used by: + #Vertices Cover + + SETUP_VC_1 + + mygraph arc insert node2 node1 edge21 + mygraph arc insert node3 node1 edge31 + mygraph arc insert node3 node2 edge32 + mygraph arc insert node4 node3 edge43 + mygraph arc insert node5 node3 edge53 + mygraph arc insert node6 node3 edge63 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_VC_1_3 {} { + + #Used by: + #Vertices Cover + + SETUP_VC_1 + + mygraph arc insert node2 node1 edge21 + mygraph arc insert node3 node1 edge31 + mygraph arc insert node3 node2 edge32 + mygraph arc insert node4 node3 edge43 + + return +} +# ------------------------------------------------------------------------- + +proc SETUP_VC_2 {} { + + #Used by: + #Vertices Cover + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node2 edge12 + mygraph arc insert node1 node3 edge13 + mygraph arc insert node2 node3 edge23 + mygraph arc insert node2 node4 edge24 + mygraph arc insert node3 node5 edge35 + mygraph arc insert node4 node5 edge45 + mygraph arc insert node4 node6 edge46 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_C5 {} { + + #Cycle with 5 edges - C5 + #Used by: + #Greedy Maximum Independent Set algorithm + #Greedy Weighted Maximum Independent Set algorithm + #Vertices Cover + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + mygraph arc insert node1 node2 + mygraph arc insert node2 node3 + mygraph arc insert node3 node4 + mygraph arc insert node4 node5 + mygraph arc insert node5 node1 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_INDEPENDENTSET_1 {} { + + #graph containing 24 nodes for independent set testing + #Reference: http://en.wikipedia.org/wiki/Independent_set_(graph_theory)#Maximal_independent_set + #Used by: + #Greedy Maximum Independent Set algorithm + #Greedy Weighted Maximum Independent Set algorithm + + struct::graph mygraph + + #adding 24 nodes: node1 - node24 + for {set i 1} {$i<=24} {incr i} { + mygraph node insert node$i + } + + #adding external edges: node1 node2, node2 node3.... + for {set i 1} {$i<=12} {incr i} { + set j [ expr { $i%12 } ] + incr j + mygraph arc insert node$i node$j ;#[list node$i node$j] + } + + #adding edges connecting internal nodes with external nodes + for {set i 1} {$i<=12} {incr i} { + mygraph arc insert node$i node[expr {$i+12}] ;#[list node$i node[expr {$i+12}]] + } + + #adding edges between internal nodes + for {set i 13} {$i<=24} {incr i} { + set u [ expr {($i+4)%24} ] + set v [ expr {($i-4)%24} ] + if { $u < 13 } { + if {$u == 0} { + set u 24 + } else { + set u [expr {$u+12}] + } + } + if { $v < 13} { + if {$v == 0} { + set v 24 + } else { + set v [expr {$v+12}] + } + } + + if { ![mygraph arc exists [list node$u node$i]] } { + mygraph arc insert node$i node$u [list node$i node$u] + } + if { ![mygraph arc exists [list node$v node$i]] } { + mygraph arc insert node$i node$v [list node$i node$v] + } + } + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_KCENTER_1 {} { + #Tight Example for unweighted version of K-Center problem + #Used by: + #Unweighted k-center 2-approximation algorithm + #Weighted k-center 3-approximation algorithm + + struct::graph mygraph + mygraph node insert node1 node2 node3 node4 node5 node6 node7 + mygraph arc insert node1 node7 [list node1 node7] + mygraph arc insert node2 node7 [list node2 node7] + mygraph arc insert node3 node7 [list node3 node7] + mygraph arc insert node4 node7 [list node4 node7] + mygraph arc insert node5 node7 [list node5 node7] + mygraph arc insert node6 node7 [list node6 node7] + mygraph arc setunweighted 1 + + for {set i 1} {$i < 7 } { incr i } { + # i in 1..6 + if { ($i+1) < 7 } { + # i in 1..5 + mygraph arc insert node$i node[ expr { $i+1 } ] [list node$i node[ expr { $i+1 } ]] + } elseif { ![mygraph arc exists [list node6 node1]] } { + mygraph arc insert node6 node1 [list node6 node1] + } + + if { ($i+2) < 7 } { + # i in 1..4 + mygraph arc insert node$i node[ expr { $i+2 } ] [list node$i node[ expr { $i+2 } ]] + } elseif { ![mygraph arc exists [list node6 node2]] } { + mygraph arc insert node6 node2 [list node6 node2] + } + } + mygraph arc insert node1 node5 [list node1 node5] + mygraph arc setunweighted 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_KCENTER_2 {} { + + #Used by: + #Unweighted k-center 2-approximation algorithm + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 node7 node8 + + foreach v [mygraph nodes] { + foreach u [mygraph nodes] { + if { ($u!=$v) && ![mygraph arc exists [list $u $v]] } { + mygraph arc insert $v $u [list $v $u] + } + } + } + foreach x [mygraph nodes -adj node1] { + if { [mygraph arc exists [list $x node1]] } { + mygraph arc setweight [list $x node1] 1 + } else { + mygraph arc setweight [list node1 $x] 1 + } + } + foreach x [mygraph nodes -adj node2] { + if { [mygraph arc exists [list $x node2]] } { + mygraph arc setweight [list $x node2] 1 + } else { + mygraph arc setweight [list node2 $x] 1 + } + } + + mygraph arc setunweighted 2 + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TWOSQUARED_1 {} { + + #Used by: + #createSquaredGraph procedure + #Unweighted k-center 2-approximation algorithm (subprocedure that extends two-squared graphs) + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 node7 node8 + mygraph arc insert node1 node2 "node1 node2" + mygraph arc insert node2 node3 "node2 node3" + mygraph arc insert node2 node4 "node2 node4" + mygraph arc insert node3 node4 "node3 node4" + mygraph arc insert node3 node5 "node3 node5" + mygraph arc insert node5 node6 "node5 node6" + mygraph arc insert node5 node7 "node5 node7" + mygraph arc insert node7 node8 "node7 node8" + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TWOSQUARED_2 {} { + + #Used by: + #createSquaredGraph procedure + #Unweighted k-center 2-approximation algorithm (subprocedure that extends two-squared graphs) + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 + mygraph arc insert node1 node2 "node1 node2" + mygraph arc insert node2 node3 "node2 node3" + mygraph arc insert node3 node4 "node3 node4" + mygraph arc insert node4 node5 "node4 node5" + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TWOSQUARED_3 {} { + + #Used by: + #Unweighted k-center 2-approximation algorithm (subprocedure that extends two-squared graphs) + + struct::graph mygraph2 + + mygraph2 node insert node1 node2 node3 node4 node5 + mygraph2 arc insert node1 node2 "node1 node2" + mygraph2 arc insert node2 node3 "node2 node3" + mygraph2 arc insert node3 node4 "node3 node4" + mygraph2 arc insert node1 node3 "node1 node3" + mygraph2 arc insert node2 node4 "node2 node4" + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TWOSQUARED_4 {} { + + #Used by: + #Unweighted k-center 2-approximation algorithm (subprocedure that extends two-squared graphs) + + struct::graph mygraph2 + + mygraph2 node insert node1 node2 node3 node4 node5 node6 node7 node8 + + mygraph2 arc insert node1 node2 "node1 node2" + mygraph2 arc insert node1 node3 "node1 node3" + mygraph2 arc insert node1 node4 "node1 node4" + mygraph2 arc insert node2 node3 "node2 node3" + mygraph2 arc insert node2 node4 "node2 node4" + mygraph2 arc insert node3 node4 "node3 node4" + + mygraph2 arc insert node5 node6 "node5 node6" + mygraph2 arc insert node5 node7 "node5 node7" + mygraph2 arc insert node5 node8 "node5 node8" + mygraph2 arc insert node6 node7 "node6 node7" + mygraph2 arc insert node7 node8 "node7 node8" + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_WEIGHTEDKCENTER_1 {nodeWeights} { + + #Used by: + #Weighted k-center 3-approximation algorithm + + upvar 1 nodeWeights nW + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 node7 node8 + mygraph arc insert node1 node2 + mygraph arc insert node2 node3 + mygraph arc insert node3 node4 + mygraph arc setunweighted 1 + mygraph arc insert node4 node5 + mygraph arc insert node4 node6 + mygraph arc insert node4 node7 + mygraph arc insert node4 node8 + mygraph arc setunweighted 1.5 + + set nW {{node1 2} {node2 2} {node3 2} {node4 1} {node5 Inf} {node6 Inf} {node7 Inf} {node8 Inf}} + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_WEIGHTEDKCENTER_2 {nodeWeights} { + + #Used by: + #Weighted k-center 3-approximation algorithm + + upvar 1 nodeWeights nW + + struct::graph mygraph + + mygraph node insert node1 node2 node3 node4 node5 node6 + mygraph arc insert node1 node6 + mygraph arc insert node2 node6 + mygraph arc insert node3 node6 + + mygraph arc insert node5 node6 + mygraph arc insert node1 node5 + mygraph arc insert node2 node5 + mygraph arc insert node3 node5 + mygraph arc setunweighted 1 + + mygraph arc insert node4 node5 + mygraph arc setunweighted 3 + mygraph arc insert node4 node6 + mygraph arc setunweighted 2 + + set nW {{node1 2} {node2 2} {node3 2} {node4 3} {node5 2} {node6 1}} + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_WEIGHTEDKCENTER_3 {nodeWeights} { + + #Used by: + #Weighted k-center 3-approximation algorithm + + SETUP_WEIGHTEDKCENTER_2 n + + upvar 1 nodeWeights nW + + set nW {{node1 1} {node2 1} {node3 1} {node4 1} {node5 1} {node6 3}} + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_FORDFULKERSON_1 {} { + + #The flow network with througputs set for each existing (non-zero) link + #Used by: + #Edmond's Karp algorithm + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + #Dinic's Algorithm for maximum flow computation + #Subprocedures of above: MKM and Dinic's algorithms for blocking flow finding + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 v4 t + + mygraph arc insert s v1 {s v1} + mygraph arc set {s v1} throughput 16 + + mygraph arc insert s v2 {s v2} + mygraph arc set {s v2} throughput 13 + + mygraph arc insert v1 v2 {v1 v2} + mygraph arc set {v1 v2} throughput 10 + + mygraph arc insert v2 v1 {v2 v1} + mygraph arc set {v2 v1} throughput 4 + + mygraph arc insert v1 v3 {v1 v3} + mygraph arc set {v1 v3} throughput 12 + + mygraph arc insert v2 v4 {v2 v4} + mygraph arc set {v2 v4} throughput 14 + + mygraph arc insert v3 v2 {v3 v2} + mygraph arc set {v3 v2} throughput 9 + + mygraph arc insert v3 t {v3 t} + mygraph arc set {v3 t} throughput 20 + + mygraph arc insert v4 v3 {v4 v3} + mygraph arc set {v4 v3} throughput 7 + + mygraph arc insert v4 t {v4 t} + mygraph arc set {v4 t} throughput 4 + + return + +} + +# ------------------------------------------------------------------------- + +proc SETUP_FORDFULKERSON_2 {} { + + #The flow network with througputs set for each existing (non-zero) link + #Used by: + #Edmond's Karp algorithm (Tight Example) + #Dinic's Algorithm for maximum flow computation + #Subprocedures of above: MKM and Dinic's algorithms for blocking flow finding + + struct::graph mygraph + + mygraph node insert a b c d + + mygraph arc insert a b ab + mygraph arc set ab throughput 1000000 + mygraph arc insert a c ac + mygraph arc set ac throughput 1000000 + mygraph arc insert b d bd + mygraph arc set bd throughput 1000000 + mygraph arc insert c d cd + mygraph arc set cd throughput 1000000 + mygraph arc insert b c bc + mygraph arc set bc throughput 1 + + return + +} + +# ------------------------------------------------------------------------- + +proc SETUP_FORDFULKERSON_3 {} { + + #The flow network with througputs set for each existing (non-zero) link + #Used by: + #Edmond's Karp algorithm + #Dinic's Algorithm for maximum flow computation + #Subprocedures of above: MKM and Dinic's algorithms for blocking flow finding + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 t + + mygraph arc insert s v1 sv1 + mygraph arc set sv1 throughput 10 + + mygraph arc insert s v2 sv2 + mygraph arc set sv2 throughput 5 + + mygraph arc insert s v3 sv3 + mygraph arc set sv3 throughput 3 + + mygraph arc insert v1 v2 v1v2 + mygraph arc set v1v2 throughput 4 + + mygraph arc insert v2 v1 v2v1 + mygraph arc set v2v1 throughput 2 + + mygraph arc insert v2 v2 v2v3 + mygraph arc set v2v3 throughput 2 + + mygraph arc insert v3 v2 v3v2 + mygraph arc set v3v2 throughput 4 + + mygraph arc insert v1 t v1t + mygraph arc set v1t throughput 3 + + mygraph arc insert v2 t v2t + mygraph arc set v2t throughput 8 + + mygraph arc insert v3 t v3t + mygraph arc set v3t throughput 10 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_FORDFULKERSON_4 {} { + + #The flow network with througputs set for each existing (non-zero) link + #Used by: + #Edmond's Karp algorithm + #Dinic's Algorithm for maximum flow computation + #Subprocedures of above: MKM and Dinic's algorithms for blocking flow finding + + SETUP_FORDFULKERSON_3 + + mygraph arc set v1v2 throughput 1 + mygraph arc set v2v1 throughput 1 + mygraph arc set v2v3 throughput 1 + mygraph arc set v3v2 throughput 1 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_FORDFULKERSON_5 {} { + #The flow network with througputs set for each existing (non-zero) link + #Used by: + #Edmond's Karp algorithm + #Dinic's Algorithm for maximum flow computation + #Subprocedures of above: MKM and Dinic's algorithms for blocking flow finding + + SETUP_FORDFULKERSON_3 + + mygraph arc setweight sv1 10.5 + mygraph arc set sv1 throughput 10.5 + mygraph arc set sv2 throughput 5.5 + mygraph arc set sv3 throughput 3.5 + mygraph arc set v1v2 throughput 4.5 + mygraph arc set v2v1 throughput 2.5 + mygraph arc set v2v3 throughput 2.3 + mygraph arc set v3v2 throughput 4.2 + mygraph arc set v1t throughput 3.1 + mygraph arc set v2t throughput 8.9 + mygraph arc set v3t throughput 10.1 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_FLOWS_0 {mygraph} { + + #Used by: + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + + foreach arc [$mygraph arcs] { + set u [$mygraph arc source $arc] + set v [$mygraph arc target $arc] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + return $f +} + +# ------------------------------------------------------------------------- + +proc SETUP_FLOWS_1 {mygraph} { + + #Used by: + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + + set f [SETUP_FLOWS_0 $mygraph] + + dict set f [list s v1] 4 + dict set f [list v1 v3] 4 + dict set f [list v3 v2] 4 + dict set f [list v2 v4] 4 + dict set f [list v4 t] 4 + + return $f +} + +# ------------------------------------------------------------------------- + +proc SETUP_FLOWS_2 {mygraph} { + + #Used by: + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + + set f [SETUP_FLOWS_0 $mygraph] + + dict set f [list s v1] 11 + dict set f [list v1 v3] 4 + dict set f [list v3 v2] 4 + dict set f [list v2 v4] 11 + dict set f [list v4 t] 4 + + dict set f [list v1 v2] 7 + dict set f [list v4 v3] 7 + dict set f [list v3 t] 7 + + + return $f +} + +# ------------------------------------------------------------------------- + +proc SETUP_FLOWS_3 {mygraph} { + + #Used by: + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + + set f [SETUP_FLOWS_0 $mygraph] + + dict set f [list s v1] 11 + dict set f [list s v2] 8 + dict set f [list v2 v1] 1 + dict set f [list v1 v3] 12 + dict set f [list v2 v4] 11 + dict set f [list v3 v2] 4 + dict set f [list v4 v3] 7 + dict set f [list v3 t] 15 + dict set f [list v4 t] 4 + + return $f +} + +# ------------------------------------------------------------------------- + +proc SETUP_FLOWS_4 {mygraph} { + + #Used by: + #Create Residual Graph procedure (subprocedure of Edmond's Karp) + + set f [SETUP_FLOWS_0 $mygraph] + + dict set f [list s v1] 11 + dict set f [list s v2] 12 + dict set f [list v2 v1] 1 + dict set f [list v1 v3] 12 + dict set f [list v2 v4] 11 + dict set f [list v4 v3] 7 + dict set f [list v3 t] 19 + dict set f [list v4 t] 4 + + return $f +} + +# ------------------------------------------------------------------------- + +proc SETUP_AUGMENTINGNETWORK_1 {_f _path} { + + #Used by: + #Create Augmenting Network procedure (subprocedure of Busacker-Gowen's Algorithm) + + upvar 1 $_f f $_path path + + struct::graph mygraph + + mygraph node insert s a b c t + + mygraph arc insert s a [list s a] + mygraph arc set [list s a] throughput 18 + mygraph arc set [list s a] cost 3 + + mygraph arc insert s c [list s c] + mygraph arc set [list s c] throughput 20 + mygraph arc set [list s c] cost 8 + + mygraph arc insert a b [list a b] + mygraph arc set [list a b] throughput 20 + mygraph arc set [list a b] cost 5 + + mygraph arc insert a c [list a c] + mygraph arc set [list a c] throughput 15 + mygraph arc set [list a c] cost 4 + + mygraph arc insert c b [list c b] + mygraph arc set [list c b] throughput 12 + mygraph arc set [list c b] cost 8 + + mygraph arc insert b t [list b t] + mygraph arc set [list b t] throughput 14 + mygraph arc set [list b t] cost 5 + + mygraph arc insert c t [list c t] + mygraph arc set [list c t] throughput 17 + mygraph arc set [list c t] cost 3 + + set path {} + lappend path s a c t + + foreach e [mygraph arcs] { + set u [mygraph arc source $e] + set v [mygraph arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + dict set f [list s a] 15 + dict set f [list a c] 15 + dict set f [list c t] 15 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_AUGMENTINGNETWORK_2 {_f _path} { + + #Used by: + #Create Augmenting Network procedure (subprocedure of Busacker-Gowen's Algorithm) + + upvar 1 $_f f $_path path + + SETUP_AUGMENTINGNETWORK_1 f path + + #mygraph arc insert s a [list s a] + mygraph arc set [list s a] throughput 3 + mygraph arc set [list s a] cost 3 + + mygraph arc insert a s [list a s] + mygraph arc set [list a s] throughput 15 + mygraph arc set [list a s] cost -3 + + mygraph arc insert c a [list c a] + mygraph arc set [list c a] throughput 15 + mygraph arc set [list c a] cost -4 + + mygraph arc set [list a c] throughput 0 + mygraph arc set [list a c] cost Inf + + #mygraph arc insert c t [list c t] + mygraph arc set [list c t] throughput 2 + mygraph arc set [list c t] cost 3 + + mygraph arc insert t c [list t c] + mygraph arc set [list t c] throughput 15 + mygraph arc set [list t c] cost -3 + + set path {} + lappend path s c t + + dict set f [list s a] 15 + dict set f [list a c] 15 + dict set f [list c t] 17 + dict set f [list s c] 2 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_AUGMENTINGNETWORK_3 {_f _path} { + + #Used by: + #Create Augmenting Network procedure (subprocedure of Busacker-Gowen's Algorithm) + + upvar 1 $_f f $_path path + + SETUP_AUGMENTINGNETWORK_2 f path + + mygraph arc set [list c t] throughput 0 + mygraph arc set [list c t] cost Inf + + mygraph arc set [list t c] throughput 17 + mygraph arc set [list t c] cost -3 + + mygraph arc set [list s c] throughput 18 + mygraph arc set [list s c] cost 8 + + mygraph arc insert c s [list c s] + mygraph arc set [list c s] throughput 2 + mygraph arc set [list c s] cost -8 + + set path {} + lappend path s a b t + + dict set f [list s a] 18 + dict set f [list a c] 15 + dict set f [list c t] 17 + dict set f [list s c] 2 + dict set f [list a b] 3 + dict set f [list b t] 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BUSACKERGOWEN_1 {} { + + #Used by: + #Busacker Gowen Algorithm + + struct::graph mygraph + + mygraph node insert s a b c t + + mygraph arc insert s a sa + mygraph arc setweight sa 3 + mygraph arc set sa cost 3 + mygraph arc set sa throughput 18 + + mygraph arc insert s c sc + mygraph arc setweight sc 8 + mygraph arc set sc cost 8 + mygraph arc set sc throughput 20 + + mygraph arc insert a b ab + mygraph arc setweight ab 5 + mygraph arc set ab cost 5 + mygraph arc set ab throughput 20 + + mygraph arc insert a c ac + mygraph arc setweight ac 4 + mygraph arc set ac cost 4 + mygraph arc set ac throughput 15 + + mygraph arc insert c b cb + mygraph arc setweight cb 8 + mygraph arc set cb cost 8 + mygraph arc set cb throughput 12 + + mygraph arc insert b t bt + mygraph arc setweight bt 5 + mygraph arc set bt cost 5 + mygraph arc set bt throughput 14 + + mygraph arc insert c t ct + mygraph arc setweight ct 3 + mygraph arc set ct cost 3 + mygraph arc set ct throughput 17 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BUSACKERGOWEN_2 {} { + #graph with not all attributes set + + #Used by: + #Busacker Gowen Algorithm + #Edmond's Karp Algorithm + + struct::graph mygraph + + mygraph node insert s v1 v2 t + mygraph arc insert v1 s v1s + + mygraph arc insert v2 s v2s + mygraph arc insert v1 t v1t + mygraph arc set v1t throughput 20 + mygraph arc set v1t cost 5 + mygraph arc insert v2 t v2t + mygraph arc set v2t throughput 20 + mygraph arc set v2t cost 5 + + return +} +# ------------------------------------------------------------------------- + +proc SETUP_SOURCESINKNOPATHS {} { + #graph where from the start path between source node s and + #sink node t doesn't exist + #Used by Busacker - Gowen + + struct::graph mygraph + + mygraph node insert s v1 v2 t + mygraph arc insert v1 s v1s + mygraph arc set v1s throughput 20 + mygraph arc set v1s cost 5 + mygraph arc insert v2 s v2s + mygraph arc set v2s throughput 20 + mygraph arc set v2s cost 5 + mygraph arc insert v1 t v1t + mygraph arc set v1t throughput 20 + mygraph arc set v1t cost 5 + mygraph arc insert v2 t v2t + mygraph arc set v2t throughput 20 + mygraph arc set v2t cost 5 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_1 {} { + + #Used by: + #Minimum Diameter Spanning Tree Algorithm + #BFS algorithm + + struct::graph mygraph + + mygraph node insert a b c d e f g h i j + + mygraph arc insert a b + mygraph arc insert b c + mygraph arc insert c d + mygraph arc insert d e + mygraph arc insert e f + mygraph arc insert b h + mygraph arc insert c g + mygraph arc insert d h + mygraph arc insert e g + mygraph arc insert g i + mygraph arc insert h j + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_2 {} { + + #Used by: + #Minimum Degree Spanning Tree Tests + + struct::graph mygraph + + mygraph node insert v1 v2 v3 v4 v5 v6 v7 v8 + mygraph arc insert v1 v2 12 + mygraph arc insert v1 v3 13 + mygraph arc insert v2 v4 24 + mygraph arc insert v3 v4 34 + mygraph arc insert v3 v5 35 + mygraph arc insert v4 v5 45 + mygraph arc insert v5 v6 56 + mygraph arc insert v5 v7 57 + mygraph arc insert v7 v8 78 + mygraph arc insert v6 v8 68 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_3 {} { + + #Used by: + #Minimum Diameter Spanning Tree Algorithm + + struct::graph mygraph + + mygraph node insert a b c d e + mygraph arc insert a b ab + mygraph arc insert b c bc + mygraph arc insert c d cd + mygraph arc insert d e de + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_4 {} { + + #Used by: + #Minimum Diameter Spanning Tree Algorithm + + SETUP_MDST_3 + + mygraph node insert f g + mygraph arc insert e f ef + mygraph arc insert f g fg + mygraph arc insert d g dg + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_5 {} { + + #Used by: + #Minimum Diameter Spanning Tree Algorithm + + struct::graph mygraph + mygraph node insert a b c d e + mygraph arc insert a b ab + mygraph arc insert b c bc + mygraph arc insert c d cd + mygraph arc insert d e de + mygraph arc insert a c ac + mygraph arc insert b d bd + mygraph arc insert c e ce + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_6 {} { + + #Used by: + #Minimum Degree Spanning Tree Tests + + struct::graph mygraph + + mygraph node insert a b c d e f g + mygraph arc insert a b ab + mygraph arc insert b c bc + mygraph arc insert c d cd + mygraph arc insert d e de + mygraph arc insert e f ef + mygraph arc insert f a fa + mygraph arc insert g a ga + mygraph arc insert g b gb + mygraph arc insert g c gc + mygraph arc insert g d gd + mygraph arc insert g e ge + mygraph arc insert g f gf + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MDST_7 {} { + + #Used by: + #Minimum Degree Spanning Tree Tests + + struct::graph mygraph + + mygraph node insert a b c d e f + mygraph arc insert a b ab + mygraph arc insert a c ac + mygraph arc insert b d bd + mygraph arc insert c e ce + mygraph arc insert d f df + mygraph arc insert e f ef + mygraph arc insert b e be + mygraph arc insert c d cd + mygraph arc insert a f af + mygraph arc insert f a fa + mygraph arc insert b c bc + mygraph arc insert d e de + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BLOCKINGFLOW_1 {} { + + #Residual graph for blocking flow testing + #Used by: + #Dinic's Blocking Flow Algorithm + #MKM (3 Hindu) Blocking Flow Algorithm + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 v4 v5 v6 v7 t + + mygraph arc insert s v1 sv1 + mygraph arc set sv1 throughput 4 + mygraph arc insert s v3 sv3 + mygraph arc set sv3 throughput 2 + mygraph arc insert v1 v2 v1v2 + mygraph arc set v1v2 throughput 3 + mygraph arc insert v1 v4 v1v4 + mygraph arc set v1v4 throughput 1 + mygraph arc insert v2 v5 v2v5 + mygraph arc set v2v5 throughput 2 + mygraph arc insert v3 v4 v3v4 + mygraph arc set v3v4 throughput 1 + mygraph arc insert v3 v6 v3v6 + mygraph arc set v3v6 throughput 3 + mygraph arc insert v4 v1 v4v1 + mygraph arc set v4v1 throughput 1 + mygraph arc insert v4 v5 v4v5 + mygraph arc set v4v5 throughput 2 + mygraph arc insert v4 v7 v4v7 + mygraph arc set v4v7 throughput 2 + mygraph arc insert v4 v6 v4v6 + mygraph arc set v4v6 throughput 1 + mygraph arc insert v5 v1 v5v1 + mygraph arc set v5v1 throughput 3 + mygraph arc insert v5 t v5t + mygraph arc set v5t throughput 3 + mygraph arc insert v6 v4 v6v4 + mygraph arc set v6v4 throughput 3 + mygraph arc insert v6 v7 v6v7 + mygraph arc set v6v7 throughput 4 + mygraph arc insert v7 t v7t + mygraph arc set v7t throughput 2 + mygraph arc insert t v7 tv7 + mygraph arc set tv7 throughput 3 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BLOCKINGFLOW_2 {} { + + #residual graph for blocking flow testing + #Used by: + #Dinic's Blocking Flow Algorithm + #MKM (3 Hindu) Blocking Flow Algorithm + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 v4 t + + mygraph arc insert s v2 sv2 + mygraph arc set sv2 throughput 6 + mygraph arc insert v2 s v2s + mygraph arc set v2s throughput 4 + mygraph arc insert v1 s v1s + mygraph arc set v1s throughput 10 + mygraph arc insert v1 v2 v1v2 + mygraph arc set v1v2 throughput 2 + mygraph arc insert v1 v4 v1v4 + mygraph arc set v1v4 throughput 2 + mygraph arc insert v2 v4 v2v4 + mygraph arc set v2v4 throughput 5 + mygraph arc insert v3 v1 v3v1 + mygraph arc set v3v1 throughput 4 + mygraph arc insert v3 t v3t + mygraph arc set v3t throughput 6 + mygraph arc insert v4 v1 v4v1 + mygraph arc set v4v1 throughput 6 + mygraph arc insert v4 v2 v4v2 + mygraph arc set v4v2 throughput 4 + mygraph arc insert v4 v3 v4v3 + mygraph arc set v4v3 throughput 6 + mygraph arc insert t v4 tv4 + mygraph arc set tv4 throughput 10 + mygraph arc insert t v3 tv3 + mygraph arc set tv3 throughput 4 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BLOCKINGFLOW_3 {} { + + #residual graph for blocking flow testing + #Used by: + #Dinic's Blocking Flow Algorithm + #MKM (3 Hindu) Blocking Flow Algorithm + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 v4 t + + mygraph arc insert v2 s v2s + mygraph arc set v2s throughput 10 + mygraph arc insert v1 s v1s + mygraph arc set v1s throughput 10 + mygraph arc insert v1 v2 v1v2 + mygraph arc set v1v2 throughput 2 + mygraph arc insert v1 v4 v1v4 + mygraph arc set v1v4 throughput 2 + mygraph arc insert v3 v1 v3v1 + mygraph arc set v3v1 throughput 4 + mygraph arc insert v3 t v3t + mygraph arc set v3t throughput 1 + mygraph arc insert v3 v4 v3v4 + mygraph arc set v3v4 throughput 5 + mygraph arc insert v4 v1 v4v1 + mygraph arc set v4v1 throughput 6 + mygraph arc insert v4 v2 v4v2 + mygraph arc set v4v2 throughput 9 + mygraph arc insert v4 v3 v4v3 + mygraph arc set v4v3 throughput 1 + mygraph arc insert t v4 tv4 + mygraph arc set tv4 throughput 10 + mygraph arc insert t v3 tv3 + mygraph arc set tv3 throughput 9 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_MAXIMUMFLOW_1 {} { + + #Flow network for maximum flow computation problems and generally flow problems. + #Used by: + #Dinic's Maximum Flow Algorithm + #Dinic's Blocking Flow Algorithm + #MKM (3 Hindu) Blocking Flow Algorithm + + struct::graph mygraph + + mygraph node insert s v1 v2 v3 v4 t + + mygraph arc insert s v1 sv1 + mygraph arc set sv1 throughput 10 + mygraph arc insert s v2 sv2 + mygraph arc set sv2 throughput 10 + mygraph arc insert v1 v2 v1v2 + mygraph arc set v1v2 throughput 2 + mygraph arc insert v2 v4 v2v4 + mygraph arc set v2v4 throughput 9 + mygraph arc insert v1 v4 v1v4 + mygraph arc set v1v4 throughput 8 + mygraph arc insert v1 v3 v1v3 + mygraph arc set v1v3 throughput 4 + mygraph arc insert v4 v3 v4v3 + mygraph arc set v4v3 throughput 6 + mygraph arc insert v3 t v3t + mygraph arc set v3t throughput 10 + mygraph arc insert v4 t v4t + mygraph arc set v4t throughput 10 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BFS_1 {} { + + #Used by: + #BFS algorithm + #Shortest Pathfinding by BFS algorithm + + struct::graph mygraph + mygraph node insert s a b c d x + + mygraph arc insert s a sa + mygraph arc setweight sa 4 + mygraph arc insert s x sx + mygraph arc setweight sx 5 + mygraph arc insert a b ab + mygraph arc setweight ab 5 + mygraph arc insert x d xd + mygraph arc setweight xd 7 + mygraph arc insert x a xa + mygraph arc setweight xa -3 + mygraph arc insert b d bd + mygraph arc setweight bd 2 + mygraph arc insert b c bc + mygraph arc setweight bc 6 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_BFS_2 {} { + + #Used by: + #BFS algorithm + #Shortest Pathfinding by BFS algorithm + + struct::graph mygraph + mygraph node insert s a b c d t + + mygraph arc insert s d sd + mygraph arc setweight sd 9 + mygraph arc insert s a sa + mygraph arc setweight sa 15 + mygraph arc insert a c ac + mygraph arc setweight ac 3 + mygraph arc insert a b ab + mygraph arc setweight ab 35 + mygraph arc insert b a ba + mygraph arc setweight ba 16 + mygraph arc insert b c bc + mygraph arc setweight bc 6 + mygraph arc insert b t bt + mygraph arc setweight bt 21 + mygraph arc insert c t ct + mygraph arc setweight ct 7 + mygraph arc insert c d cd + mygraph arc setweight cd 2 + mygraph arc insert d c dc + mygraph arc setweight dc 2 + mygraph arc insert d a da + mygraph arc setweight da 4 + mygraph arc insert t b tb + mygraph arc setweight tb 5 + + return +} + +# ------------------------------------------------------------------------- + +proc SETUP_TSPHEURISTIC_1 {C} { + + #Used by: + #TSP heuristics of local searching - 2 approximation algorithm + upvar $C _C + + struct::graph mygraph + mygraph node insert a b c d e + + mygraph arc insert a b ab + mygraph arc set ab weight 11 + mygraph arc insert a c ac + mygraph arc set ac weight 16 + mygraph arc insert a d ad + mygraph arc set ad weight 28 + mygraph arc insert a e ae + mygraph arc set ae weight 42 + mygraph arc insert b c bc + mygraph arc set bc weight 44 + mygraph arc insert b d bd + mygraph arc set bd weight 31 + mygraph arc insert b e be + mygraph arc set be weight 27 + mygraph arc insert c d cd + mygraph arc set cd weight 6 + mygraph arc insert c e ce + mygraph arc set ce weight 15 + mygraph arc insert d e de + mygraph arc set de weight 21 + + set _C {ab bc cd de ae} + + return +} + +# ------------------------------------------------------------------------- +# Generators for various error messages generated +# by the implementations. + +proc NegativeCycleOccurance { g } { return "Error. Given graph \"mygraph\" contains cycle with negative sum of weights." } +proc UnweightedArcOccurance { } { return "Operation invalid for graph with unweighted arcs." } +proc LackOfEdgesOccurance {G e} { return "Edge \"$e\" doesn't exist in graph \"mygraph\". Set the proper set of edges." } +proc UnconnectedGraphOccurance {G} { return "Error. Given graph \"mygraph\" is not a connected graph." } +proc WrongValueAtInput {x} { return "The \"$x\" value must be an positive integer." } +proc LackOfSinkOrSource {s t} { return "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" } +proc WrongAttributes {args} { + set message "The input network doesn't have all attributes set correctly... Please, check again attributes: " + append message "\"[join $args "\" and \""]\"" + return "$message for input graph." +} diff --git a/tcllib/modules/struct/graph/tests/XOpsSupport b/tcllib/modules/struct/graph/tests/XOpsSupport new file mode 100644 index 0000000..1fb96f8 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/XOpsSupport @@ -0,0 +1,128 @@ +# -*- tcl -*- +# graphops.testsupport: Helper commands for the graph ops testsuite. +# +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# All rights reserved. +# +# RCS: @(#) $Id: XOpsSupport,v 1.6 2009/09/24 19:30:11 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +# Code to generate various graphs to operate on. + +#---------------------------------------------------------------------- + +proc bicanon {bi} { + return [lsort -dict [list [lsort -dict [lindex $bi 0]] [lsort -dict [lindex $bi 1]]]] +} + +proc setsetcanon {s} { + set r {} + foreach item $s { + lappend r [lsort -dict $item] + } + return [lsort -dict $r] +} + +#---------------------------------------------------------------------- + +proc EulerTour {g arcs} { + Euler 1 $g $arcs +} + +proc EulerPath {g arcs} { + Euler 0 $g $arcs +} + +proc Euler {tour g arcs} { + if {[llength [lsort -unique $arcs]] < [llength $arcs]} { + #puts [lsort $arcs] + return dup-arcs + } elseif {![struct::set equal $arcs [$g arcs]]} { + #puts [lsort $arcs] + #puts [lsort [$g arcs] + return missing-arcs + } + set a [lindex $arcs 0] + set first [list [$g arc source $a] [$g arc target $a]] + set last $first + + #puts T=($arcs) + #puts "$a == ($first)" + foreach a [lrange $arcs 1 end] { + set now [list [$g arc source $a] [$g arc target $a]] + set nail [struct::set intersect $last $now] + + #puts -nonewline "$a == ($now) * ($last) = ($nail)" + + if {[struct::set size $nail] < 1} { + return gap + } elseif {[struct::set size $nail] > 1} { + return same + } + + if {[struct::set size $now] > 1} { + set last [struct::set difference $now $nail] + } ; # else: a loop arc has no effect on last. + + #puts " --> ($last)" + } + if {$tour} { + set nail [struct::set intersect $last $first] + if {[struct::set size $nail] < 1} { + return gap + } elseif {[struct::set size $nail] > 1} { + return same + } + } + return ok +} + +#---------------------------------------------------------------------- + +# custom match code. +proc ismaxindependentset {g nodes} { + + # i. all nodes in the set are pair-wise independent (no arcs + # between them). + foreach u $nodes { + set ua [$g arcs -adj $u] + foreach v $nodes { + # ignore u == v + if {$u eq $v} continue + set va [$g arcs -adj $v] + if {![struct::set empty [struct::set intersect $ua $va]]} { + # u, v have arc between them, are not independent. + return 0 + } + } + } + + # ii. all nodes outside of the set in the gaph are dependent on at + # least one node in the set. + foreach v [$g nodes] { + # ignore nodes in the set + if {$v in $nodes} continue + set va [$g arcs -adj $v] + + # node outside the set must have edge to at least one node in + # the set, or it would independent of it and the set would not + # be maximal. + set ok 0 + foreach u $nodes { + set ua [$g arcs -adj $u] + if {![struct::set empty [struct::set intersect $ua $va]]} { + # u, v have an arc between them, are not independent, + # good. + set ok 1 + break + } + } + if {!$ok} { return 0 } + } + return 1 +} + +#---------------------------------------------------------------------- +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/Xcontrol b/tcllib/modules/struct/graph/tests/Xcontrol new file mode 100644 index 0000000..a08c0d0 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/Xcontrol @@ -0,0 +1,72 @@ +# -*- tcl -*- +# graph.testsuite: tests for the graph structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# +# RCS: @(#) $Id: Xcontrol,v 1.3 2009/09/24 16:23:47 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +set SELF [file dirname [info script]] + +# ------------------------------------------------------------------------- + +source ${SELF}/Xsetup + +source ${SELF}/arcs.test +source ${SELF}/assign.test +source ${SELF}/command.test +source ${SELF}/deserialize.test +source ${SELF}/nodes.test +source ${SELF}/rassign.test +source ${SELF}/serialize.test +source ${SELF}/swap.test +source ${SELF}/walk.test + +source ${SELF}/arc/attr.test +source ${SELF}/arc/delete.test +source ${SELF}/arc/exists.test +source ${SELF}/arc/flip.test +source ${SELF}/arc/insert.test +source ${SELF}/arc/move.test +source ${SELF}/arc/move-source.test +source ${SELF}/arc/move-target.test +source ${SELF}/arc/rename.test +source ${SELF}/arc/source.test +source ${SELF}/arc/target.test +source ${SELF}/arc/nodes.test +source ${SELF}/arc/getweight.test +source ${SELF}/arc/getunweighted.test +source ${SELF}/arc/hasweight.test +source ${SELF}/arc/setunweighted.test +source ${SELF}/arc/setweight.test +source ${SELF}/arc/unsetweight.test +source ${SELF}/arc/weights.test + +source ${SELF}/node/attr.test +source ${SELF}/node/degree.test +source ${SELF}/node/delete.test +source ${SELF}/node/exists.test +source ${SELF}/node/insert.test +source ${SELF}/node/opposite.test +source ${SELF}/node/rename.test + +# Attribute handling, graph, arcs, nodes - mostly identical + +source ${SELF}/attr/Xsetup ; # Implementation independent - Move2 Xsupport? +source ${SELF}/attr/append.test +source ${SELF}/attr/get.test +source ${SELF}/attr/getall.test +source ${SELF}/attr/keyexists.test +source ${SELF}/attr/keys.test +source ${SELF}/attr/lappend.test +source ${SELF}/attr/set.test +source ${SELF}/attr/unset.test + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/Xsetup b/tcllib/modules/struct/graph/tests/Xsetup new file mode 100644 index 0000000..36a696b --- /dev/null +++ b/tcllib/modules/struct/graph/tests/Xsetup @@ -0,0 +1,100 @@ +# -*- tcl -*- +# graph.testsuite.setup: Setting up implementation specific definitions. +# +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# +# RCS: @(#) $Id: Xsetup,v 1.4 2009/11/03 17:38:30 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +# tmWrong - wrong#args generation, missing arguments +# tmTooMany - wrong#args generation, too many arguments +# MY - variable holding the name of the graph instance found in +# error messages. + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint graph_critcl [string equal $impl critcl] + +switch -exact -- $setimpl { + critcl { + proc tmSE {tcl critcl} {return $critcl} + } + tcl { + proc tmSE {tcl critcl} {return $tcl} + } +} + +switch -exact -- $impl { + critcl { + set MY mygraph + + proc tmWrong {m loarg n {xarg {}}} { + return [tcltest::wrongNumArgs "mygraph $m" $loarg $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + return [tcltest::tooManyArgs "mygraph $m" $loarg] + } + + proc tmE {tcl critcl} {return $critcl} + + if {[package vsatisfies [package present Tcl] 8.5]} { + proc tmWrongA {m loarg n {xarg {}}} { + if {[llength $m] > 1} {set m [lindex $m 1]} + return [tcltest::wrongNumArgs "CMD $m" $loarg $n] + } + + proc tmTooManyA {m loarg {xarg {}}} { + if {[llength $m] > 1} {set m [lindex $m 1]} + return [tcltest::tooManyArgs "CMD $m" $loarg] + } + } else { + proc tmWrongA {m loarg n {xarg {}}} { + return [tcltest::wrongNumArgs "mygraph $m" $loarg $n] + } + + proc tmTooManyA {m loarg {xarg {}}} { + return [tcltest::tooManyArgs "mygraph $m" $loarg] + } + } + } + tcl { + set MY ::mygraph + + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + if {[llength $m] > 1} {set m _[join $m _]} + incr n + return [tcltest::wrongNumArgs "::struct::graph::_$m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + if {[llength $m] > 1} {set m _[join $m _]} + return [tcltest::tooManyArgs "::struct::graph::_$m" "name$xarg"] + } + + proc tmWrongA {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + if {[llength $m] > 1} {set m _[join $m _]} + incr n + return [tcltest::wrongNumArgs "::struct::graph::_$m" "name$xarg" $n] + } + + proc tmTooManyA {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + if {[llength $m] > 1} {set m _[join $m _]} + return [tcltest::tooManyArgs "::struct::graph::_$m" "name$xarg"] + } + + proc tmE {tcl critcl} {return $tcl} + } +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/Xsupport b/tcllib/modules/struct/graph/tests/Xsupport new file mode 100644 index 0000000..fe22b48 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/Xsupport @@ -0,0 +1,320 @@ +# -*- tcl -*- +# graph.testsupport: Helper commands for the testsuite. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# All rights reserved. +# +# RCS: @(#) $Id: Xsupport,v 1.4 2009/11/03 17:38:30 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +# Validate a serialization against the graph it was generated from. + +proc validate_serial {g serial {nodes {}}} { + # Need a list with length a multiple of 3, plus one. + + if {[llength $serial] % 3 != 1} { + return serial/wrong#elements + } + + set gattr [lindex $serial end] + if {[llength $gattr] % 2} { + return attr/graph/wrong#elements + } + if {![string equal \ + [dictsort $gattr] \ + [dictsort [$g getall]]]} { + return attr/graph/data-mismatch + } + + # Check node attrs and arcs information + array set an {} + array set ne {} + foreach {node attr arcs} [lrange $serial 0 end-1] { + # Must not list nodes outside of origin + if {![$g node exists $node]} { + return node/$node/unknown + } + # Node structure correct ? + if {[llength $attr] % 2} { + return node/$node/attr/wrong#elements + } + # Node attributes matching ? + if {![string equal \ + [dictsort $attr] \ + [dictsort [$g node getall $node]]]} { + return node/$node/attr/data-mismatch + } + # Remember nodes for reverse check. + set ne($node) . + + # Go through the attached arcs. + foreach a $arcs { + # Structure correct ? + if {([llength $a] != 3) && ([llength $a] != 4)} { + return node/$node/arc/wrong#elements + } + # Decode structure + foreach {arc dst aattr} $a break + # Already handled ? + if {[info exists an($arc)]} { + return arc/$arc/duplicate-definition + } + # Must not list arc outside of origin + if {![$g arc exists $arc]} { + return arc/$arc/unknown + } + # Attribute structure correct ? + if {[llength $aattr] % 2} { + return arc/$arc/attr/wrong#elements + } + # Attribute data correct ? + if {![string equal \ + [dictsort $aattr] \ + [dictsort [$g arc getall $arc]]]} { + return arc/$arc/attr/data-mismatch + } + # Arc information, node reference ok ? + if {![string is integer -strict $dst]} { + return arc/$arc/dst/not-an-integer + } + if {$dst < 0} { + return arc/$arc/dst/out-of-bounds + } + if {$dst >= [llength $serial]} { + return arc/$arc/dts/out-of-bounds + } + # Arc information matching origin ? + if {![string equal $node [$g arc source $arc]]} { + return arc/$arc/src/mismatch/$node/[$g arc source $arc] + } + if {![string equal [lindex $serial $dst] [$g arc target $arc]]} { + return arc/$arc/dst/mismatch/$node/[$g arc target $arc] + } + # Arc weight ok? + if {[llength $a] == 4} { + if {![$g arc hasweight $arc]} { + return arc/$arc/weight/mismatch/existence/defined-but-missing + } elseif {[lindex $a end] ne [$g arc getweight $arc]} { + return arc/$arc/weight/mismatch/value/[lindex $a end]/[$g arc getweight $arc]/ + } + } elseif {[$g arc hasweight $arc]} { + return arc/$arc/weight/mismatch/existence/undefined-but-notmissing + } + # Remember for check for multiples + set an($arc) . + } + } + + # Nodes ... All must exist in graph ... + # ... Spanning nodes have to be in serialization + + if {[llength $nodes] == 0} { + set nodes [lsort [$g nodes]] + } else { + set nodes [lsort $nodes] + } + + # Reverse check ... + if {[array size ne] != [llength $nodes]} { + return nodes/mismatch/#nodes + } + if {![string equal [lsort [array names ne]] $nodes]} { + return nodes/mismatch/data + } + + # Arcs ... All must exist in graph ... + # ... src / dst has to exist, has to match data in graph. + # ... All arcs between nodes in 'n' have to be in 'a' + + foreach k [$g arcs] { + set s [$g arc source $k] + set e [$g arc target $k] + if {[info exists ne($s)] && [info exists ne($e)] && ![info exists an($k)]} { + return arc/$k/missing/should-have-been-listed + } + } + + return ok +} + +#---------------------------------------------------------------------- + +proc SETUP {{g mygraph}} { + catch {$g destroy} + struct::graph $g +} + +#---------------------------------------------------------------------- + +proc SETUPx {} { + SETUP + + mygraph node insert %0 %1 %2 %3 %4 %5 + mygraph node set %0 volume 30 + mygraph node set %5 volume 50 + + mygraph arc insert %0 %1 0 ; mygraph arc set 0 volume 30 + mygraph arc insert %0 %2 1 + mygraph arc insert %0 %3 2 + mygraph arc insert %3 %4 3 + mygraph arc insert %4 %5 4 + mygraph arc insert %5 %3 5 ; mygraph arc set 5 volume 50 +} + +#---------------------------------------------------------------------- + +proc SETUPwalk {} { + SETUP + mygraph node insert i ii iii iv v vi vii viii ix + mygraph arc insert i ii 1 + mygraph arc insert ii iii 2 + mygraph arc insert ii iii 3 + mygraph arc insert ii iii 4 + mygraph arc insert iii iv 5 + mygraph arc insert iii iv 6 + mygraph arc insert iv v 7 + mygraph arc insert v vi 8 + mygraph arc insert vi viii 9 + mygraph arc insert viii i 10 + mygraph arc insert i ix 11 + mygraph arc insert ix ix 12 + mygraph arc insert i vii 13 + mygraph arc insert vii vi 14 +} + +#---------------------------------------------------------------------- +# Generators for various error messages generated +# by the implementations. + +proc MissingArc {g a} {return "arc \"$a\" does not exist in graph \"$g\""} +proc MissingNode {g n} {return "node \"$n\" does not exist in graph \"$g\""} + +proc ExistingArc {g a} {return "arc \"$a\" already exists in graph \"$g\""} +proc ExistingNode {g n} {return "node \"$n\" already exists in graph \"$g\""} + +proc MissingKey {e type k} {return "invalid key \"$k\" for $type \"$e\""} + +# Fake for graph attribute tests +proc MissingGraph {args} {return {Bogus missing}} + +#---------------------------------------------------------------------- + +# Helper commands for TSP problems. + +# 1. Generate canonical arc direction for a set of arcs, assuming that +# the arcs are specified as {nodeA nodeB}. Handles plain arc names +# as well, by ignoring them. Works only if plain arc names do not +# contain spaces. + +proc undirected {arcs} { + # arcs = list(arc), arc = list(source target) + set result {} + foreach a $arcs { + if {[llength $a] < 2} { + lappend result $a + } else { + lappend result [lsort $a] + } + } + return $result +} + +# 2. Canonical representations of TSP tours. +# 2a. For symmetrical graphs the tour weight is invariant under node +# rotation and reversal of direction. +# 2b. For asymmetrical graphs the tour weight is invariant under node +# rotation. +# +# 'toursort' generates a canonical representation for a tour per (2a). +# First node is smallest node in the tour, second node is the smallest +# of the two neighbours in the tour, of the first node. +# +# 'toursorta' generates a canonical representation for a tour per (2b). +# First node is smallest node in the tour. +# +# 'Smallest' isdefined through lexicographical comparison of node +# names (lsort -dict). + +proc toursort {nodes} { + # Remember: last(nodes) == first(nodes) + + # Empty or single-node tour => nothing to do. + if {[llength $nodes] <= 2} { + return $nodes + } + + # Two-node tour => Sort it. + if {[llength $nodes] == 2} { + return [list {*}[set first [lsort -dict [lrange $nodes 0 1]]] $first] + } + + # Three or more nodes requires more complex operations. + + set nodes [lrange $nodes 0 end-1] ; # Drop the duplicate + set min [lindex [lsort -dict $nodes] 0] + set pos [lsearch -exact $nodes $min] + + # Extended list with pre-fist/post-last nodes to avoid boundary + # computations when getting the neighbours of min. + + set e [list [lindex $nodes end] {*}$nodes [lindex $nodes 0]] + + # We have to correct pos (+1) for the extended list, inlining this + # into the neighbour extraction, we are looking for the nodes at + # locations (pos+1)-1 and (pos+1)+1, i.e. pos and pos+2. + + set pre [lindex $e $pos] + set post [lindex $e $pos+2] + + if {[lindex [lsort -dict [list $pre $post]] 0] eq $pre} { + # pre < post => The direction is wrong, reverse. + set nodes [lreverse $nodes] + set pos [lsearch -exact $nodes $min] + } + + # Now it is time to rotate the node last to bring min to the + # front, if it is not there already. + + if {$pos > 0} { + set nodes [list {*}[lrange $nodes ${pos} end] {*}[lrange $nodes 0 ${pos}-1]] + } + + # Re-add the duplicate. + lappend nodes [lindex $nodes 0] + return $nodes +} + +proc toursorta {nodes} { + # Remember: last(nodes) == first(nodes) + + # Empty or single-node tour => nothing to do. + if {[llength $nodes] <= 2} { + return $nodes + } + + # Two-node tour => Sort it. + if {[llength $nodes] == 2} { + return [list {*}[set first [lsort -dict [lrange $nodes 0 1]]] $first] + } + + # Three or more nodes requires more complex operations. + + set nodes [lrange $nodes 0 end-1] ; # Drop the duplicate + set pos [lsearch -exact $nodes [lindex [lsort -dict $nodes] 0]] + + # Now it is time to rotate the node last to bring min to the + # front, if it is not there already. + + if {$pos > 0} { + set nodes [list {*}[lrange $nodes ${pos} end] {*}[lrange $nodes 0 ${pos}-1]] + } + + # Re-add the duplicate. + lappend nodes [lindex $nodes 0] + return $nodes +} + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/attr.test b/tcllib/modules/struct/graph/tests/arc/attr.test new file mode 100644 index 0000000..013e243 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/attr.test @@ -0,0 +1,97 @@ +# -*- tcl -*- +# Graph tests - arc attr +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: attr.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc attr KEY ?-arcs ARCLIST|-glob PATTERN|-regexp PATTERN? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-attr-1.0 {arc attr, wrong#args, missing} { + SETUPx + catch {mygraph arc attr} msg + mygraph destroy + set msg +} [tmWrong {arc attr} {key ?-arcs list|-glob pattern|-regexp pattern?} 0 {key args}] + +test graph-${impl}-${setimpl}-arc-attr-1.1 {arc attr, wrong#args, missing} { + SETUPx + catch {mygraph arc attr a b} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" + +test graph-${impl}-${setimpl}-arc-attr-1.2 {arc attr, wrong#args, too many} { + SETUPx + catch {mygraph arc attr a b c d} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-attr-2.0 {arc attr, bogus switch} { + SETUPx + catch {mygraph arc attr a -foo barf} msg + mygraph destroy + set msg +} {bad type "-foo": must be -arcs, -glob, or -regexp} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-attr-3.0 {arc attr, unfiltered, nothing} { + SETUPx + set result [mygraph arc attr vol] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-arc-attr-3.1 {arc attr, unfiltered, something} { + SETUPx + set result [dictsort [mygraph arc attr volume]] + mygraph destroy + set result +} {0 30 5 50} + +test graph-${impl}-${setimpl}-arc-attr-3.2 {arc attr, filtered -arcs} { + SETUPx + set result [mygraph arc attr volume -arcs {0 3}] + mygraph destroy + set result +} {0 30} + +test graph-${impl}-${setimpl}-arc-attr-3.3 {arc attr, filtered -glob} { + SETUPx + set result [mygraph arc attr volume -glob {[0-3]}] + mygraph destroy + set result +} {0 30} + +test graph-${impl}-${setimpl}-arc-attr-3.4 {arc attr, filtered -regexp} { + SETUPx + set result [mygraph arc attr volume -regexp {[0-3]}] + mygraph destroy + set result +} {0 30} + +test graph-${impl}-${setimpl}-arc-attr-3.5 {arc attr, filtered -arcs nothing} { + SETUPx + set result [mygraph arc attr volume -arcs {}] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-arc-attr-3.6 {arc attr, nothing} { + SETUPx + mygraph arc unset 0 volume + mygraph arc unset 5 volume + set result [mygraph arc attr volume] + mygraph destroy + set result +} {} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/delete.test b/tcllib/modules/struct/graph/tests/arc/delete.test new file mode 100644 index 0000000..41dc5b2 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/delete.test @@ -0,0 +1,94 @@ +# -*- tcl -*- +# Graph tests - arc deletion +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: delete.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc delete ARC ARC... + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-delete-1.0 {arc delete, wrong#args, missing} { + SETUP + catch {mygraph arc delete} msg + mygraph destroy + set msg +} [tmE {wrong # args: should be "::struct::graph::__arc_delete name arc arc..."} \ + {wrong # args: should be "mygraph arc delete arc arc..."}] + +# Cannot use tmWrong, will be incorrect for the Tcl implementation +# run by a pre-8.4 core. +# [tmWrong {arc delete} {arc arc...} 0] + +# Impossible to have too many arguments +# Any number of arcs is acceptable. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-delete-2.0 {arc delete, missing arc} { + SETUP + catch {mygraph arc delete arc0} msg + mygraph destroy + set msg +} [MissingArc $MY arc0] + +# ------------------------------------------------------------------------- +# Ok arguments, single, multiple deletion. + +test graph-${impl}-${setimpl}-arc-delete-3.0 {arc delete} { + SETUP + + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + + set res {} + lappend res [mygraph arc exists arc0] + lappend res [mygraph arc delete arc0] + lappend res [mygraph arc exists arc0] + + mygraph destroy + set res +} {1 {} 0} + +test graph-${impl}-${setimpl}-arc-delete-3.1 {arc delete, multiple at once} { + SETUP + + mygraph node insert node0 node1 node2 node3 + mygraph arc insert node0 node1 arc0 + mygraph arc insert node0 node1 arc1 + mygraph arc insert node2 node3 arc2 + mygraph arc insert node1 node3 arc3 + + set res {} + lappend res [mygraph arc exists arc0] + lappend res [mygraph arc exists arc1] + lappend res [mygraph arc exists arc2] + lappend res [mygraph arc exists arc3] + lappend res [mygraph arc delete arc0 arc1 arc2 arc3] + lappend res [mygraph arc exists arc0] + lappend res [mygraph arc exists arc1] + lappend res [mygraph arc exists arc2] + lappend res [mygraph arc exists arc3] + + mygraph destroy + set res +} {1 1 1 1 {} 0 0 0 0} + +test graph-${impl}-${setimpl}-arc-delete-3.2 {arc delete, keeping adjacent nodes} { + SETUP + + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + + set res {} + lappend res [mygraph arc delete arc0] + lappend res [mygraph node exists node0] + lappend res [mygraph node exists node1] + + mygraph destroy + set res +} {{} 1 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/exists.test b/tcllib/modules/struct/graph/tests/arc/exists.test new file mode 100644 index 0000000..9865063 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/exists.test @@ -0,0 +1,47 @@ +# -*- tcl -*- +# Graph tests - arc existence +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: exists.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc exists ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-exists-1.0 {arc exists, wrong#args, missing} { + SETUP + catch {mygraph arc exists} msg + mygraph destroy + set msg +} [tmWrong {arc exists} arc 0] + +test graph-${impl}-${setimpl}-arc-exists-1.1 {arc exists, wrong#args, too many} { + SETUP + catch {mygraph arc exists 0 1} msg + mygraph destroy + set msg +} [tmTooMany {arc exists} arc] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-exists-2.0 {arc exists} { + SETUP + set res {} + lappend res [mygraph arc exists arc1] + + mygraph node insert node1 node2 + mygraph arc insert node1 node2 arc1 + + lappend res [mygraph arc exists arc1] + + mygraph arc delete arc1 + + lappend res [mygraph arc exists arc1] + + mygraph destroy + set res +} {0 1 0} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/flip.test b/tcllib/modules/struct/graph/tests/arc/flip.test new file mode 100644 index 0000000..4fdd5d6 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/flip.test @@ -0,0 +1,59 @@ +# -*- tcl -*- +# Graph tests - arc flip +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: flip.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc flip ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-flip-1.0 {arc flip, wrong#args, missing} { + SETUP + catch {mygraph arc flip} res + mygraph destroy + set res +} [tmWrong {arc flip} arc 0] + +test graph-${impl}-${setimpl}-arc-flip-1.1 {arc flip, wrong#args, too many} { + SETUP + catch {mygraph arc flip a b} res + mygraph destroy + set res +} [tmTooMany {arc flip} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-flip-2.0 {arc flip, missing arc} { + SETUP + catch {mygraph arc flip a} res + mygraph destroy + set res +} [MissingArc $MY a] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-flip-3.0 {arc flip, regular arc} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + mygraph arc flip a + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {1 0} + +test graph-${impl}-${setimpl}-arc-flip-3.1 {arc flip, loop} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc flip a + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {0 0} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/getunweighted.test b/tcllib/modules/struct/graph/tests/arc/getunweighted.test new file mode 100644 index 0000000..2b94904 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/getunweighted.test @@ -0,0 +1,74 @@ +# -*- tcl -*- +# Graph tests - arc getunweighted +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: getunweighted.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc getunweighted + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-getunweighted-1.0 {arc getunweighted, wrong#args, too many} { + SETUP + catch {mygraph arc getunweighted a} res + mygraph destroy + set res +} [tmTooMany {arc getunweighted} {}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-getunweighted-3.0 {arc getunweighted, no arcs} { + SETUP + set res [mygraph arc getunweighted] + mygraph destroy + set res +} {} + +test graph-${impl}-${setimpl}-arc-getunweighted-3.1 {arc getunweighted, all arcs, one} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + set res [mygraph arc getunweighted] + mygraph destroy + set res +} {a} + +test graph-${impl}-${setimpl}-arc-getunweighted-3.2 {arc getunweighted, all arcs, more} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph node insert 1 + mygraph arc insert 1 0 b + set res [lsort -dict [mygraph arc getunweighted]] + mygraph destroy + set res +} {a b} + +test graph-${impl}-${setimpl}-arc-getunweighted-3.3 {arc getunweighted, none} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 1 + set res [mygraph arc getunweighted] + mygraph destroy + set res +} {} + +test graph-${impl}-${setimpl}-arc-getunweighted-3.4 {arc getunweighted, some} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph node insert 1 + mygraph arc insert 1 0 b + mygraph arc setweight a 1 + set res [mygraph arc getunweighted] + mygraph destroy + set res +} b + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/getweight.test b/tcllib/modules/struct/graph/tests/arc/getweight.test new file mode 100644 index 0000000..b1f9176 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/getweight.test @@ -0,0 +1,58 @@ +# -*- tcl -*- +# Graph tests - arc getweight +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: getweight.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc getweight + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-getweight-1.0 {arc getweight, wrong#args, missing} { + SETUP + catch {mygraph arc getweight} res + mygraph destroy + set res +} [tmWrong {arc getweight} arc 0] + +test graph-${impl}-${setimpl}-arc-getweight-1.1 {arc getweight, wrong#args, too many} { + SETUP + catch {mygraph arc getweight a b} res + mygraph destroy + set res +} [tmTooMany {arc getweight} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-getweight-2.0 {arc getweight, missing arc} { + SETUP + catch {mygraph arc getweight a} res + mygraph destroy + set res +} [MissingArc $MY a] + +test graph-${impl}-${setimpl}-arc-getweight-2.1 {arc getweight, arc missing weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + catch {mygraph arc getweight a} res + mygraph destroy + set res +} {arc "a" has no weight} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-getweight-3.0 {arc getweight, arc has weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 1 + set res [mygraph arc getweight a] + mygraph destroy + set res +} 1 + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/hasweight.test b/tcllib/modules/struct/graph/tests/arc/hasweight.test new file mode 100644 index 0000000..a2ff523 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/hasweight.test @@ -0,0 +1,58 @@ +# -*- tcl -*- +# Graph tests - arc hasweight +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: hasweight.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc hasweight + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-hasweight-1.0 {arc hasweight, wrong#args, missing} { + SETUP + catch {mygraph arc hasweight} res + mygraph destroy + set res +} [tmWrong {arc hasweight} arc 0] + +test graph-${impl}-${setimpl}-arc-hasweight-1.1 {arc hasweight, wrong#args, too many} { + SETUP + catch {mygraph arc hasweight a b} res + mygraph destroy + set res +} [tmTooMany {arc hasweight} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-hasweight-2.0 {arc hasweight, missing arc} { + SETUP + catch {mygraph arc hasweight a} res + mygraph destroy + set res +} [MissingArc $MY a] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-hasweight-3.0 {arc hasweight, arc missing weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + set res [mygraph arc hasweight a] + mygraph destroy + set res +} 0 + +test graph-${impl}-${setimpl}-arc-hasweight-3.` {arc hasweight, arc has weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 1 + set res [mygraph arc hasweight a] + mygraph destroy + set res +} 1 + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/insert.test b/tcllib/modules/struct/graph/tests/arc/insert.test new file mode 100644 index 0000000..b3c5efa --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/insert.test @@ -0,0 +1,113 @@ +# -*- tcl -*- +# Graph tests - arc insertion +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: insert.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc insert START END ?ARC? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-insert-1.0 {arc insert, wrong#args, missing} { + SETUP + catch {mygraph arc insert} msg + mygraph destroy + set msg +} [tmWrong {arc insert} {source target ?arc?} 0 {source target args}] + +test graph-${impl}-${setimpl}-arc-insert-1.1 {arc insert, wrong#args, missing} { + SETUP + catch {mygraph arc insert 0} msg + mygraph destroy + set msg +} [tmWrong {arc insert} {source target ?arc?} 1 {source target args}] + +test graph-${impl}-${setimpl}-arc-insert-1.2 {arc insert, wrong#args, too many} { + SETUP + catch {mygraph arc insert 0 1 2 3} msg + mygraph destroy + set msg +} [tmE {wrong # args: should be "::struct::graph::__arc_insert name source target ?arc?"} \ + {wrong # args: should be "mygraph arc insert source target ?arc?"}] + +# Cannot use tmTooMany, will be incorrect for the Tcl implementation +# run by a pre-8.4 core. +# [tmTooMany {arc insert} {source target ?arc?}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-insert-2.0 {arc insert, missing start} { + SETUP + mygraph node insert node1 + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} "source [MissingNode $MY node0]" + +test graph-${impl}-${setimpl}-arc-insert-2.1 {arc insert, missing end} { + SETUP + mygraph node insert node0 + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} "target [MissingNode $MY node1]" + +test graph-${impl}-${setimpl}-arc-insert-2.2 {arc insert, existing arc} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} [ExistingArc $MY arc0] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-insert-3.0 {arc insert, node/arc linkage} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + + set result {} + lappend result [mygraph arc exists arc0] + lappend result [mygraph arc source arc0] + lappend result [mygraph arc target arc0] + lappend result [mygraph arcs -out node0] + lappend result [mygraph arcs -in node1] + + mygraph destroy + set result +} {1 node0 node1 arc0 arc0} + +test graph-${impl}-${setimpl}-arc-insert-3.1 {arc insert, attribute defaults} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + + set result [mygraph arc getall arc0] + + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-arc-insert-3.2 {arc insert, auto-generated name} { + SETUP + mygraph node insert n0 + + # Note: The use of 'arc3' for the explicit name tests that the + # name-generator will skip over existing names when it tries to + # come up with a new one. + + set result {} + lappend result [mygraph arc insert n0 n0] + lappend result [mygraph arc insert n0 n0] + mygraph arc insert n0 n0 arc3 + lappend result [mygraph arc insert n0 n0] + mygraph destroy + set result +} {arc1 arc2 arc4} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/move-source.test b/tcllib/modules/struct/graph/tests/arc/move-source.test new file mode 100644 index 0000000..971188b --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/move-source.test @@ -0,0 +1,76 @@ +# -*- tcl -*- +# Graph tests - arc move-source +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: move-source.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc move-source ARC NEW-SOURCE + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-move-source-1.0 {arc move-source, wrong#args, missing} { + SETUP + catch {mygraph arc move-source} res + mygraph destroy + set res +} [tmWrong {arc move-source} {arc newsource} 0] + +test graph-${impl}-${setimpl}-arc-move-source-1.1 {arc move-source, wrong#args, missing} { + SETUP + catch {mygraph arc move-source a} res + mygraph destroy + set res +} [tmWrong {arc move-source} {arc newsource} 1] + +test graph-${impl}-${setimpl}-arc-move-source-1.2 {arc move-source, wrong#args, too many} { + SETUP + catch {mygraph arc move-source a b c} res + mygraph destroy + set res +} [tmTooMany {arc move-source} {arc newsource}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-move-source-1.3 {arc move-source, missing arc} { + SETUP + mygraph node insert 0 + catch {mygraph arc move-source a 0} res + mygraph destroy + set res +} [MissingArc $MY a] + +test graph-${impl}-${setimpl}-arc-move-source-1.4 {arc move-source, missing node} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + catch {mygraph arc move-source a 2} res + mygraph destroy + set res +} [MissingNode $MY 2] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-move-source-1.5 {arc move-source, changed source} { + SETUP + mygraph node insert 0 1 2 + mygraph arc insert 0 1 a + mygraph arc move-source a 2 + set res [mygraph arc source a] + mygraph destroy + set res +} 2 + +test graph-${impl}-${setimpl}-arc-move-source-1.6 {arc move-source, unchanged source} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + mygraph arc move-source a 0 + set res [mygraph arc source a] + mygraph destroy + set res +} 0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/move-target.test b/tcllib/modules/struct/graph/tests/arc/move-target.test new file mode 100644 index 0000000..be0a5e3 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/move-target.test @@ -0,0 +1,76 @@ +# -*- tcl -*- +# Graph tests - arc move-target +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: move-target.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc move-target ARC NEW-TARGET + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-move-target-1.0 {arc move-target, wrong#args, missing} { + SETUP + catch {mygraph arc move-target} res + mygraph destroy + set res +} [tmWrong {arc move-target} {arc newtarget} 0] + +test graph-${impl}-${setimpl}-arc-move-target-1.1 {arc move-target, wrong#args, missing} { + SETUP + catch {mygraph arc move-target a} res + mygraph destroy + set res +} [tmWrong {arc move-target} {arc newtarget} 1] + +test graph-${impl}-${setimpl}-arc-move-target-1.2 {arc move-target, wrong#args, too many} { + SETUP + catch {mygraph arc move-target a b c} res + mygraph destroy + set res +} [tmTooMany {arc move-target} {arc newtarget}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-move-target-1.3 {arc move-target, missing arc} { + SETUP + mygraph node insert 0 + catch {mygraph arc move-target a 0} res + mygraph destroy + set res +} [MissingArc $MY a] + +test graph-${impl}-${setimpl}-arc-move-target-1.4 {arc move-target, missing node} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + catch {mygraph arc move-target a 2} res + mygraph destroy + set res +} [MissingNode $MY 2] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-move-target-1.5 {arc move-target, changed target} { + SETUP + mygraph node insert 0 1 2 + mygraph arc insert 0 1 a + mygraph arc move-target a 2 + set res [mygraph arc target a] + mygraph destroy + set res +} 2 + +test graph-${impl}-${setimpl}-arc-move-target-1.6 {arc move-target, unchanged target} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + mygraph arc move-target a 0 + set res [mygraph arc target a] + mygraph destroy + set res +} 0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/move.test b/tcllib/modules/struct/graph/tests/arc/move.test new file mode 100644 index 0000000..4275888 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/move.test @@ -0,0 +1,111 @@ +# -*- tcl -*- +# Graph tests - arc move +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: move.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc move ARC NEW-SOURCE NEW-TARGET + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-move-1.0 {arc move, wrong#args, missing} { + SETUP + catch {mygraph arc move} res + mygraph destroy + set res +} [tmWrong {arc move} {arc newsource newtarget} 0] + +test graph-${impl}-${setimpl}-arc-move-1.1 {arc move} { + SETUP + catch {mygraph arc move a} res + mygraph destroy + set res +} [tmWrong {arc move} {arc newsource newtarget} 1] + +test graph-${impl}-${setimpl}-arc-move-1.2 {arc move} { + SETUP + catch {mygraph arc move a b} res + mygraph destroy + set res +} [tmWrong {arc move} {arc newsource newtarget} 2] + +test graph-${impl}-${setimpl}-arc-move-1.3 {arc move} { + SETUP + catch {mygraph arc move a b c d} res + mygraph destroy + set res +} [tmTooMany {arc move} {arc newsource newtarget}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-move-2.0 {arc move} { + SETUP + mygraph node insert 0 1 + catch {mygraph arc move a 0 1} res + mygraph destroy + set res +} [MissingArc $MY a] + +test graph-${impl}-${setimpl}-arc-move-2.1 {arc move} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + catch {mygraph arc move a 0 2} res + mygraph destroy + set res +} [MissingNode $MY 2] + +test graph-${impl}-${setimpl}-arc-move-2.2 {arc move} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + catch {mygraph arc move a 2 0} res + mygraph destroy + set res +} [MissingNode $MY 2] + +# ------------------------------------------------------------------------- + +test graph-${impl}-${setimpl}-arc-move-3.0 {arc move, new source & target} { + SETUP + mygraph node insert 0 1 2 3 + mygraph arc insert 0 1 a + mygraph arc move a 2 3 + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {2 3} + +test graph-${impl}-${setimpl}-arc-move-3.1 {arc move, unchanged source, target} { + SETUP + mygraph node insert 0 1 2 3 + mygraph arc insert 0 1 a + mygraph arc move a 0 1 + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {0 1} + +test graph-${impl}-${setimpl}-arc-move-3.2 {arc move, unchanged source, changed target} { + SETUP + mygraph node insert 0 1 2 3 + mygraph arc insert 0 1 a + mygraph arc move a 0 3 + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {0 3} + +test graph-${impl}-${setimpl}-arc-move-3.3 {arc move, changed source, unchanged target} { + SETUP + mygraph node insert 0 1 2 3 + mygraph arc insert 0 1 a + mygraph arc move a 2 1 + set res [list [mygraph arc source a] [mygraph arc target a]] + mygraph destroy + set res +} {2 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/nodes.test b/tcllib/modules/struct/graph/tests/arc/nodes.test new file mode 100644 index 0000000..d5383b7 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/nodes.test @@ -0,0 +1,48 @@ +# -*- tcl -*- +# Graph tests - arc nodes +# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: nodes.test,v 1.1 2009/09/24 16:23:47 andreas_kupries Exp $ + +# Syntax: graph arc nodes ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-nodes-1.0 {arc nodes, wrong#arcs, missing} { + SETUP + catch {mygraph arc nodes} msg + mygraph destroy + set msg +} [tmWrong {arc nodes} arc 0] + +test graph-${impl}-${setimpl}-arc-nodes-1.1 {arc nodes, wrong#arcs, too many} { + SETUP + catch {mygraph arc nodes a b} msg + mygraph destroy + set msg +} [tmTooMany {arc nodes} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-nodes-2.0 {arc nodes, missing arc} { + SETUP + catch {mygraph arc nodes arc0} msg + mygraph destroy + set msg +} [MissingArc $MY arc0] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-nodes-3.0 {arc nodes} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc nodes arc0] + mygraph destroy + set result +} {node0 node1} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/rename.test b/tcllib/modules/struct/graph/tests/arc/rename.test new file mode 100644 index 0000000..250dc7a --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/rename.test @@ -0,0 +1,104 @@ +# -*- tcl -*- +# Graph tests - arc rename +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: rename.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc rename ARC NEWNAME + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-rename-1.0 {arc rename, wrong # args, missing} { + SETUP + catch {mygraph arc rename} result + mygraph destroy + set result +} [tmWrong {arc rename} {arc newname} 0] + +test graph-${impl}-${setimpl}-arc-rename-1.1 {arc rename, wrong # args, missing} { + SETUP + catch {mygraph arc rename foo} result + mygraph destroy + set result +} [tmWrong {arc rename} {arc newname} 1] + +test graph-${impl}-${setimpl}-arc-rename-1.2 {arc rename, wrong # args, too many} { + SETUP + catch {mygraph arc rename foo far fox} result + mygraph destroy + set result +} [tmTooMany {arc rename} {arc newname}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-rename-2.0 {arc rename, missing arc} { + SETUP + catch {mygraph arc rename 0 foo} result + mygraph destroy + set result +} [MissingArc $MY 0] + +test graph-${impl}-${setimpl}-arc-rename-2.1 {arc rename, duplicate arc for target} { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a + mygraph arc insert 0 1 b + + catch {mygraph arc rename a b} result + mygraph destroy + set result +} [ExistingArc $MY b] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-rename-3.0 {arc rename, node linkage} { + SETUP + + mygraph node insert a b + mygraph arc insert a b 0 + + set result {} + lappend result [mygraph arc source 0] + lappend result [mygraph arc target 0] + lappend result [mygraph arc exists 0] + lappend result [mygraph arc exists snarf] + lappend result [mygraph arcs -in b] + lappend result [mygraph arcs -out a] + + mygraph arc rename 0 snarf + lappend result | + + lappend result [mygraph arc source snarf] + lappend result [mygraph arc target snarf] + lappend result [mygraph arc exists 0] + lappend result [mygraph arc exists snarf] + lappend result [mygraph arcs -in b] + lappend result [mygraph arcs -out a] + + mygraph destroy + set result +} {a b 1 0 0 0 | a b 0 1 snarf snarf} + +test graph-${impl}-${setimpl}-arc-rename-3.1 {arc rename, attribute transfer} { + SETUP + mygraph node insert a b + mygraph arc insert a b 0 + mygraph arc set 0 data foo + + set result {} + lappend result [mygraph arc getall 0] + lappend result [catch {mygraph arc getall 5}] + + mygraph arc rename 0 5 + + lappend result [mygraph arc getall 5] + lappend result [catch {mygraph arc getall 0}] + + mygraph destroy + set result +} {{data foo} 1 {data foo} 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/setunweighted.test b/tcllib/modules/struct/graph/tests/arc/setunweighted.test new file mode 100644 index 0000000..d70cbe1 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/setunweighted.test @@ -0,0 +1,64 @@ +# -*- tcl -*- +# Graph tests - arc setunweighted +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: setunweighted.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc setunweighted + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-setunweighted-1.0 {arc setunweighted, wrong#args, too many} { + SETUP + catch {mygraph arc setunweighted a b} res + mygraph destroy + set res +} [tmTooMany {arc setunweighted} {?weight?}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-setunweighted-3.0 {arc setunweighted, no arcs to set} { + SETUP + mygraph arc setunweighted + set res [mygraph arc weights] + mygraph destroy + set res +} {} + +test graph-${impl}-${setimpl}-arc-setunweighted-3.1 {arc setunweighted, arc, no arcs to set} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 3 + mygraph arc setunweighted + set res [mygraph arc weights] + mygraph destroy + set res +} {a 3} + +test graph-${impl}-${setimpl}-arc-setunweighted-3.2 {arc setunweighted, arc, set default} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setunweighted + set res [mygraph arc weights] + mygraph destroy + set res +} {a 0} + +test graph-${impl}-${setimpl}-arc-setunweighted-3.3 {arc setunweighted, arc, set weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setunweighted 4 + set res [mygraph arc weights] + mygraph destroy + set res +} {a 4} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/setweight.test b/tcllib/modules/struct/graph/tests/arc/setweight.test new file mode 100644 index 0000000..75cea95 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/setweight.test @@ -0,0 +1,71 @@ +# -*- tcl -*- +# Graph tests - arc setweight +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: setweight.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc setweight + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-setweight-1.0 {arc setweight, wrong#args, missing} { + SETUP + catch {mygraph arc setweight} res + mygraph destroy + set res +} [tmWrong {arc setweight} {arc weight} 0] + +test graph-${impl}-${setimpl}-arc-setweight-1.1 {arc setweight, wrong#args, missing} { + SETUP + catch {mygraph arc setweight a} res + mygraph destroy + set res +} [tmWrong {arc setweight} {arc weight} 0] + +test graph-${impl}-${setimpl}-arc-setweight-1.2 {arc setweight, wrong#args, too many} { + SETUP + catch {mygraph arc setweight a b c} res + mygraph destroy + set res +} [tmTooMany {arc setweight} {arc weight}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-setweight-2.0 {arc setweight, missing arc} { + SETUP + catch {mygraph arc setweight a 1} res + mygraph destroy + set res +} [MissingArc $MY a] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-setweight-3.0 {arc setweight, arc, set new weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + set res [mygraph arc hasweight a] + mygraph arc setweight a 2 + lappend res [mygraph arc hasweight a] + lappend res [mygraph arc getweight a] + mygraph destroy + set res +} {0 1 2} + +test graph-${impl}-${setimpl}-arc-setweight-3.1 {arc setweight, arc, replace existing weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 2 + set res [mygraph arc hasweight a] + mygraph arc setweight a 3 + lappend res [mygraph arc hasweight a] + lappend res [mygraph arc getweight a] + mygraph destroy + set res +} {1 1 3} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/source.test b/tcllib/modules/struct/graph/tests/arc/source.test new file mode 100644 index 0000000..b7f99f6 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/source.test @@ -0,0 +1,48 @@ +# -*- tcl -*- +# Graph tests - arc source +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: source.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc source ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-source-1.0 {arc source, wrong#arcs, missing} { + SETUP + catch {mygraph arc source} msg + mygraph destroy + set msg +} [tmWrong {arc source} arc 0] + +test graph-${impl}-${setimpl}-arc-source-1.1 {arc source, wrong#arcs, too many} { + SETUP + catch {mygraph arc source a b} msg + mygraph destroy + set msg +} [tmTooMany {arc source} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-source-2.0 {arc source, missing arc} { + SETUP + catch {mygraph arc source arc0} msg + mygraph destroy + set msg +} [MissingArc $MY arc0] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-source-3.0 {arc source} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc source arc0] + mygraph destroy + set result +} node0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/target.test b/tcllib/modules/struct/graph/tests/arc/target.test new file mode 100644 index 0000000..5f74009 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/target.test @@ -0,0 +1,48 @@ +# -*- tcl -*- +# Graph tests - arc target +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: target.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph arc target ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-target-1.0 {arc target, wrong#arcs, missing} { + SETUP + catch {mygraph arc target} msg + mygraph destroy + set msg +} [tmWrong {arc target} arc 0] + +test graph-${impl}-${setimpl}-arc-target-1.1 {arc target, wrong#arcs, too many} { + SETUP + catch {mygraph arc target a b} msg + mygraph destroy + set msg +} [tmTooMany {arc target} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-target-2.0 {arc target, missing arc} { + SETUP + catch {mygraph arc target arc0} msg + mygraph destroy + set msg +} [MissingArc $MY arc0] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-target-3.0 {arc target} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc target arc0] + mygraph destroy + set result +} node1 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/unsetweight.test b/tcllib/modules/struct/graph/tests/arc/unsetweight.test new file mode 100644 index 0000000..8144212 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/unsetweight.test @@ -0,0 +1,62 @@ +# -*- tcl -*- +# Graph tests - arc unsetweight +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: unsetweight.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc unsetweight + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-unsetweight-1.0 {arc unsetweight, wrong#args, missing} { + SETUP + catch {mygraph arc unsetweight} res + mygraph destroy + set res +} [tmWrong {arc unsetweight} arc 0] + +test graph-${impl}-${setimpl}-arc-unsetweight-1.1 {arc unsetweight, wrong#args, too many} { + SETUP + catch {mygraph arc unsetweight a b} res + mygraph destroy + set res +} [tmTooMany {arc unsetweight} arc] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arc-unsetweight-2.0 {arc unsetweight, missing arc} { + SETUP + catch {mygraph arc unsetweight a} res + mygraph destroy + set res +} [MissingArc $MY a] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-unsetweight-3.0 {arc unsetweight, arc missing weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + set res [mygraph arc hasweight a] + mygraph arc unsetweight a + lappend res [mygraph arc hasweight a] + mygraph destroy + set res +} {0 0} + +test graph-${impl}-${setimpl}-arc-unsetweight-3.1 {arc unsetweight, arc missing weight} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 1 + set res [mygraph arc hasweight a] + mygraph arc unsetweight a + lappend res [mygraph arc hasweight a] + mygraph destroy + set res +} {1 0} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arc/weights.test b/tcllib/modules/struct/graph/tests/arc/weights.test new file mode 100644 index 0000000..430a745 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arc/weights.test @@ -0,0 +1,76 @@ +# -*- tcl -*- +# Graph tests - arc weights +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: weights.test,v 1.1 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph arc weights + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arc-weights-1.0 {arc weights, wrong#args, too many} { + SETUP + catch {mygraph arc weights a} res + mygraph destroy + set res +} [tmTooMany {arc weights} {}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arc-weights-3.0 {arc weights, no arcs} { + SETUP + set res [mygraph arc weights] + mygraph destroy + set res +} {} + +test graph-${impl}-${setimpl}-arc-weights-3.1 {arc weights, all arcs, one} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph arc setweight a 1 + set res [mygraph arc weights] + mygraph destroy + set res +} {a 1} + +test graph-${impl}-${setimpl}-arc-weights-3.2 {arc weights, all arcs, more} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph node insert 1 + mygraph arc insert 1 0 b + mygraph arc setweight a 2 + mygraph arc setweight b 1 + set res [dictsort [mygraph arc weights]] + mygraph destroy + set res +} {a 2 b 1} + +test graph-${impl}-${setimpl}-arc-weights-3.3 {arc weights, none} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + set res [mygraph arc weights] + mygraph destroy + set res +} {} + +test graph-${impl}-${setimpl}-arc-weights-3.4 {arc weights, some} { + SETUP + mygraph node insert 0 + mygraph arc insert 0 0 a + mygraph node insert 1 + mygraph arc insert 1 0 b + mygraph arc setweight a 1 + set res [mygraph arc weights] + mygraph destroy + set res +} {a 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/arcs.test b/tcllib/modules/struct/graph/tests/arcs.test new file mode 100644 index 0000000..9785a3f --- /dev/null +++ b/tcllib/modules/struct/graph/tests/arcs.test @@ -0,0 +1,326 @@ +# -*- tcl -*- +# Graph tests - arcs +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: arcs.test,v 1.4 2009/11/03 17:38:30 andreas_kupries Exp $ + +# Syntax: graph arcs +# (1) graph arcs -key KEY +# graph arcs -key KEY -value VALUE +# (2) graph arcs -filter CMDPREFIX +# (3) graph arcs -in NODE... +# graph arcs -out NODE... +# graph arcs -adj NODE... +# graph arcs -inner NODE... +# graph arcs -embedded NODE... + +# We can use one in each group (1,2,3) + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +# Cannot have missing arguments (zero is fine), +# except when switches are in use. That however +# is tested with the switches. Ditto for too many +# arguments. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arcs-1.0 {arcs, bad switch} { + SETUP + catch {mygraph arcs -foo} msg + mygraph destroy + set msg +} {bad restriction "-foo": must be -adj, -embedding, -filter, -in, -inner, -key, -out, or -value} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arcs-2.0 {arcs, empty graph} { + SETUP + set result [mygraph arcs] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-arcs-2.1 {arcs, nodes without arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [mygraph arcs] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-arcs-2.2 {arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + mygraph arc insert 0 1 a + mygraph arc insert 2 3 b + mygraph arc insert 4 5 c + set result [lsort [mygraph arcs]] + mygraph destroy + set result +} {a b c} + +# --------------------------------------------------- + +# (1) -key, -value +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arcs-key-1.0 {arcs, wrong#args, missing} { + SETUP + catch {mygraph arcs -key} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY arcs ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +test graph-${impl}-${setimpl}-arcs-key-1.1 {arcs, wrong#args, missing} { + SETUP + catch {mygraph arcs -value} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY arcs ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arcs-key-2.0 {arcs, multiple -key} { + SETUP + catch {mygraph arcs -key foobar -value 1 -key foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-key"} + +test graph-${impl}-${setimpl}-arcs-key-2.1 {arcs, multiple -value} { + SETUP + catch {mygraph arcs -key foobar -value 1 -value foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-value"} + +test graph-${impl}-${setimpl}-arcs-key-2.2 {arcs, -value without -key} { + SETUP + catch {mygraph arcs -value 1} msg + mygraph destroy + set msg +} {invalid restriction: use of "-value" without "-key"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arcs-key-3.0 {arcs, -key} { + SETUP + mygraph node insert n0 n1 + mygraph arc insert n0 n1 a1 + mygraph arc insert n0 n1 a2 + mygraph arc set a1 foobar 1 + mygraph arc set a2 blubber 2 + + catch {mygraph arcs -key foobar} msg + mygraph destroy + set msg +} a1 + +test graph-${impl}-${setimpl}-arcs-key-3.1 {arcs, -key, -value} { + SETUP + mygraph node insert n0 n1 + mygraph arc insert n0 n1 a1 + mygraph arc insert n0 n1 a2 + mygraph arc set a1 foobar 1 + mygraph arc set a2 foobar 2 + + catch {mygraph arcs -key foobar -value 1} msg + mygraph destroy + set msg +} a1 + +# --------------------------------------------------- + +# (2) -filter +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-arcs-filter-1.0 {arcs, wrong#args, missing} { + SETUP + catch {mygraph arcs -filter} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY arcs ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-arcs-filter-2.0 {arcs, multiple -filter} { + SETUP + catch {mygraph arcs -filter foobar -filter foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-filter"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-arcs-filter-3.0 {arcs, -filter} { + SETUP + + mygraph node insert 1 2 3 4 5 6 + + mygraph arc insert 4 1 A + mygraph arc insert 5 2 B + mygraph arc insert 6 3 C + mygraph arc insert 3 1 D + mygraph arc insert 1 2 E + mygraph arc insert 2 3 F + + mygraph arc set A volume 30 + mygraph arc set C volume 50 + + proc vol {g n} { + $g arc keyexists $n volume + } + + set result [lsort [mygraph arcs -filter vol]] + mygraph destroy + rename vol {} + + set result +} {A C} + +test graph-${impl}-${setimpl}-arcs-filter-3.1 {arcs, -filter} { + SETUP + + mygraph node insert 1 2 3 4 5 6 + + mygraph arc insert 4 1 A + mygraph arc insert 5 2 B + mygraph arc insert 6 3 C + mygraph arc insert 3 1 D + mygraph arc insert 1 2 E + mygraph arc insert 2 3 F + + mygraph arc set A volume 30 + mygraph arc set C volume 50 + + proc vol {g n} { + if {![$g arc keyexists $n volume]} {return 0} + expr {[$g arc get $n volume] > 40} + } + + set result [mygraph arcs -filter vol] + mygraph destroy + rename vol {} + + set result +} C + +# --------------------------------------------------- + +# (3) -in, -out, -adj, -inner, -embedding +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +set n 0 +foreach switch {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-arcs-ioaie-1.$n "arcs, $switch, wrong#args, missing" { + SETUP + catch {mygraph arcs $switch} msg + mygraph destroy + set msg + } "wrong # args: should be \"$MY arcs ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" ; # {} + + incr n +} + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +set n 0 +foreach switch {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-arcs-ioaie-2.$n "arcs, $switch, missing node" { + SETUP + catch {mygraph arcs $switch x} msg + mygraph destroy + set msg + } [MissingNode $MY x] ; # {} + + incr n + + foreach switchB {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-arcs-ioaie-2.$n "arcs, $switch, $switchB together" { + SETUP + catch {mygraph arcs $switch $switchB x} msg + mygraph destroy + set msg + } {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} ; # {} + + incr n + } +} + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {switch nodes expected} { + -in {1 2 3} {A B C D E F} -in {4 5 6} {} + -out {1 2 3} {D E F} -out {4 5 6} {A B C} + -adj {1 2 3} {A B C D E F} -adj {4 5 6} {A B C} + -inner {1 2 3} {D E F} -inner {4 5 6} {} + -embedding {1 2 3} {A B C} -embedding {4 5 6} {A B C} + -in {1 2} {A B D E} -in {4 5} {} + -out {1 2} {E F} -out {4 5} {A B} + -adj {1 2} {A B D E F} -adj {4 5} {A B} + -inner {1 2} {E} -inner {4 5} {} + -embedding {1 2} {A B D F} -embedding {4 5} {A B} + -in {1} {A D} -in {4} {} + -out {1} {E} -out {4} {A} + -adj {1} {A D E} -adj {4} {A} + -inner {1} {} -inner {4} {} + -embedding {1} {A D E} -embedding {4} {A} + -in {1 4} {A D} -in {4 2} {B E} + -out {1 4} {A E} -out {4 2} {A F} + -adj {1 4} {A D E} -adj {4 2} {A B E F} + -inner {1 4} {A} -inner {4 2} {} + -embedding {1 4} {D E} -embedding {4 2} {A B E F} + -in {1 1} {A D} -in {4 4} {} + -out {1 1} {E} -out {4 4} {A} + -adj {1 1} {A D E} -adj {4 4} {A} + -inner {1 1} {} -inner {4 4} {} + -embedding {1 1} {A D E} -embedding {4 4} {A} +} { + test graph-${impl}-${setimpl}-arcs-ioaie-3.$n "arcs, $switch" { + SETUP + + mygraph node insert 1 2 3 4 5 6 + mygraph arc insert 4 1 A + mygraph arc insert 5 2 B + mygraph arc insert 6 3 C + mygraph arc insert 3 1 D + mygraph arc insert 1 2 E + mygraph arc insert 2 3 F + + set result [lsort [eval [linsert $nodes 0 mygraph arcs $switch]]] + mygraph destroy + set result + } $expected ; # {} + + incr n +} + +test graph-${impl}-${setimpl}-arcs-adj-1.0 {arcs -adj, border case C code failure} -setup { + struct::graph mygraph + mygraph node insert E + mygraph node insert F + mygraph arc insert E F E_F +} -body { + mygraph arcs -adj E +} -cleanup { + mygraph destroy +} -result {E_F} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/assign.test b/tcllib/modules/struct/graph/tests/assign.test new file mode 100644 index 0000000..20e2c29 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/assign.test @@ -0,0 +1,75 @@ +# -*- tcl -*- +# Graph tests - assignment (=) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: assign.test,v 1.2 2007/04/12 03:01:54 andreas_kupries Exp $ + +# Syntax: graph = GRAPH + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-assign-1.0 {assign, wrong#args, missing} { + SETUP + catch {mygraph =} result + mygraph destroy + set result +} [tmWrong = source 0] + +test graph-${impl}-${setimpl}-assign-1.1 {assign, wrong#args, too many} { + SETUP + catch {mygraph = foo bar} result + mygraph destroy + set result +} [tmTooMany = source] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-assign-2.0 {assign, bad src command} { + SETUP + catch {mygraph = foo} result + mygraph destroy + set result +} {invalid command name "foo"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-assign-3.0 {assign, direct} { + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + SETUP + SETUP bgraph + + mygraph deserialize $serial + + set result [validate_serial bgraph $serial] + bgraph = mygraph + lappend result [validate_serial bgraph $serial] + + mygraph destroy + bgraph destroy + set result +} {attr/graph/data-mismatch ok} + +test graph-${impl}-${setimpl}-assign-3.1 {assign, deserial/serial} { + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + SETUP + SETUP bgraph + proc mywrap {args} {uplevel #0 [linsert $args 0 mygraph]} + + mygraph deserialize $serial + + set result [validate_serial bgraph $serial] + bgraph = mywrap + lappend result [validate_serial bgraph $serial] + + mygraph destroy + bgraph destroy + rename mywrap {} + set result +} {attr/graph/data-mismatch ok} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/Xsetup b/tcllib/modules/struct/graph/tests/attr/Xsetup new file mode 100644 index 0000000..557ab66 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/Xsetup @@ -0,0 +1,78 @@ +# -*- tcl -*- +# Graph tests - Attribute helper commands +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: Xsetup,v 1.1 2006/11/16 06:33:14 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +proc Arc {} {mygraph node insert 0 1 ; mygraph arc insert 0 1 x} +proc Node {} {mygraph node insert x} +proc Graph {} {} + +proc SetRArc {a} {CMD set x $a} +proc SetRNode {a} {CMD set x $a} +proc SetRGraph {a} {CMD set $a} + +proc SetWArc {a v} {CMD set x $a $v} +proc SetWNode {a v} {CMD set x $a $v} +proc SetWGraph {a v} {CMD set $a $v} + +proc GetArc {a} {CMD get x $a} +proc GetNode {a} {CMD get x $a} +proc GetGraph {a} {CMD get $a} + +proc UnsetArc {a} {CMD unset x $a} +proc UnsetNode {a} {CMD unset x $a} +proc UnsetGraph {a} {CMD unset $a} + +proc AppendArc {a v} {CMD append x $a $v} +proc AppendNode {a v} {CMD append x $a $v} +proc AppendGraph {a v} {CMD append $a $v} + +proc LappendArc {a v} {CMD lappend x $a $v} +proc LappendNode {a v} {CMD lappend x $a $v} +proc LappendGraph {a v} {CMD lappend $a $v} + +proc KeyexistsArc {a} {CMD keyexists x $a} +proc KeyexistsNode {a} {CMD keyexists x $a} +proc KeyexistsGraph {a} {CMD keyexists $a} + +proc GetallArc {} {CMD getall x} +proc GetallNode {} {CMD getall x} +proc GetallGraph {} {CMD getall } + +proc GetallPArc {p} {CMD getall x $p} +proc GetallPNode {p} {CMD getall x $p} +proc GetallPGraph {p} {CMD getall $p} + +proc KeysArc {} {CMD keys x} +proc KeysNode {} {CMD keys x} +proc KeysGraph {} {CMD keys } + +proc KeysPArc {p} {CMD keys x $p} +proc KeysPNode {p} {CMD keys x $p} +proc KeysPGraph {p} {CMD keys $p} + +# ------------------------------------------------------------------------- + +proc AttrSetup {} { + # CMD is for the testing of wrong#args errors. + # XXX$ex are for regular tests, i.e. argument + # errors and ok behaviour. + + upvar 1 mk mk stem stem e e MY MY + + if {$mk == {}} {set mk $MY} + + # CMD = stem, remove existing CMD + catch {interp alias {} CMD {}} + eval [linsert $stem 0 interp alias {} CMD {}] + + # To skip tests which do not apply to graph attributes + ::tcltest::testConstraint graph \ + [string equal $e graph] + return +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/append.test b/tcllib/modules/struct/graph/tests/attr/append.test new file mode 100644 index 0000000..03dcbfd --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/append.test @@ -0,0 +1,88 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node append (attribute append) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: append.test,v 1.3 2008/03/07 06:51:36 andreas_kupries Exp $ + +# Syntax: graph append KEY VALUE +# Syntax: graph arc append ARC KEY VALUE +# Syntax: graph node append NODE KEY VALUE + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-append-1.0 "$e append, wrong#args, missing" { + SETUP + catch {CMD append} msg + mygraph destroy + set msg + } [tmWrongA "${mp}append" "${mp}key value" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-append-1.1 "$e append, wrong#args, missing" { + SETUP + catch {CMD append a} msg + mygraph destroy + set msg + } [tmWrongA "${mp}append" "${mp}key value" 1] ; # {} + + test graph-${impl}-${setimpl}-${e}-append-1.2 "$e append, wrong#args, missing" !graph { + SETUP + catch {CMD append a b} msg + mygraph destroy + set msg + } [tmWrongA "${mp}append" "${mp}key value" 2] ; # {} + + test graph-${impl}-${setimpl}-${e}-append-1.3 "$e append, wrong#args, too many" { + SETUP + catch {CMD append a b c d} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}append" "${mp}key value"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-append-2.0 "$e append, missing $e" !graph { + SETUP + catch {Append$ex data foo} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-append-3.0 "$e append, no attribute, created" { + SETUP + $ex + set result {} + lappend result [Keyexists$ex data] + lappend result [Append$ex data bar] + lappend result [Keyexists$ex data] + lappend result [Get$ex data] + mygraph destroy + set result + } {0 bar 1 bar} ; # {} + + test graph-${impl}-${setimpl}-${e}-append-3.1 "$e append, existing attribute, appending" { + SETUP + $ex + set result {} + lappend result [SetW$ex data foo] + lappend result [Append$ex data bar] + lappend result [Get$ex data] + mygraph destroy + set result + } {foo foobar foobar} ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/get.test b/tcllib/modules/struct/graph/tests/attr/get.test new file mode 100644 index 0000000..d7554ec --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/get.test @@ -0,0 +1,84 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node get (attribute get) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: get.test,v 1.3 2008/03/07 06:51:36 andreas_kupries Exp $ + +# Syntax: graph get KEY +# Syntax: graph arc get ARC KEY +# Syntax: graph node get NODE KEY + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-get-1.0 "$e get, wrong#args, missing" { + SETUP + catch {CMD get} msg + mygraph destroy + set msg + } [tmWrongA "${mp}get" "${mp}key" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-get-1.1 "$e get, wrong#args, missing" !graph { + SETUP + catch {CMD get x} msg + mygraph destroy + set msg + } [tmWrongA "${mp}get" "${mp}key" 1] ; # {} + + test graph-${impl}-${setimpl}-${e}-get-1.2 "$e get, wrong#args, too many" { + SETUP + catch {CMD get x y z} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}get" "${mp}key"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-get-2.0 "$e get, missing $e" !graph { + SETUP + catch {Get$ex data} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + test graph-${impl}-${setimpl}-${e}-get-2.1 "$e get, no attributes" { + SETUP + $ex + catch {Get$ex bogus} msg + mygraph destroy + set msg + } [MissingKey $mk $e bogus] ; # {} + + test graph-${impl}-${setimpl}-${e}-get-2.2 "$e get, missing key" { + SETUP + $ex + SetW$ex foo far + catch {Get$ex bogus} msg + mygraph destroy + set msg + } [MissingKey $mk $e bogus] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-get-2.4 "$e get" { + SETUP + $ex + SetW$ex boom foobar + set result [Get$ex boom] + mygraph destroy + set result + } foobar ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/getall.test b/tcllib/modules/struct/graph/tests/attr/getall.test new file mode 100644 index 0000000..114080d --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/getall.test @@ -0,0 +1,79 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node getall (attribute getall) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: getall.test,v 1.3 2008/03/07 06:51:37 andreas_kupries Exp $ + +# Syntax: graph getall ?PATTERN? +# Syntax: graph arc getall ARC ?PATTERN? +# Syntax: graph node getall NODE ?PATTERN? + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-getall-1.0 "$e getall, wrong # args, missing" !graph { + SETUP + catch {CMD getall} msg + mygraph destroy + set msg + } [tmWrongA "${mp}getall" "${mp}?pattern?" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-getall-1.1 "$e getall, wrong # args, too many" { + SETUP + catch {CMD getall a b c} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}getall" "${mp}?pattern?"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-getall-2.0 "$e getall, missing $e" !graph { + SETUP + catch {Getall$ex} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-getall-3.0 "$e getall, no attributes, empty dictionary" { + SETUP + $ex + set results [Getall$ex] + mygraph destroy + set results + } {} ; # {} + + test graph-${impl}-${setimpl}-${e}-getall-3.1 "$e getall, result is dictionary" { + SETUP + $ex + SetW$ex data foobar + SetW$ex other thing + set results [dictsort [Getall$ex]] + mygraph destroy + set results + } {data foobar other thing} ; # {} + + test graph-${impl}-${setimpl}-${e}-getall-3.2 "$e getall, pattern match" { + SETUP + $ex + SetW$ex data foobar + SetW$ex other thing + set results [dictsort [GetallP$ex d*]] + mygraph destroy + set results + } {data foobar} ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/keyexists.test b/tcllib/modules/struct/graph/tests/attr/keyexists.test new file mode 100644 index 0000000..d543be7 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/keyexists.test @@ -0,0 +1,84 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node keyexists (attribute keyexists) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: keyexists.test,v 1.3 2008/03/07 06:51:39 andreas_kupries Exp $ + +# Syntax: graph keyexists KEY +# Syntax: graph arc keyexists ARC KEY +# Syntax: graph node keyexists NODE KEY + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-keyexists-1.0 "$e keyexists, wrong # args, missing" { + SETUP + catch {CMD keyexists} msg + mygraph destroy + set msg + } [tmWrongA "${mp}keyexists" "${mp}key" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-keyexists-1.1 "$e keyexists, wrong # args, missing" !graph { + SETUP + catch {CMD keyexists a} msg + mygraph destroy + set msg + } [tmWrongA "${mp}keyexists" "${mp}key" 1] ; # {} + + test graph-${impl}-${setimpl}-${e}-keyexists-1.2 "$e keyexists, wrong # args, too many" { + SETUP + catch {CMD keyexists a b c} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}keyexists" "${mp}key"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-keyexists-2.0 "$e keyexists, missing $e" !graph { + SETUP + catch {Keyexists$ex foo} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-keyexists-3.0 "$e keyexists, no attributes" { + SETUP + $ex + set result [Keyexists$ex bogus] + mygraph destroy + set result + } 0 ; # {} + + test graph-${impl}-${setimpl}-${e}-keyexists-3.1 "$e keyexists, missing key" { + SETUP + $ex + SetW$ex ok "" + set result [Keyexists$ex bogus] + mygraph destroy + set result + } 0 ; # {} + + test graph-${impl}-${setimpl}-${e}-keyexists-3.2 "$e keyexists, existing key" { + SETUP + $ex + SetW$ex ok "" + set result [Keyexists$ex ok] + mygraph destroy + set result + } 1 ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/keys.test b/tcllib/modules/struct/graph/tests/attr/keys.test new file mode 100644 index 0000000..e80c445 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/keys.test @@ -0,0 +1,79 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node keys (attribute keys) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: keys.test,v 1.3 2008/03/07 06:51:39 andreas_kupries Exp $ + +# Syntax: graph keys ?PATTERN? +# Syntax: graph arc keys ARC ?PATTERN? +# Syntax: graph node keys NODE ?PATTERN? + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-keys-1.0 "$e keys, wrong # args, missing" !graph { + SETUP + catch {CMD keys} msg + mygraph destroy + set msg + } [tmWrongA "${mp}keys" "${mp}?pattern?" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-keys-1.1 "$e keys, wrong # args, too many" { + SETUP + catch {CMD keys a b c} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}keys" "${mp}?pattern?"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-keys-2.0 "$e keys, missing $e" !graph { + SETUP + catch {Keys$ex} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-keys-3.0 "$e keys, no attributes, empty list result" { + SETUP + $ex + set results [Keys$ex] + mygraph destroy + set results + } {} + + test graph-${impl}-${setimpl}-${e}-keys-3.1 "$e keys, list result" { + SETUP + $ex + SetW$ex data foobar + SetW$ex other thing + set results [Keys$ex] + mygraph destroy + lsort $results + } {data other} + + test graph-${impl}-${setimpl}-${e}-keys-3.2 "$e keys, pattern match" { + SETUP + $ex + SetW$ex data foobar + SetW$ex other thing + set results [KeysP$ex d*] + mygraph destroy + set results + } data +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/lappend.test b/tcllib/modules/struct/graph/tests/attr/lappend.test new file mode 100644 index 0000000..df3e5ab --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/lappend.test @@ -0,0 +1,88 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node lappend (attribute lappend) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: lappend.test,v 1.3 2008/03/07 06:51:39 andreas_kupries Exp $ + +# Syntax: graph lappend KEY VALUE +# Syntax: graph arc lappend ARC KEY VALUE +# Syntax: graph node lappend NODE KEY VALUE + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-lappend-1.0 "$e lappend, wrong#args, missing" { + SETUP + catch {CMD lappend} msg + mygraph destroy + set msg + } [tmWrongA "${mp}lappend" "${mp}key value" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-lappend-1.1 "$e lappend, wrong#args, missing" { + SETUP + catch {CMD lappend a} msg + mygraph destroy + set msg + } [tmWrongA "${mp}lappend" "${mp}key value" 1] ; # {} + + test graph-${impl}-${setimpl}-${e}-lappend-1.2 "$e lappend, wrong#args, missing" !graph { + SETUP + catch {CMD lappend a b} msg + mygraph destroy + set msg + } [tmWrongA "${mp}lappend" "${mp}key value" 2] ; # {} + + test graph-${impl}-${setimpl}-${e}-lappend-1.3 "$e lappend, wrong#args, too many" { + SETUP + catch {CMD lappend a b c d} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}lappend" "${mp}key value"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-lappend-2.0 "$e lappend, missing $e" !graph { + SETUP + catch {Lappend$ex data foo} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-lappend-3.0 "$e lappend, no attribute, created" { + SETUP + $ex + set result {} + lappend result [Keyexists$ex data] + lappend result [Lappend$ex data bar] + lappend result [Keyexists$ex data] + lappend result [Get$ex data] + mygraph destroy + set result + } {0 bar 1 bar} ; # {} + + test graph-${impl}-${setimpl}-${e}-lappend-3.1 "$e lappend, existing attribute, appending" { + SETUP + $ex + set result {} + lappend result [SetW$ex data foo] + lappend result [Lappend$ex data bar] + lappend result [Get$ex data] + mygraph destroy + set result + } {foo {foo bar} {foo bar}} ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/set.test b/tcllib/modules/struct/graph/tests/attr/set.test new file mode 100644 index 0000000..626404e --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/set.test @@ -0,0 +1,97 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node set (attribute set) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: set.test,v 1.3 2008/03/07 06:51:39 andreas_kupries Exp $ + +# Syntax: graph set KEY ?VALUE? +# Syntax: graph arc set ARC KEY ?VALUE? +# Syntax: graph node set NODE KEY ?VALUE? + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + AttrSetup + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-set-1.0 "$e set, wrong # args, missing" { + SETUP + catch {CMD set} msg + mygraph destroy + set msg + } [tmWrongA "${mp}set" "${mp}key ?value?" 0 "${mp}key args"] ; # {} + + test graph-${impl}-${setimpl}-${e}-set-1.1 "$e set, wrong # args, missing" !graph { + SETUP + catch {CMD set a} msg + mygraph destroy + set msg + } [tmWrongA "${mp}set" "${mp}key ?value?" 1 "${mp}key args"] ; # {} + + test graph-${impl}-${setimpl}-${e}-set-1.2 "$e set, wrong # args, too many" { + SETUP + catch {CMD set a b c d} msg + mygraph destroy + set msg + } [tmE \ + "wrong # args: should be \"$MY ${mp}set ${mp}key ?value?\"" \ + [tmTooManyA "${mp}set" "${mp}key ?value?"]] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-set-2.0 "$e set, missing $e" !graph { + SETUP + catch {CMD set x data} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + test graph-${impl}-${setimpl}-${e}-set-2.1 "$e set, no attributes (retrieval)" { + SETUP + $ex + catch {SetR$ex foo} msg + mygraph destroy + set msg + } [MissingKey $mk $e foo] ; # {} + + test graph-${impl}-${setimpl}-${e}-set-2.2 "$e set, missing key (retrieval)" { + SETUP + $ex + SetW$ex data "" + catch {SetR$ex foo} msg + mygraph destroy + set msg + } [MissingKey $mk $e foo] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-set-3.0 "$e set, set value, result" { + SETUP + $ex + set result {} + lappend result [SetW$ex baz foobar] + lappend result [Get$ex baz] + mygraph destroy + set result + } {foobar foobar} ; # {} + + test graph-${impl}-${setimpl}-${e}-set-3.1 "$e set, retrieve value" { + SETUP + $ex + SetW$ex baz foobar + + set result [SetR$ex baz] + mygraph destroy + set result + } foobar ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/attr/unset.test b/tcllib/modules/struct/graph/tests/attr/unset.test new file mode 100644 index 0000000..1a79440 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/attr/unset.test @@ -0,0 +1,115 @@ +# -*- tcl -*- +# Graph tests - graph/arc/node unset (attribute unset) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: unset.test,v 1.3 2008/03/07 06:51:39 andreas_kupries Exp $ + +# Syntax: graph unset KEY +# Syntax: graph arc unset ARC KEY +# Syntax: graph node unset NODE KEY + +# ------------------------------------------------------------------------- + +proc Arc {} {mygraph node insert 0 1 ; mygraph arc insert 0 1 x} +proc Node {} {mygraph node insert x} + +# ------------------------------------------------------------------------- + +foreach {e ex stem mp mk} { + arc Arc {mygraph arc} {arc } x + node Node {mygraph node} {node } x + graph Graph {mygraph} {} {} +} { + if {$mk == {}} {set mk $MY} + # CMD = stem, remove existing CMD + catch {interp alias {} CMD {}} + eval [linsert $stem 0 interp alias {} CMD {}] + # To skip tests which do not apply to graph attributes + ::tcltest::testConstraint graph [string equal $e graph] + + # CMD is for the testing of wrong#args errors. + # XXX$ex are for regular tests, i.e. argument + # errors and ok behaviour. + + # ------------------------------------------------------------------------- + # Wrong # args: Missing, Too many + + test graph-${impl}-${setimpl}-${e}-unset-1.0 "$e unset, wrong # args, missing" { + SETUP + catch {CMD unset} msg + mygraph destroy + set msg + } [tmWrongA "${mp}unset" "${mp}key" 0] ; # {} + + test graph-${impl}-${setimpl}-${e}-unset-1.1 "$e unset, wrong # args, missing" !graph { + SETUP + catch {CMD unset a} msg + mygraph destroy + set msg + } [tmWrongA "${mp}unset" "${mp}key" 1] ; # {} + + test graph-${impl}-${setimpl}-${e}-unset-1.2 "$e unset, wrong # args, too many" { + SETUP + catch {CMD unset a b c} msg + mygraph destroy + set msg + } [tmTooManyA "${mp}unset" "${mp}key"] ; # {} + + # ------------------------------------------------------------------------- + # Logical arguments checks and failures + + test graph-${impl}-${setimpl}-${e}-unset-2.0 "$e unset, missing $e" !graph { + SETUP + catch {Unset$ex data} msg + mygraph destroy + set msg + } [Missing$ex $MY x] ; # {} + + # ------------------------------------------------------------------------- + # Ok arguments. + + test graph-${impl}-${setimpl}-${e}-unset-3.0 "$e unset, no attributes, ok" { + SETUP + $ex + set result [list [catch {Unset$ex bogus} msg] $msg] + mygraph destroy + set result + } {0 {}} ; # {} + + test graph-${impl}-${setimpl}-${e}-unset-3.1 "$e unset, missing key, ok" { + SETUP + $ex + SetW$ex foo "" + set result [list [catch {Unset$ex bogus} msg] $msg] + mygraph destroy + set result + } {0 {}} ; # {} + + test graph-${impl}-${setimpl}-${e}-unset-3.2 "$e unset, data is gone" { + SETUP + $ex + set result {} + lappend result [Keyexists$ex foobar] + SetW$ex foobar foobar + lappend result [Keyexists$ex foobar] + Unset$ex foobar + lappend result [Keyexists$ex foobar] + mygraph destroy + set result + } {0 1 0} ; # {} + + test graph-${impl}-${setimpl}-${e}-unset-3.6 "$e unset, then $e delete" !graph { + SETUP + $ex + set result {} + + mygraph $e set x foo bar + mygraph $e unset x foo + mygraph $e delete x + set result [mygraph $e exists x] + mygraph destroy + set result + } 0 ; # {} +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/command.test b/tcllib/modules/struct/graph/tests/command.test new file mode 100644 index 0000000..67121b9 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/command.test @@ -0,0 +1,161 @@ +# -*- tcl -*- +# Graph tests - graph command basics +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: command.test,v 1.7 2009/11/26 04:42:16 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +# Graph class command has no missing arguments, will auto-generate +# instance name. As for too many arguments, this will be checked as +# part of testing the de-serialization. + +test graph-${impl}-${setimpl}-create-1.1 {graph create, copy, wrong#args, missing} { + catch {mygraph destroy} + catch {struct::graph mygraph =} result + set result +} {wrong # args: should be "struct::graph ?name ?=|:=|as|deserialize source??"} + +test graph-${impl}-${setimpl}-create-1.2 {graph create, copy, wrong#args, too many} { + catch {mygraph destroy} + catch {struct::graph mygraph = a b} result + set result +} {wrong # args: should be "struct::graph ?name ?=|:=|as|deserialize source??"} + +test graph-${impl}-${setimpl}-create-1.3 {graph create, copy, unknown operator} { + catch {mygraph destroy} + catch {struct::graph mygraph foo a} result + set result +} {wrong # args: should be "struct::graph ?name ?=|:=|as|deserialize source??"} + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-create-2.0 {graph create, duplicate, graph} { + SETUP + catch {struct::graph mygraph} msg + mygraph destroy + set msg +} "command \"::mygraph\" already exists, unable to create graph" + +test graph-${impl}-${setimpl}-create-2.1 {graph create, duplicate, non-graph} { + catch {struct::graph set} msg + set msg +} "command \"::set\" already exists, unable to create graph" + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-create-3.0 {graph create, object command is created} { + SETUP + set result [string equal [info commands ::mygraph] "::mygraph"] + mygraph destroy + set result +} 1 + +test graph-${impl}-${setimpl}-create-3.1 {graph create, auto-generation of name} { + set name [struct::graph] + set result [list \ + [string match ::graph* $name] \ + [string equal [info commands $name] "$name"]] + $name destroy + set result +} {1 1} + +test graph-${impl}-${setimpl}-create-3.2 {graph create, destroy removes object command} { + SETUP + mygraph destroy + string equal [info commands ::mygraph] "" +} 1 + +test graph-${impl}-${setimpl}-create-3.3 {graph create, copy, value} { + catch {mygraph destroy} + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + struct::graph mygraph deserialize $serial + set result [validate_serial mygraph $serial] + mygraph destroy + + set result +} ok + +test graph-${impl}-${setimpl}-create-3.4 {graph create, copy, graph} { + catch {mygraph destroy} + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + struct::graph mygraph deserialize $serial + struct::graph bgraph = mygraph + + set result [validate_serial bgraph $serial] + mygraph destroy + bgraph destroy + + set result +} ok + +test graph-${impl}-${setimpl}-create-3.5 {graph create, copy, graph with weights} { + catch {mygraph destroy} + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {} 222}} %1 {} {{d 9 {}}} %2 {} {{e 0 {} 444}} {data foo}} + + struct::graph mygraph deserialize $serial + struct::graph bgraph = mygraph + + set result [validate_serial bgraph $serial] + mygraph destroy + bgraph destroy + + set result +} ok + +test graph-${impl}-${setimpl}-create-3.6 {graph create, copy, empty graph} { + catch {mygraph destroy} + set serial {{}} + + struct::graph mygraph deserialize $serial + struct::graph bgraph = mygraph + + set result [validate_serial bgraph $serial] + mygraph destroy + bgraph destroy + + set result +} ok + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-instance-1.0 {graph command, wrong#args, missing} { + SETUP + catch {mygraph} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY option ?arg arg ...?\"" + +# Too many arguments dependent on method, not testable here. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-instance-2.0 {graph command, bad method} { + SETUP + catch {mygraph foo} msg + mygraph destroy + set msg +} {bad option "foo": must be -->, =, append, arc, arcs, deserialize, destroy, get, getall, keyexists, keys, lappend, node, nodes, serialize, set, swap, unset, or walk} + +test graph-${impl}-${setimpl}-instance-2.1 {graph arc command, bad method} { + SETUP + catch {mygraph arc foo} msg + mygraph destroy + set msg +} {bad option "foo": must be append, attr, delete, exists, flip, get, getall, getunweighted, getweight, hasweight, insert, keyexists, keys, lappend, move, move-source, move-target, nodes, rename, set, setunweighted, setweight, source, target, unset, unsetweight, or weights} + +test graph-${impl}-${setimpl}-instance-2.2 {graph node command, bad method} { + SETUP + catch {mygraph node foo} msg + mygraph destroy + set msg +} {bad option "foo": must be append, attr, degree, delete, exists, get, getall, insert, keyexists, keys, lappend, opposite, rename, set, or unset} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/deserialize.test b/tcllib/modules/struct/graph/tests/deserialize.test new file mode 100644 index 0000000..b6cc895 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/deserialize.test @@ -0,0 +1,209 @@ +# -*- tcl -*- +# Graph tests - deserialize +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: deserialize.test,v 1.3 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph deserialize SERIALIZATION + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-deserialize-1.0 {deserialize, wrong #args, missing} { + SETUP + catch {mygraph deserialize} result + mygraph destroy + set result +} [tmWrong deserialize serial 0] + +test graph-${impl}-${setimpl}-deserialize-1.1 {deserialize, wrong #args, to many} { + SETUP + catch {mygraph deserialize foo bar} result + mygraph destroy + set result +} [tmTooMany deserialize serial] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-deserialize-2.0 {deserialize, incorrect length} { + SETUP + set serial {. %3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: list length not 1 mod 3.}} + +test graph-${impl}-${setimpl}-deserialize-2.1 {deserialize, attributes, graph, !dict} { + SETUP + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data . foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: malformed graph attribute dictionary.}} + +test graph-${impl}-${setimpl}-deserialize-2.2 {deserialize, attributes, node, !dict} { + SETUP + set serial {%3 {.} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: malformed node attribute dictionary.}} + +test graph-${impl}-${setimpl}-deserialize-2.3 {deserialize, attributes, arc, !dict} { + SETUP + set serial {%3 {} {{f 6 {.}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: malformed arc attribute dictionary.}} + +test graph-${impl}-${setimpl}-deserialize-2.4 {deserialize, duplicate arcs} { + SETUP + set serial {%3 {} {{a 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: duplicate definition of arc "a".}} + +test graph-${impl}-${setimpl}-deserialize-2.5 {deserialize, non-numeric node-reference} { + SETUP + set serial {%3 {} {{f . {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: bad arc destination reference ".".}} + +test graph-${impl}-${setimpl}-deserialize-2.6 {deserialize, incorrect node-reference, not 0 mod 3} { + SETUP + set serial {%3 {} {{f 2 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: bad arc destination reference "2".}} + +test graph-${impl}-${setimpl}-deserialize-2.7 {deserialize, out-of-range node-reference, lower bound} { + SETUP + set serial {%3 {} {{f -2 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: bad arc destination reference "-2".}} + +test graph-${impl}-${setimpl}-deserialize-2.8 {deserialize, out-of-range node-reference, upper bound} { + SETUP + set serial {%3 {} {{f 14 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: bad arc destination reference "14".}} + +test graph-${impl}-${setimpl}-deserialize-2.9 {deserialize, duplicate nodes} { + SETUP + set serial {%1 {foo bar} {{a 3 {}} {c 6 {}}} %1 {} {} %3 {} {{f 3 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: duplicate node names.}} + +test graph-${impl}-${setimpl}-deserialize-2.10 {deserialize, wrong arc information length, missing} { + SETUP + set serial {%3 {} {{f 6}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: arc information length not 3 or 4.}} + +test graph-${impl}-${setimpl}-deserialize-2.11 {deserialize, wrong arc information length, too many} { + SETUP + set serial {%3 {} {{f 6 {. .} _weight_ toomuch}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set fail [catch {mygraph deserialize $serial} result] + mygraph destroy + list $fail $result +} {1 {error in serialization: arc information length not 3 or 4.}} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-deserialize-3.0 {deserialize, empty graph} { + SETUP + set serial {{}} + mygraph deserialize $serial + set result [validate_serial mygraph $serial] + mygraph destroy + set result +} ok + +test graph-${impl}-${setimpl}-deserialize-3.1 {deserialize} { + SETUP + + # Our check of the success of the deserialize + # is to validate the generated graph against the + # serialized data. + + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + set result [list] + lappend result [validate_serial mygraph $serial] + + mygraph deserialize $serial + lappend result [validate_serial mygraph $serial] + + mygraph destroy + set result +} {attr/graph/data-mismatch ok} + +test graph-${impl}-${setimpl}-deserialize-3.2 {deserialize} { + SETUP + + # Our check of the success of the deserialize + # is to validate the generated graph against the + # serialized data. + + # Applying to serialization one after the + # other. Checking that the second operation + # completely squashes the data from the first. + + set seriala {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + set serialb {%0 {foo bar} {{a 3 {}} {c 6 {}}} %1 {} {} %3 {} {{f 3 {}}} {data foo}} + + set result [list] + lappend result [validate_serial mygraph $seriala] + lappend result [validate_serial mygraph $serialb] + + mygraph deserialize $seriala + lappend result [validate_serial mygraph $seriala] + lappend result [validate_serial mygraph $serialb] + + mygraph deserialize $serialb + lappend result [validate_serial mygraph $seriala] + lappend result [validate_serial mygraph $serialb] + + mygraph destroy + set result +} [list \ + attr/graph/data-mismatch attr/graph/data-mismatch \ + ok nodes/mismatch/#nodes \ + arc/b/unknown ok] + + +test graph-${impl}-${setimpl}-deserialize-3.3 {deserialize, weights} { + SETUP + + # Our check of the success of the deserialize + # is to validate the generated graph against the + # serialized data. + + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {} 333} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {} 888}} %2 {} {{e 0 {}}} {data foo}} + + set result [list] + lappend result [validate_serial mygraph $serial] + + mygraph deserialize $serial + lappend result [validate_serial mygraph $serial] + + mygraph destroy + set result +} {attr/graph/data-mismatch ok} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/attr.test b/tcllib/modules/struct/graph/tests/node/attr.test new file mode 100644 index 0000000..fab276e --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/attr.test @@ -0,0 +1,97 @@ +# -*- tcl -*- +# Graph tests - node attr +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: attr.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node attr KEY ?-nodes NODESLIST|-glob PATTERN|-regexp PATTERN? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-attr-1.0 {node attr, wrong#args, missing} { + SETUPx + catch {mygraph node attr} msg + mygraph destroy + set msg +} [tmWrong {node attr} {key ?-nodes list|-glob pattern|-regexp pattern?} 0 {key args}] + +test graph-${impl}-${setimpl}-node-attr-1.1 {node attr, wrong#args, missing} { + SETUPx + catch {mygraph node attr a b} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + +test graph-${impl}-${setimpl}-node-attr-1.2 {node attr, wrong#args, too many} { + SETUPx + catch {mygraph node attr a b c d} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-attr-2.0 {node attr, bogus switch} { + SETUPx + catch {mygraph node attr a -foo barf} msg + mygraph destroy + set msg +} {bad type "-foo": must be -glob, -nodes, or -regexp} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-node-attr-3.4 {node attr, unfiltered, nothing} { + SETUPx + set result [mygraph node attr vol] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-node-attr-3.5 {node attr, unfiltered something} { + SETUPx + set result [dictsort [mygraph node attr volume]] + mygraph destroy + set result +} {%0 30 %5 50} + +test graph-${impl}-${setimpl}-node-attr-3.6 {node attr, filtered -nodes} { + SETUPx + set result [mygraph node attr volume -nodes {%0 %3}] + mygraph destroy + set result +} {%0 30} + +test graph-${impl}-${setimpl}-node-attr-3.7 {node attr, filtered -glob} { + SETUPx + set result [mygraph node attr volume -glob {%[0-3]}] + mygraph destroy + set result +} {%0 30} + +test graph-${impl}-${setimpl}-node-attr-3.8 {node attr, filtered regexp} { + SETUPx + set result [mygraph node attr volume -regexp {[0-3]}] + mygraph destroy + set result +} {%0 30} + +test graph-${impl}-${setimpl}-node-attr-3.9 {node attr, filtered -nodes nothing} { + SETUPx + set result [mygraph node attr volume -nodes {}] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-node-attr-3.10 {node attr, nothing} { + SETUPx + mygraph node unset %0 volume + mygraph node unset %5 volume + set result [mygraph node attr volume] + mygraph destroy + set result +} {} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/degree.test b/tcllib/modules/struct/graph/tests/node/degree.test new file mode 100644 index 0000000..cca0ce5 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/degree.test @@ -0,0 +1,87 @@ +# -*- tcl -*- +# Graph tests - node degree +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: degree.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node degree ?-in|-out? NODE + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-degree-1.0 {node degree, wrong#args, missing} { + SETUP + catch {mygraph node degree} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY node degree ?-in|-out? node\"" + +test graph-${impl}-${setimpl}-node-degree-1.1 {node degree, wrong#args, too many} { + SETUP + catch {mygraph node degree foo bar baz} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY node degree ?-in|-out? node\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-degree-2.0 {node degree, missing node} { + SETUP + catch {mygraph node degree node0} msg + mygraph destroy + set msg +} [MissingNode $MY node0] + +test graph-${impl}-${setimpl}-node-degree-2.1 {node degree, bad switch} { + SETUP + catch {mygraph node degree -foo node0} msg + mygraph destroy + set msg +} "bad option \"-foo\": must be -in or -out" + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-node-degree-3.0 {node degree} { + SETUP + mygraph node insert node0 node1 node2 node3 node4 node5 + + mygraph arc insert node1 node2 arc0 + mygraph arc insert node3 node3 arc1 + mygraph arc insert node4 node5 arc2 + mygraph arc insert node4 node5 arc3 + mygraph arc insert node4 node5 arc4 + mygraph arc insert node5 node2 arc5 + + set result {} + lappend result node0 - + lappend result [mygraph node degree node0] + lappend result [mygraph node degree -in node0] + lappend result [mygraph node degree -out node0] + lappend result node1 - + lappend result [mygraph node degree node1] + lappend result [mygraph node degree -in node1] + lappend result [mygraph node degree -out node1] + lappend result node2 - + lappend result [mygraph node degree node2] + lappend result [mygraph node degree -in node2] + lappend result [mygraph node degree -out node2] + lappend result node3 - + lappend result [mygraph node degree node3] + lappend result [mygraph node degree -in node3] + lappend result [mygraph node degree -out node3] + lappend result node4 - + lappend result [mygraph node degree node4] + lappend result [mygraph node degree -in node4] + lappend result [mygraph node degree -out node4] + lappend result node5 - + lappend result [mygraph node degree node5] + lappend result [mygraph node degree -in node5] + lappend result [mygraph node degree -out node5] + + mygraph destroy + set result +} {node0 - 0 0 0 node1 - 1 0 1 node2 - 2 2 0 node3 - 2 1 1 node4 - 3 0 3 node5 - 4 3 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/delete.test b/tcllib/modules/struct/graph/tests/node/delete.test new file mode 100644 index 0000000..56a92d3 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/delete.test @@ -0,0 +1,88 @@ +# -*- tcl -*- +# Graph tests - node deletion +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: delete.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node delete NODE NODE... + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-delete-1.0 {node delete, wrong#args, missing} { + SETUP + catch {mygraph node delete} msg + mygraph destroy + set msg +} [tmE {wrong # args: should be "::struct::graph::__node_delete name node node..."} \ + {wrong # args: should be "mygraph node delete node node..."}] + +# Cannot use tmWrong, will be incorrect for the Tcl implementation +# run by a pre-8.4 core. +# [tmWrong {node delete} {node node...} 0] + +# Impossible to have too many arguments +# Any number of nodes is acceptable. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-delete-2.0 {node delete, missing node} { + SETUP + catch {mygraph node delete node0} msg + mygraph destroy + set msg +} [MissingNode $MY node0] + +# ------------------------------------------------------------------------- +# Ok arguments, single, multiple deletion. + +test graph-${impl}-${setimpl}-node-delete-3.0 {node delete, single} { + SETUP + mygraph node insert node0 + set res {} + + lappend res [mygraph node exists node0] + lappend res [mygraph node delete node0] + lappend res [mygraph node exists node0] + + mygraph destroy + set res +} {1 {} 0} + +test graph-${impl}-${setimpl}-node-delete-3.1 {node delete, multiple at once} { + SETUP + mygraph node insert node0 node1 node2 node3 + set res {} + + lappend res [mygraph node exists node0] + lappend res [mygraph node exists node1] + lappend res [mygraph node exists node2] + lappend res [mygraph node exists node3] + lappend res [mygraph node delete node0 node1 node2 node3] + lappend res [mygraph node exists node0] + lappend res [mygraph node exists node1] + lappend res [mygraph node exists node2] + lappend res [mygraph node exists node3] + + mygraph destroy + set res +} {1 1 1 1 {} 0 0 0 0} + +test graph-${impl}-${setimpl}-node-delete-3.2 {node delete, deleting adjacent arcs} { + SETUP + mygraph node insert node0 node1 node2 + mygraph arc insert node0 node1 arc0 + mygraph arc insert node1 node2 arc1 + + mygraph node delete node1 + + set result {} + lappend result [mygraph arc exists arc0] + lappend result [mygraph arc exists arc1] + + mygraph destroy + set result +} {0 0} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/exists.test b/tcllib/modules/struct/graph/tests/node/exists.test new file mode 100644 index 0000000..47d8ef2 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/exists.test @@ -0,0 +1,46 @@ +# -*- tcl -*- +# Graph tests - node existence +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: exists.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node exists NODE + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-exists-1.0 {node exists, wrong#args, missing} { + SETUP + catch {mygraph node exists} msg + mygraph destroy + set msg +} [tmWrong {node exists} node 0] + +test graph-${impl}-${setimpl}-node-exists-1.1 {node exists, wrong#args, too many} { + SETUP + catch {mygraph node exists 0 1} msg + mygraph destroy + set msg +} [tmTooMany {node exists} node] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-node-exists-2.0 {node exists} { + SETUP + set res {} + lappend res [mygraph node exists node1] + + mygraph node insert node1 + + lappend res [mygraph node exists node1] + + mygraph node delete node1 + + lappend res [mygraph node exists node1] + + mygraph destroy + set res +} {0 1 0} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/insert.test b/tcllib/modules/struct/graph/tests/node/insert.test new file mode 100644 index 0000000..6fa748e --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/insert.test @@ -0,0 +1,67 @@ +# -*- tcl -*- +# Graph tests - node insertion +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: insert.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node insert ?NODE...? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +# Impossible to have to have missing or too many arguments. +# Any number of new nodes is acceptable. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-insert-2.0 {node insert, duplicate node} { + SETUP + mygraph node insert node0 + catch {mygraph node insert node0} msg + mygraph destroy + set msg +} [ExistingNode $MY node0] + +# ------------------------------------------------------------------------- +# Ok arguments. None, single, multiple, defaults + +test graph-${impl}-${setimpl}-node-insert-3.0 {node insert, defaults} { + SETUP + mygraph node insert node0 + set result {} + lappend result [mygraph node exists node0] + lappend result [mygraph node getall node0] + lappend result [mygraph nodes -out node0] + lappend result [mygraph nodes -in node0] + mygraph destroy + set result +} {1 {} {} {}} + +test graph-${impl}-${setimpl}-node-insert-3.1 {node insert, auto-generation of name} { + SETUP + + # Note: The use of 'node3' for the explicit name tests that the + # name-generator will skip over existing names when it tries to + # come up with a new one. + + set result {} + lappend result [mygraph node insert] + lappend result [mygraph node insert] + mygraph node insert node3 + lappend result [mygraph node insert] + mygraph destroy + set result +} {node1 node2 node4} + +test graph-${impl}-${setimpl}-node-insert-3.2 {node insert, multiple} { + SETUP + mygraph node insert node0 node1 + set result {} + lappend result [mygraph node exists node0] + lappend result [mygraph node exists node1] + mygraph destroy + set result +} {1 1} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/opposite.test b/tcllib/modules/struct/graph/tests/node/opposite.test new file mode 100644 index 0000000..71b8aec --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/opposite.test @@ -0,0 +1,88 @@ +# -*- tcl -*- +# Graph tests - node opposite +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: opposite.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node opposite NODE ARC + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-opposite-1.0 {node opposite, wrong#args, missing} { + SETUP + catch {mygraph node opposite} msg + mygraph destroy + set msg +} [tmWrong {node opposite} {node arc} 0] + +test graph-${impl}-${setimpl}-node-opposite-1.1 {node opposite, wrong#args, missing} { + SETUP + catch {mygraph node opposite 0} msg + mygraph destroy + set msg +} [tmWrong {node opposite} {node arc} 1] + +test graph-${impl}-${setimpl}-node-opposite-1.2 {node opposite, wrong#args, too many} { + SETUP + catch {mygraph node opposite 0 1 2} msg + mygraph destroy + set msg +} [tmTooMany {node opposite} {node arc}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-opposite-2.1 {node opposite, missing node} { + SETUP + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} [MissingNode $MY node0] + +test graph-${impl}-${setimpl}-node-opposite-2.2 {node opposite, missing arc} { + SETUP + mygraph node insert node0 + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} [MissingArc $MY arc0] + +test graph-${impl}-${setimpl}-node-opposite-2.3 {node opposite, !adjacent node/arc} { + SETUP + mygraph node insert node0 node1 node2 + mygraph arc insert node1 node2 arc0 + + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} "node \"node0\" and arc \"arc0\" are not connected in graph \"$MY\"" + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-node-opposite-3.0 {node opposite, source|target} { + SETUP + mygraph node insert node0 node1 + mygraph arc insert node0 node1 arc0 + + set result {} + lappend result [mygraph node opposite node0 arc0] + lappend result [mygraph node opposite node1 arc0] + + mygraph destroy + set result +} {node1 node0} + +test graph-${impl}-${setimpl}-node-opposite-3.1 {node opposite, loop} { + SETUP + mygraph node insert node0 + mygraph arc insert node0 node0 arc0 + + set result [mygraph node opposite node0 arc0] + + mygraph destroy + set result +} {node0} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/node/rename.test b/tcllib/modules/struct/graph/tests/node/rename.test new file mode 100644 index 0000000..f9d2cdd --- /dev/null +++ b/tcllib/modules/struct/graph/tests/node/rename.test @@ -0,0 +1,106 @@ +# -*- tcl -*- +# Graph tests - node rename +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: rename.test,v 1.2 2007/04/12 03:01:56 andreas_kupries Exp $ + +# Syntax: graph node rename NODE NEW-NAME + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-node-rename-1.0 {node rename, wrong # args, missing} { + SETUP + catch {mygraph node rename} result + mygraph destroy + set result +} [tmWrong {node rename} {node newname} 0] + +test graph-${impl}-${setimpl}-node-rename-1.1 {node rename, wrong # args, missing} { + SETUP + catch {mygraph node rename foo} result + mygraph destroy + set result +} [tmWrong {node rename} {node newname} 1] + +test graph-${impl}-${setimpl}-node-rename-1.2 {node rename, wrong # args, too many} { + SETUP + catch {mygraph node rename foo far fox} result + mygraph destroy + set result +} [tmTooMany {node rename} {node newname}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-node-rename-2.0 {node rename, missing node} { + SETUP + catch {mygraph node rename 0 foo} result + mygraph destroy + set result +} [MissingNode $MY 0] + +test graph-${impl}-${setimpl}-node-rename-2.1 {node rename, duplicate target node} { + SETUP + mygraph node insert root 0 + catch {mygraph node rename root 0} result + mygraph destroy + set result +} [ExistingNode $MY 0] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-node-rename-3.0 {node rename, arc linkage} { + SETUP + + mygraph node insert 0 1 2 3 4 5 6 + mygraph arc insert 1 0 a + mygraph arc insert 2 0 b + mygraph arc insert 3 0 c + mygraph arc insert 0 4 d + mygraph arc insert 0 5 e + mygraph arc insert 0 6 f + + + set result {} + lappend result [mygraph node degree -in 0] + lappend result [mygraph node degree -out 0] + lappend result [mygraph node exists 0] + lappend result [mygraph node exists snarf] + lappend result [lsort [mygraph nodes -in 0]] + lappend result [lsort [mygraph nodes -out 0]] + + mygraph node rename 0 snarf + lappend result | + + lappend result [mygraph node degree -in snarf] + lappend result [mygraph node degree -out snarf] + lappend result [mygraph node exists 0] + lappend result [mygraph node exists snarf] + lappend result [lsort [mygraph nodes -in snarf]] + lappend result [lsort [mygraph nodes -out snarf]] + + mygraph destroy + set result +} {3 3 1 0 {1 2 3} {4 5 6} | 3 3 0 1 {1 2 3} {4 5 6}} + +test graph-${impl}-${setimpl}-node-rename-3.1 {node rename, attribute transfer} { + SETUP + mygraph node insert 0 + mygraph node set 0 data foo + + set result {} + lappend result [mygraph node getall 0] + lappend result [catch {mygraph node getall 5}] + + mygraph node rename 0 5 + + lappend result [mygraph node getall 5] + lappend result [catch {mygraph node getall 0}] + + mygraph destroy + set result +} {{data foo} 1 {data foo} 1} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/nodes.test b/tcllib/modules/struct/graph/tests/nodes.test new file mode 100644 index 0000000..4934073 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/nodes.test @@ -0,0 +1,313 @@ +# -*- tcl -*- +# Graph tests - nodes +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: nodes.test,v 1.3 2008/03/23 19:08:26 andreas_kupries Exp $ + +# Syntax: graph nodes +# (1) graph nodes -key KEY +# graph nodes -key KEY -value VALUE +# (2) graph nodes -filter CMDPREFIX +# (3) graph nodes -in NODE... +# graph nodes -out NODE... +# graph nodes -adj NODE... +# graph nodes -inner NODE... +# graph nodes -embedded NODE... + +# We can use one in each group (1,2,3) + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +# Cannot have missing arguments (zero is fine), +# except when switches are in use. That however +# is tested with the switches. Ditto for too many +# arguments. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-nodes-1.0 {nodes, bad switch} { + SETUP + catch {mygraph nodes -foo} msg + mygraph destroy + set msg +} {bad restriction "-foo": must be -adj, -embedding, -filter, -in, -inner, -key, -out, or -value} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-nodes-2.0 {nodes, empty graph} { + SETUP + set result [mygraph nodes] + mygraph destroy + set result +} {} + +test graph-${impl}-${setimpl}-nodes-2.1 {nodes} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [lsort [mygraph nodes]] + mygraph destroy + set result +} {0 1 2 3 4 5} + +# --------------------------------------------------- + +# (1) -key, -value +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-nodes-key-1.0 {nodes, wrong#args, missing} { + SETUP + catch {mygraph nodes -key} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY nodes ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +test graph-${impl}-${setimpl}-nodes-key-1.1 {nodes, wrong#args, missing} { + SETUP + catch {mygraph nodes -value} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY nodes ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-nodes-key-2.0 {nodes, multiple -key} { + SETUP + catch {mygraph nodes -key foobar -value 1 -key foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-key"} + +test graph-${impl}-${setimpl}-nodes-key-2.1 {nodes, multiple -value} { + SETUP + catch {mygraph nodes -key foobar -value 1 -value foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-value"} + +test graph-${impl}-${setimpl}-nodes-key-2.2 {nodes, -value without -key} { + SETUP + catch {mygraph nodes -value 1} msg + mygraph destroy + set msg +} {invalid restriction: use of "-value" without "-key"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-nodes-key-3.0 {nodes, -key} { + SETUP + mygraph node insert n0 n1 + mygraph node set n0 foobar 1 + mygraph node set n1 blubber 2 + + catch {mygraph nodes -key foobar} msg + mygraph destroy + set msg +} n0 + +test graph-${impl}-${setimpl}-nodes-key-3.1 {nodes, -key, -value} { + SETUP + mygraph node insert n0 n1 + mygraph node set n0 foobar 1 + mygraph node set n1 foobar 2 + + catch {mygraph nodes -key foobar -value 1} msg + mygraph destroy + set msg +} n0 + +# --------------------------------------------------- + +# (2) -filter +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-nodes-filter-1.0 {nodes, wrong#args, missing} { + SETUP + catch {mygraph nodes -filter} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY nodes ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-nodes-filter-2.0 {nodes, multiple -filter} { + SETUP + catch {mygraph nodes -filter foobar -filter foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-filter"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-nodes-filter-3.0 {nodes, -filter} { + SETUP + + mygraph node insert 1 2 3 4 5 6 + mygraph node set 1 volume 30 + mygraph node set 3 volume 50 + + proc vol {g n} { + $g node keyexists $n volume + } + + set result [lsort [mygraph nodes -filter vol]] + mygraph destroy + rename vol {} + + set result +} {1 3} + +test graph-${impl}-${setimpl}-nodes-filter-3.1 {nodes, -filter} { + SETUP + + mygraph node insert 1 2 3 4 5 6 + mygraph node set 1 volume 30 + mygraph node set 3 volume 50 + + proc vol {g n} { + if {![$g node keyexists $n volume]} {return 0} + expr {[$g node get $n volume] > 40} + } + + set result [mygraph nodes -filter vol] + mygraph destroy + rename vol {} + + set result +} 3 + +# --------------------------------------------------- + +# (3) -in, -out, -adj, -inner, -embedding +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +set n 0 +foreach switch {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-nodes-ioaie-1.$n "nodes, $switch, wrong#args, missing" { + SETUP + catch {mygraph nodes $switch} msg + mygraph destroy + set msg + } "wrong # args: should be \"$MY nodes ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" ; # {} + + incr n +} + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +set n 0 +foreach switch {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-nodes-ioaie-2.$n "nodes, $switch, missing node" { + SETUP + catch {mygraph nodes $switch x} msg + mygraph destroy + set msg + } [MissingNode $MY x] ; # {} + + incr n + + foreach switchB {-in -out -adj -inner -embedding} { + + test graph-${impl}-${setimpl}-nodes-ioaie-2.$n "nodes, $switch, $switchB together" { + SETUP + catch {mygraph nodes $switch $switchB x} msg + mygraph destroy + set msg + } {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} ; # {} + + incr n + } +} + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {switch nodes expected} { + -in {1 2 3} {1 2 3 4 5 6} -in {4 5 6} {} + -out {1 2 3} {1 2 3} -out {4 5 6} {1 2 3} + -adj {1 2 3} {1 2 3 4 5 6} -adj {4 5 6} {1 2 3} + -inner {1 2 3} {1 2 3} -inner {4 5 6} {} + -embedding {1 2 3} {4 5 6} -embedding {4 5 6} {1 2 3} + -in {1 2} {1 3 4 5} -in {4 5} {} + -out {1 2} {2 3} -out {4 5} {1 2} + -adj {1 2} {1 2 3 4 5} -adj {4 5} {1 2} + -inner {1 2} {1 2} -inner {4 5} {} + -embedding {1 2} {3 4 5} -embedding {4 5} {1 2} + -in {1} {3 4} -in {4} {} + -out {1} {2} -out {4} {1} + -adj {1} {2 3 4} -adj {4} {1} + -inner {1} {} -inner {4} {} + -embedding {1} {2 3 4} -embedding {4} {1} + -in {1 4} {3 4} -in {4 2} {1 5} + -out {1 4} {1 2} -out {4 2} {1 3} + -adj {1 4} {1 2 3 4} -adj {4 2} {1 3 5} + -inner {1 4} {1 4} -inner {4 2} {} + -embedding {1 4} {2 3} -embedding {4 2} {1 3 5} +} { + test graph-${impl}-${setimpl}-nodes-ioaie-3.$n "nodes, $switch" { + SETUP + + mygraph node insert 1 2 3 4 5 6 + mygraph arc insert 4 1 A + mygraph arc insert 5 2 B + mygraph arc insert 6 3 C + mygraph arc insert 3 1 D + mygraph arc insert 1 2 E + mygraph arc insert 2 3 F + + set result [lsort [eval [linsert $nodes 0 mygraph nodes $switch]]] + mygraph destroy + set result + } $expected ; # {} + + incr n +} + +# --------------------------------------------------- +# Test with many parallel arcs, beyond the number of nodes, i.e. lots +# of duplicates sources and destinations, to check that the dup +# removal works correctly. See bug [SF 1923685]. + +set n 0 +foreach {switch nodes expected} { + -in 2 1 + -out 2 3 + -adj 2 {1 3} + -inner {1 2 3} {1 2 3} + -embedding 2 {1 3} +} { + test graph-${impl}-${setimpl}-nodes-parallel-ioaie-bug1923685-4.$n "nodes, $switch, parallel arcs, bug 1923685" { + SETUP + + mygraph node insert 1 2 3 4 + mygraph arc insert 1 2 A ; mygraph arc insert 2 3 A. + mygraph arc insert 1 2 B ; mygraph arc insert 2 3 B. + mygraph arc insert 1 2 C ; mygraph arc insert 2 3 C. + mygraph arc insert 1 2 D ; mygraph arc insert 2 3 D. + mygraph arc insert 1 2 E ; mygraph arc insert 2 3 E. + mygraph arc insert 1 2 F ; mygraph arc insert 2 3 F. + mygraph arc insert 1 2 G ; mygraph arc insert 2 3 G. + mygraph arc insert 1 2 H ; mygraph arc insert 2 3 H. + + set result [lsort [eval [linsert $nodes 0 mygraph nodes $switch]]] + mygraph destroy + set result + } $expected ; # {} + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/adjlist.test b/tcllib/modules/struct/graph/tests/ops/adjlist.test new file mode 100644 index 0000000..ab135eb --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/adjlist.test @@ -0,0 +1,158 @@ +# -*- tcl -*- +#Adjacency List - Tests + +# Sort input into canonical form. +proc adjsort {dict} { + set res {} + foreach {k v} [dictsort $dict] { + lappend res $k [lsort -dict $v] + } + return $res +} + +#Test 1.0 - undirected but weighted graph containing some special cases +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.0 { AdjacencyList, undirected, unweighted, graph simulation } { + SETUP_ADJACENCYLIST_K4 + set result [struct::graph::op::toAdjacencyList mygraph] + mygraph destroy + set result +} "node1 {node2 node3 node4} node2 {node1 node3} node3 {node1 node2 node4} node4 {node1 node3}" + +#Test 1.1 - undirected but weighted graph containing some special cases +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.1 { AdjacencyList, undirected, weighted, graph simulation } { + SETUP_ADJACENCYLIST_K4_WEIGHTED + set result [struct::graph::op::toAdjacencyList mygraph -weights] + mygraph destroy + set result +} "node1 {{node2 1} {node3 1} {node4 1}} node2 {{node1 1} {node3 1}} node3 {{node1 1} {node2 1} {node4 1}} node4 {{node1 1} {node3 1}}" + +#Test 1.2 - directed, weighted graph with different wages at crucial edges ( e.g. edges between same nodes ) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.2 { AdjacencyList, directed, weighted, graph simulation } { + SETUP_ADJACENCYLIST_K4_WEIGHTED_DIRECTED + set result [adjsort [struct::graph::op::toAdjacencyList mygraph -directed -weights]] + mygraph destroy + set result +} {node1 {{node2 1} {node3 1} {node4 2}} node2 {{node3 1}} node3 {{node4 1}} node4 {{node1 3}}} + +#Test 1.3 - directed weighted graph, same us upper but changed order of options +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.3 { AdjacencyList, directed, weighted, graph simulation } { + SETUP_ADJACENCYLIST_K4_WEIGHTED_DIRECTED + set result [adjsort [struct::graph::op::toAdjacencyList mygraph -weights -directed]] + mygraph destroy + set result +} {node1 {{node2 1} {node3 1} {node4 2}} node2 {{node3 1}} node3 {{node4 1}} node4 {{node1 3}}} + +#Test 1.4 - directed but unweighted graph containing some special cases +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.4 { AdjacencyList, directed, unweighted, graph simulation } { + SETUP_ADJACENCYLIST_K4 + set result [adjsort [struct::graph::op::toAdjacencyList mygraph -directed]] + mygraph destroy + set result +} {node1 {node2 node3 node4} node2 node3 node3 node4 node4 node1} + +#Test 1.5 - case where graph has no edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.5 { AdjacencyList, no edges } { + SETUP_NOEDGES_1 + set result [struct::graph::op::toAdjacencyList mygraph] + mygraph destroy + set result +} "node1 {} node2 {} node3 {} node4 {}" + +#Test 1.6 - case where graph has no edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.6 { AdjacencyList, no edges } { + SETUP_NOEDGES_1 + set result [struct::graph::op::toAdjacencyList mygraph -directed -weights] + mygraph destroy + set result +} "node1 {} node2 {} node3 {} node4 {}" + +#Test 1.7 - another graph simulation for checking proper return value +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-1.7 { AdjacencyList, undirected, unweighted, graph simulation } { + SETUP_ADJACENCYLIST_1 + set result [struct::graph::op::toAdjacencyList mygraph] + mygraph destroy + set result +} "node1 {node2 node6} node2 {node1 node3} node3 {node2 node6} node4 {node5 node6} node5 node4 node6 {node1 node3 node4}" + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-2.0 { AdjacencyList, wrong args, missing } { + catch {struct::graph::op::toAdjacencyList} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::toAdjacencyList {G args} 0] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when given undirected graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.0 {AdjacencyList, undirected, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::toAdjacencyList mygraph -weights} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.1 - case when given directed graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.1 {AdjacencyList, directed, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::toAdjacencyList mygraph -directed -weights} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.2 - case when given undirected graph doesn't have weights at some edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.2 {AdjacencyList, undirected, partial lack of weights at edges } { + SETUP_PARTIALLYWEIGHTED_K4 + catch {struct::graph::op::toAdjacencyList mygraph -weights} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.3 - case when given directed graph doesn't have weights at some edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.3 {AdjacencyList, directed, partial lack of weights at edges } { + SETUP_PARTIALLYWEIGHTED_K4 + catch {struct::graph::op::toAdjacencyList mygraph -directed -weights} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.4 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.4 {AdjacencyList, bad option used } { + SETUP + catch {struct::graph::op::toAdjacencyList mygraph -badoption} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -directed or -weights} + +#Test 3.5 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.5 {AdjacencyList, bad options used } { + SETUP + catch {struct::graph::op::toAdjacencyList mygraph -directed -badoption} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -directed or -weights} + +#Test 3.6 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.6 {AdjacencyList, bad options used } { + SETUP + catch {struct::graph::op::toAdjacencyList mygraph -weights -badoption} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -directed or -weights} + +#Test 3.7 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.7 {AdjacencyList, bad options used } { + SETUP + catch {struct::graph::op::toAdjacencyList mygraph -badoption -directed} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -directed or -weights} + +#Test 3.8 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-AdjacencyList-3.8 {AdjacencyList, bad options used } { + SETUP + catch {struct::graph::op::toAdjacencyList mygraph -badoption -weights} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -directed or -weights} diff --git a/tcllib/modules/struct/graph/tests/ops/adjmatrix.test b/tcllib/modules/struct/graph/tests/ops/adjmatrix.test new file mode 100644 index 0000000..67f8fea --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/adjmatrix.test @@ -0,0 +1,69 @@ +# -*- tcl -*- +# Graph ops tests - Adjacency Matrix. +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: adjmatrix.test,v 1.5 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::toAdjacencyMatrix G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-1.0 {toAdjacencyMatrix, wrong args, missing} -body { + struct::graph::op::toAdjacencyMatrix +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::toAdjacencyMatrix {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-1.1 {toAdjacencyMatrix, wrong args, too many} -body { + struct::graph::op::toAdjacencyMatrix g x +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::toAdjacencyMatrix {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-2.0 {toAdjacencyMatrix, empty graph} -setup { + SETUP +} -body { + struct::graph::op::toAdjacencyMatrix mygraph +} -cleanup { + mygraph destroy +} -result {{{}}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-2.1 {toAdjacencyMatrix, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + struct::graph::op::toAdjacencyMatrix mygraph +} -cleanup { + mygraph destroy +} -result {{{} 0 1 2 3 4 5} {0 0 0 0 0 0 0} {1 0 0 0 0 0 0} {2 0 0 0 0 0 0} {3 0 0 0 0 0 0} {4 0 0 0 0 0 0} {5 0 0 0 0 0 0}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-2.2 {toAdjacencyMatrix, nodes, arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 + mygraph arc insert 0 1 a + mygraph arc insert 2 3 b + mygraph arc insert 4 5 c +} -body { + struct::graph::op::toAdjacencyMatrix mygraph +} -cleanup { + mygraph destroy +} -result {{{} 0 1 2 3 4 5} {0 0 1 0 0 0 0} {1 1 0 0 0 0 0} {2 0 0 0 1 0 0} {3 0 0 1 0 0 0} {4 0 0 0 0 0 1} {5 0 0 0 0 1 0}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-toAdjacencyMatrix-2.3 {toAdjacencyMatrix, nodes, parallel arcs, loops} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 + mygraph arc insert 0 1 a + mygraph arc insert 0 1 b + mygraph arc insert 2 3 c + mygraph arc insert 3 2 d + mygraph arc insert 4 4 e +} -body { + struct::graph::op::toAdjacencyMatrix mygraph +} -cleanup { + mygraph destroy +} -result {{{} 0 1 2 3 4 5} {0 0 1 0 0 0 0} {1 1 0 0 0 0 0} {2 0 0 0 1 0 0} {3 0 0 1 0 0 0} {4 0 0 0 0 1 0} {5 0 0 0 0 0 0}} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/bellmanford.test b/tcllib/modules/struct/graph/tests/ops/bellmanford.test new file mode 100644 index 0000000..706f9c5 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/bellmanford.test @@ -0,0 +1,137 @@ +# -*- tcl -*- +#Bellman-Ford's Algorithm - Tests +# +#Searching distances between selected node and all other nodes in graph. + +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + +#Tests 1.0 and 1.1 - couting right values for special cases of graphs +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.0 { BellmanFord, graph simulation } { + SETUP_BELLMANFORD_1 + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 1 node3 2 node4 3} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.1 { BellmanFord, graph simulation } { + SETUP_BELLMANFORD_2 + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 8 node3 5 node4 7 node5 3 node6 5} + +#Tests 1.2 - 1.4 - Test cases when there occur existance of cycle with negative sum of weights at edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.2 { BellmanFord, negative cycles } { + SETUP_NEGATIVECYCLE_1 + catch { struct::graph::op::BellmanFord mygraph node1 } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.3 { BellmanFord, negative cycles } { + SETUP_NEGATIVECYCLE_2 + catch { struct::graph::op::BellmanFord mygraph node1 } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.4 { BellmanFord, negative cycles } { + SETUP_NEGATIVECYCLE_3 + catch { struct::graph::op::BellmanFord mygraph node1 } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +#Test 1.5 - do the algorithm finds a proper solution for directed complete graph with one edge deleted? +#checking proper source - target relation +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.5 { BellmanFord, complete graph } { + SETUP_K4 + set result [dictsort [struct::graph::op::BellmanFord mygraph node4]] + mygraph destroy + set result +} {node1 2 node2 2 node3 3 node4 0} + +#Test 1.6 - coherent graph case, graph with startnode without edges pointing out, setting Inf values +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.6 { BellmanFord, uncoherence } { + SETUP_PARTIALLYCONNECTED_1 + set result [dictsort [struct::graph::op::BellmanFord mygraph node5]] + mygraph destroy + set result +} {node1 Inf node2 Inf node3 Inf node4 Inf node5 0} + +#Test 1.7 - case when we are given a graph without any edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.7 { BellmanFord, no edges } { + SETUP_NOEDGES_1 + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 Inf node3 Inf node4 Inf} + +#Test 1.8 - case when we are given a graph with all edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.8 { BellmanFord, all weights set to 0 } { + SETUP_ZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 0 node3 0 node4 0} + +#Test 1.9 - case when we are given a graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.9 { BellmanFord, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 0 node3 0 node4 1} + +#Test 1.10 - case when we are given a complete K4 graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-1.10 { BellmanFord, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::BellmanFord mygraph node1]] + mygraph destroy + set result +} {node1 0 node2 0 node3 0 node4 0} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-2.0 { BellmanFord, wrong args, missing } { + catch {struct::graph::op::BellmanFord} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BellmanFord {G startnode} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-2.1 { BellmanFord, wrong args, missing } { + catch {struct::graph::op::BellmanFord G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BellmanFord {G startnode} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-2.2 { BellmanFord, wrong args, too many} { + catch {struct::graph::op::BellmanFord G startnode x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::BellmanFord {G startnode}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when startnode doesn't exist in given graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-3.0 {BellmanFord, unexisting node } { + SETUP + catch {struct::graph::op::BellmanFord mygraph startnode} result + mygraph destroy + set result +} [MissingNode mygraph startnode] + +#Test 3.1 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-3.1 {BellmanFord, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::BellmanFord mygraph startnode} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.2 - case when given graph doesn't have weights at some edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BellmanFord-3.1 {BellmanFord, partial lack of weights at edges } { + SETUP_PARTIALLYWEIGHTED_K4 + catch {struct::graph::op::BellmanFord mygraph startnode} result + mygraph destroy + set result +} [UnweightedArcOccurance] diff --git a/tcllib/modules/struct/graph/tests/ops/bfs.test b/tcllib/modules/struct/graph/tests/ops/bfs.test new file mode 100644 index 0000000..2155c9f --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/bfs.test @@ -0,0 +1,204 @@ +# -*- tcl -*- +#Breadth-First Search procedures +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +# ------------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------------ +#Tests for shortest paths finding using BFS algorithm +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.0 { graph simulation } { + SETUP_BFS_1 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph s distances]] + mygraph destroy + set result +} {a 2 b 7 c 13 d 9 s 0 x 5} + +#Test 1.1 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.1 { graph simulation } { + SETUP_BFS_1 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph s paths]] + mygraph destroy + set result +} {a {s x} b {s x a} c {s x a b} d {s x a b} x s} + +#Test 1.2 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.2 { graph simulation } { + SETUP_BFS_2 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph s distances]] + mygraph destroy + set result +} {a 13 b 23 c 11 d 9 s 0 t 18} + +#Test 1.3 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.3 { graph simulation } { + SETUP_BFS_2 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph s paths]] + mygraph destroy + set result +} {a {s d} b {s d c t} c {s d} d s t {s d c}} + +#Test 1.4 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.4 { graph simulation } { + SETUP_BELLMANFORD_2 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph node1 distances]] + mygraph destroy + set result +} {node1 0 node2 8 node3 5 node4 7 node5 3 node6 5} + +#Test 1.5 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-1.5 { graph simulation } { + SETUP_BELLMANFORD_2 + set result [dictsort [struct::graph::op::ShortestsPathsByBFS mygraph node1 paths]] + mygraph destroy + set result +} {node2 node1 node3 {node1 node2 node4} node4 {node1 node2} node5 {node1 node2 node4 node3} node6 {node1 node2 node4 node3 node5}} + +#Tests for standard BFS Algorithm +#Test 1.6 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.6 { graph simulation } { + SETUP_BFS_2 + set solution [struct::graph::op::BFS mygraph s graph] + set result "[lsort [$solution nodes]] | [lsort [$solution arcs]]" + $solution destroy + mygraph destroy + set result +} [tmE \ + {a b c d s t | {a b} {c t} {d c} {s a} {s d}} \ + {a b c d s t | {a b} {a c} {b t} {s a} {s d}}] +# Tcl ordering: d,a | Both results are valid. +# C ordering: a,d | + +#Test 1.7 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.7 { graph simulation } { + SETUP_BFS_2 + set result [struct::graph::op::BFS mygraph s tree] + set tree {} + foreach node [$result nodes] { + lappend tree [list $node [lsort [$result children $node]]] + } + mygraph destroy + $result destroy + lsort $tree +} [tmE \ + {{a b} {b {}} {c t} {d c} {s {a d}} {t {}}} \ + {{a {b c}} {b t} {c {}} {d {}} {s {a d}} {t {}}}] +# See 1.6. + +#Test 1.8 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.8 { graph simulation } { + SETUP_MDST_1 + set solution [struct::graph::op::BFS mygraph d graph] + set result "[lsort [$solution nodes]] | [lsort [$solution arcs]]" + mygraph destroy + $solution destroy + set result +} [tmE \ + {a b c d e f g h i j | {b a} {d c} {d e} {d h} {e f} {e g} {g i} {h b} {h j}} \ + {a b c d e f g h i j | {b a} {c b} {c g} {d c} {d e} {d h} {e f} {g i} {h j}}] + +#Test 1.9 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.9 { graph simulation } { + SETUP_MDST_1 + set result [struct::graph::op::BFS mygraph d tree] + set tree {} + foreach node [$result nodes] { + lappend tree [list $node [lsort [$result children $node]]] + } + mygraph destroy + $result destroy + lsort $tree +} [tmE \ + {{a {}} {b a} {c {}} {d {c e h}} {e {f g}} {f {}} {g i} {h {b j}} {i {}} {j {}}} \ + {{a {}} {b a} {c {b g}} {d {c e h}} {e f} {f {}} {g i} {h j} {i {}} {j {}}}] + +#Test 1.10 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.10 { graph simulation } { + SETUP_BELLMANFORD_2 + set solution [struct::graph::op::BFS mygraph node1 graph] + set result "[lsort [$solution nodes]] | [lsort [$solution arcs]]" + mygraph destroy + $solution destroy + set result +} [tmE \ + {node1 node2 node3 node4 node5 node6 | {node1 node2} {node1 node3} {node2 node4} {node3 node5} {node4 node6}} \ + {node1 node2 node3 node4 node5 node6 | {node1 node2} {node1 node3} {node3 node4} {node3 node5} {node4 node6}}] + +#Test 1.11 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-1.11 { graph simulation } { + SETUP_BELLMANFORD_2 + set result [struct::graph::op::BFS mygraph node1 tree] + set tree {} + foreach node [$result nodes] { + lappend tree [list $node [lsort [$result children $node]]] + } + mygraph destroy + $result destroy + lsort $tree +} [tmE \ + {{node1 {node2 node3}} {node2 node4} {node3 node5} {node4 node6} {node5 {}} {node6 {}}} \ + {{node1 {node2 node3}} {node2 {}} {node3 {node4 node5}} {node4 node6} {node5 {}} {node6 {}}}] + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-2.0 { BFS, wrong args, missing } { + catch {struct::graph::op::ShortestsPathsByBFS} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::ShortestsPathsByBFS {G s outputFormat} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-2.1 { BFS, wrong args, missing } { + catch {struct::graph::op::ShortestsPathsByBFS G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::ShortestsPathsByBFS {G s outputFormat} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-2.2 { BFS, wrong args, missing } { + catch {struct::graph::op::ShortestsPathsByBFS G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::ShortestsPathsByBFS {G s outputFormat} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-2.3 { BFS, wrong args, too many} { + catch {struct::graph::op::ShortestsPathsByBFS G a b c} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::ShortestsPathsByBFS {G s outputFormat}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-2.4 { BFS, wrong args, missing } { + catch {struct::graph::op::BFS} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BFS {G s outputFormat} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-2.5 { BFS, wrong args, missing } { + catch {struct::graph::op::BFS G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BFS {G s outputFormat} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-2.6 { BFS, wrong args, missing } { + catch {struct::graph::op::BFS G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BFS {G s outputFormat} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-2.7 { BFS, wrong args, too many} { + catch {struct::graph::op::BFS G a b c} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::BFS {G s outputFormat}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-ShortestsPathsByBFS-3.0 { ShortestsPathsByBFS } { + SETUP + catch {struct::graph::op::ShortestsPathsByBFS mygraph s badOption} result + mygraph destroy + set result +} {Unknown output format "badOption", expected distances, or paths.} + +#Test 3.1 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BFS-3.1 { BFS } { + SETUP + catch {struct::graph::op::BFS mygraph s badOption} result + mygraph destroy + set result +} {Unknown output format "badOption", expected graph, or tree.} diff --git a/tcllib/modules/struct/graph/tests/ops/bipartite.test b/tcllib/modules/struct/graph/tests/ops/bipartite.test new file mode 100644 index 0000000..786e566 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/bipartite.test @@ -0,0 +1,147 @@ +# -*- tcl -*- +# Graph ops tests - Minimum spanning tree/forest per Bipartite +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: bipartite.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isBipartite? G ?partitionvar? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-1.0 {bipartite, wrong args, missing} -body { + struct::graph::op::isBipartite? +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::isBipartite? {g ?bipartitionvar?} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-1.1 {bipartite, wrong args, too many} -body { + struct::graph::op::isBipartite? g x y +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::isBipartite? {g ?bipartitionvar?}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.0 {bipartite, empty graph} -setup { + SETUP +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.1 {bipartite, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.2 {bipartite, no} -setup { + SETUP_D +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.3 {bipartite, yes} -setup { + SETUP_E +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.4 {bipartite, yes} -setup { + SETUP_F +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.5 {bipartite, yes} -setup { + SETUP_G +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-3.6 {bipartite, yes} -setup { + SETUP_C +} -body { + struct::graph::op::isBipartite? mygraph +} -cleanup { + mygraph destroy +} -result 1 + +# ------------------------------------------------------------------------- +# Ok arguments, get the partitions. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.0 {bipartite, empty graph} -setup { + SETUP + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + set result +} -cleanup { + mygraph destroy +} -result {{} {}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.1 {bipartite, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + bicanon $result +} -cleanup { + mygraph destroy +} -result {{} {0 1 2 3 4 5}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.3 {bipartite, yes} -setup { + SETUP_E + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + bicanon $result +} -cleanup { + mygraph destroy +} -result {{1b 2b 3b 4b 5b 6b 7b 8b} {1w 2w 3w 4w 5w 6w 7w 8w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.4 {bipartite, yes} -setup { + SETUP_F + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + bicanon $result +} -cleanup { + mygraph destroy +} -result {{1b 2b 3b 4b} {1w 2w 3w 4w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.5 {bipartite, yes} -setup { + SETUP_G + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + bicanon $result +} -cleanup { + mygraph destroy +} -result {{1b 2b 3b 4b 5b} {1w 2w 3w 4w 5w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-bipartite-4.6 {bipartite, yes} -setup { + SETUP_C + set result {} +} -body { + struct::graph::op::isBipartite? mygraph result + bicanon $result +} -cleanup { + mygraph destroy +} -result {{A D F} {B C E}} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/bridge.test b/tcllib/modules/struct/graph/tests/ops/bridge.test new file mode 100644 index 0000000..b84c1ab --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/bridge.test @@ -0,0 +1,75 @@ +# -*- tcl -*- +# Graph ops tests - Connected components II. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: bridge.test,v 1.3 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isBridge? G A + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-1.0 {isBridge?, wrong args, missing} { + catch {struct::graph::op::isBridge?} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isBridge? {g arc} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-1.1 {isBridge?, wrong args, missing} { + catch {struct::graph::op::isBridge? g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isBridge? {g arc} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-1.2 {isBridge?, wrong args, too many} { + catch {struct::graph::op::isBridge? g x y} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::isBridge? {g arc}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-2.0 {isBridge?, bad arc} { + SETUP + catch {struct::graph::op::isBridge? mygraph foo} result + mygraph destroy + set result +} {arc "foo" does not exist in graph "mygraph"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-3.1 {isBridge?} { + SETUP_A + set result [lsort -dict [struct::graph::op::isBridge? mygraph 'arc0_1']] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-3.2 {isBridge?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isBridge? mygraph bridge1]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-3.3 {isBridge?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isBridge? mygraph bridge2]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-3.4 {isBridge?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isBridge? mygraph bridge3]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isBridge?-3.5 {isBridge?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isBridge? mygraph nobridge]] + mygraph destroy + set result +} 0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/busackergowen.test b/tcllib/modules/struct/graph/tests/ops/busackergowen.test new file mode 100644 index 0000000..d83a638 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/busackergowen.test @@ -0,0 +1,157 @@ +# -*- tcl -*- +#Busacker-Gowen algorithm - computing maximum flow in a flow network +# +# + + +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +# ------------------------------------------------------------------------------------ +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.0 { graph simulation } { + SETUP_BUSACKERGOWEN_1 + set result [dictsort [struct::graph::op::BusackerGowen mygraph 25 s t]] + mygraph destroy + set result +} {{a b} 8 {a c} 10 {b t} 8 {c t} 17 {s a} 18 {s c} 7} + +#Test 1.1 - case considering when desired flow is equal to max flow +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.1 { graph simulation } { + SETUP_BUSACKERGOWEN_1 + set result [dictsort [struct::graph::op::BusackerGowen mygraph 31 s t]] + mygraph destroy + set result +} {{a b} 14 {b t} 14 {c a} 18 {c t} 17 {s a} 18 {s c} 13} + +#Test 1.2 - case considering when desired flow exceeds max flow - algorithm should end when +#there is no more paths between source and sink nodes. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.2 { graph simulation } { + SETUP_BUSACKERGOWEN_1 + set result [dictsort [struct::graph::op::BusackerGowen mygraph 40 s t]] + mygraph destroy + set result +} {{a b} 14 {b t} 14 {c a} 18 {c t} 17 {s a} 18 {s c} 13} + +#Test 1.3 - case when the are no paths between source and sink from the beginning +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.3 { graph simulation } { + SETUP_SOURCESINKNOPATHS + set result [struct::graph::op::BusackerGowen mygraph 1 s t] + mygraph destroy + set result +} {} + +#Test 1.4 - test for subprocedure that creates Augmenting Network +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.4 { createAugmentingNetwork, graph simulation } -setup { + SETUP_AUGMENTINGNETWORK_1 f path + set throughputs {} + set costs {} +} -body { + set result [struct::graph::op::createAugmentingNetwork mygraph $f $path] + set throughputs_arcs [$result arcs -key throughput] + set costs_arcs [$result arcs -key cost] + foreach t $throughputs_arcs c $costs_arcs { + dict set throughputs $t [$result arc set $t throughput] + dict set costs $c [$result arc set $c cost] + } + list [dictsort $throughputs] | [dictsort $costs] +} -cleanup { + unset costs throughputs f costs_arcs throughputs_arcs path t + mygraph destroy + $result destroy +} -result {{{a b} 20 {a c} 0 {a s} 15 {b t} 14 {c a} 15 {c b} 12 {c t} 2 {s a} 3 {s c} 20 {t c} 15} | {{a b} 5 {a c} Inf {a s} -3 {b t} 5 {c a} -4 {c b} 8 {c t} 3 {s a} 3 {s c} 8 {t c} -3}} + +#Test 1.5 - test for subprocedure that creates Augmenting Network +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.5 { createAugmentingNetwork, graph simulation } -setup { + SETUP_AUGMENTINGNETWORK_2 f path + set throughputs {} + set costs {} +} -body { + set result [struct::graph::op::createAugmentingNetwork mygraph $f $path] + set throughputs_arcs [$result arcs -key throughput] + set costs_arcs [$result arcs -key cost] + foreach t $throughputs_arcs c $costs_arcs { + dict set throughputs $t [$result arc set $t throughput] + dict set costs $c [$result arc set $c cost] + } + list [dictsort $throughputs] | [dictsort $costs] +} -cleanup { + unset costs throughputs f costs_arcs throughputs_arcs path t + mygraph destroy + $result destroy +} -result {{{a b} 20 {a c} 0 {a s} 15 {b t} 14 {c a} 15 {c b} 12 {c s} 2 {c t} 0 {s a} 3 {s c} 18 {t c} 17} | {{a b} 5 {a c} Inf {a s} -3 {b t} 5 {c a} -4 {c b} 8 {c s} -8 {c t} Inf {s a} 3 {s c} 8 {t c} -3}} + +#Test 1.6 - test for subprocedure that creates Augmenting Network +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-1.6 { createAugmentingNetwork, graph simulation } -setup { + SETUP_AUGMENTINGNETWORK_3 f path + set throughputs {} + set costs {} +} -body { + set result [struct::graph::op::createAugmentingNetwork mygraph $f $path] + set throughputs_arcs [$result arcs -key throughput] + set costs_arcs [$result arcs -key cost] + foreach t $throughputs_arcs c $costs_arcs { + dict set throughputs $t [$result arc set $t throughput] + dict set costs $c [$result arc set $c cost] + } + list [dictsort $throughputs] | [dictsort $costs] +} -cleanup { + unset costs throughputs f costs_arcs throughputs_arcs path t + mygraph destroy + $result destroy +} -result {{{a b} 17 {a c} 0 {a s} 18 {b a} 3 {b t} 11 {c a} 15 {c b} 12 {c s} 2 {c t} 0 {s a} 0 {s c} 18 {t b} 3 {t c} 17} | {{a b} 5 {a c} Inf {a s} -3 {b a} -5 {b t} 5 {c a} -4 {c b} 8 {c s} -8 {c t} Inf {s a} Inf {s c} 8 {t b} -5 {t c} -3}} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-2.0 { BusackerGowen, wrong args, missing } { + catch {struct::graph::op::BusackerGowen} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BusackerGowen {G desiredFlow s t} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-2.1 { BusackerGowen, wrong args, missing } { + catch {struct::graph::op::BusackerGowen G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BusackerGowen {G desiredFlow s t} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-2.2 { BusackerGowen, wrong args, missing } { + catch {struct::graph::op::BusackerGowen G desiredFlow} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BusackerGowen {G desiredFlow s t} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-2.3 { BusackerGowen, wrong args, too many} { + catch {struct::graph::op::BusackerGowen G desiredFlow c s t z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::BusackerGowen {G desiredFlow s t}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-2.4 { BusackerGowen, wrong args, missing } { + catch {struct::graph::op::BusackerGowen G desiredFlow s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BusackerGowen {G desiredFlow s t} 3] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when sink and source nodes given at input aren't nodes of input graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-3.0 {BusackerGowen, wrong sink or source } { + SETUP_BUSACKERGOWEN_1 + catch {struct::graph::op::BusackerGowen mygraph 25 x y } result + mygraph destroy + set result +} [LackOfSinkOrSource x y] + +#Test 3.1 - case when input network has lacking attributes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-3.1 {BusackerGowen, missing attributes } { + SETUP_BUSACKERGOWEN_2 + catch {struct::graph::op::BusackerGowen mygraph 25 s t } result + mygraph destroy + set result +} [WrongAttributes throughput cost] + +#Test 3.2 - case when wrong input value of desired flow is given at input +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BusackerGowen-3.2 {BusackerGowen, wrong input, desired flow } { + SETUP_BUSACKERGOWEN_1 + catch {struct::graph::op::BusackerGowen mygraph 0 s t } result + mygraph destroy + set result +} [WrongValueAtInput desiredFlow] diff --git a/tcllib/modules/struct/graph/tests/ops/christofides.test b/tcllib/modules/struct/graph/tests/ops/christofides.test new file mode 100644 index 0000000..fdb6124 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/christofides.test @@ -0,0 +1,58 @@ +# -*- tcl -*- +#Christofides Algorithm - Tests +# +#Finding Hamilton Cycle in a graph satisfying triangle inequality + +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 - Tight Example for Christofides algorithm +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-1.0 { Christofides, graph simulation } -setup { + SETUP_CHRISTO_1 +} -body { + toursort [struct::graph::op::Christofides mygraph] +} -cleanup { + mygraph destroy +} -result [tmE \ + {node1 node2 node3 node5 node7 node6 node4 node2 node1} \ + {node1 node2 node3 node4 node5 node7 node6 node4 node2 node1}] + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-2.0 { Christofides, wrong args, missing } { + catch {struct::graph::op::Christofides} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::Christofides {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-2.1 { Christofides, wrong args, too many} { + catch {struct::graph::op::Christofides G y x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::Christofides {G}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-3.0 {Christofides, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::Christofides mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.1 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-3.1 {Christofides, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::Christofides mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.2 - case when given graph is not a connected graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Christofides-3.2 { Christofides, unconnected graph } { + SETUP_NOEDGES_1 + catch { struct::graph::op::Christofides mygraph } result + mygraph destroy + set result +} [UnconnectedGraphOccurance {mygraph}] diff --git a/tcllib/modules/struct/graph/tests/ops/componentof.test b/tcllib/modules/struct/graph/tests/ops/componentof.test new file mode 100644 index 0000000..4a93be1 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/componentof.test @@ -0,0 +1,167 @@ +# -*- tcl -*- +# Graph ops tests - Connected components II. +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: componentof.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::connectedComponentOf G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-1.0 {connectedComponentOf, wrong args, missing} -body { + struct::graph::op::connectedComponentOf +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::connectedComponentOf {g n} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-1.1 {connectedComponentOf, wrong args, missing} -body { + struct::graph::op::connectedComponentOf g +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::connectedComponentOf {g n} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-1.2 {connectedComponentOf, wrong args, too many} -body { + struct::graph::op::connectedComponentOf g x y +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::connectedComponentOf {g n}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-2.0 {connectedComponentOf, bad node} -setup { + SETUP +} -body { + struct::graph::op::connectedComponentOf mygraph foo +} -cleanup { + mygraph destroy +} -returnCodes error -result {node "foo" does not exist in graph "mygraph"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.1 {connectedComponentOf, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 0] +} -cleanup { + mygraph destroy +} -result 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.2 {connectedComponentOf, single CC} -setup { + SETUP_A +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 'node5'] +} -cleanup { + mygraph destroy +} -result {'node0' 'node1' 'node2' 'node3' 'node4' 'node5' 'node6'} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.3 {connectedComponentOf, single CC} -setup { + SETUP_B +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph D] +} -cleanup { + mygraph destroy +} -result {A B C D E S} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.4 {connectedComponentOf, single CC} -setup { + SETUP_C +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph D] +} -cleanup { + mygraph destroy +} -result {A B C D E F} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.5 {connectedComponentOf, single CC} -setup { + SETUP_D +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph g] +} -cleanup { + mygraph destroy +} -result {a b c d f g h i j} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.6 {connectedComponentOf, single CC} -setup { + SETUP_E +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 5b] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b 3w 4b 4w 5b 5w 6b 6w 7b 7w 8b 8w} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.7 {connectedComponentOf, single CC} -setup { + SETUP_F +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 2w] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b 3w 4b 4w} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.8 {connectedComponentOf, single CC} -setup { + SETUP_G +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 3b] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b 3w 4b 4w 5b 5w} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.9 {connectedComponentOf, single CC} -setup { + SETUP_H +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph C] +} -cleanup { + mygraph destroy +} -result {A B C D E} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.10 {connectedComponentOf, single CC} -setup { + SETUP_I +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph N4] +} -cleanup { + mygraph destroy +} -result {N1 N2 N3 N4 N5} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.11.0 {connectedComponentOf, multiple CC} -setup { + SETUP_J +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 4] +} -cleanup { + mygraph destroy +} -result {1 4 5} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.11.1 {connectedComponentOf, multiple CC} -setup { + SETUP_J +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 2] +} -cleanup { + mygraph destroy +} -result 2 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.11.2 {connectedComponentOf, multiple CC} -setup { + SETUP_J +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 3] +} -cleanup { + mygraph destroy +} -result 3 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.11.3 {connectedComponentOf, multiple CC} -setup { + SETUP_J +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph 6] +} -cleanup { + mygraph destroy +} -result {6 7} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.12.0 {connectedComponentOf, multiple CC} -setup { + SETUP_K +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph No3] +} -cleanup { + mygraph destroy +} -result {No1 No2 No3 No4} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponentOf-3.12.1 {connectedComponentOf, multiple CC} -setup { + SETUP_K +} -body { + lsort -dict [struct::graph::op::connectedComponentOf mygraph No5] +} -cleanup { + mygraph destroy +} -result No5 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/components.test b/tcllib/modules/struct/graph/tests/ops/components.test new file mode 100644 index 0000000..c2776b0 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/components.test @@ -0,0 +1,131 @@ +# -*- tcl -*- +# Graph ops tests - Connected components. +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: components.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::connectedComponents G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-1.0 {connectedComponents, wrong args, missing} -body { + struct::graph::op::connectedComponents +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::connectedComponents {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-1.1 {connectedComponents, wrong args, too many} -body { + struct::graph::op::connectedComponents g x +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::connectedComponents {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.0 {connectedComponents, empty graph} -setup { + SETUP +} -body { + struct::graph::op::connectedComponents mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.1 {connectedComponents, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {0 1 2 3 4 5} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.2 {connectedComponents, single CC} -setup { + SETUP_A +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{'node0' 'node1' 'node2' 'node3' 'node4' 'node5' 'node6'}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.3 {connectedComponents, single CC} -setup { + SETUP_B +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{A B C D E S}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.4 {connectedComponents, single CC} -setup { + SETUP_C +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{A B C D E F}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.5 {connectedComponents, single CC} -setup { + SETUP_D +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{a b c d f g h i j}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.6 {connectedComponents, single CC} -setup { + SETUP_E +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{1b 1w 2b 2w 3b 3w 4b 4w 5b 5w 6b 6w 7b 7w 8b 8w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.7 {connectedComponents, single CC} -setup { + SETUP_F +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{1b 1w 2b 2w 3b 3w 4b 4w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.8 {connectedComponents, single CC} -setup { + SETUP_G +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{1b 1w 2b 2w 3b 3w 4b 4w 5b 5w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.9 {connectedComponents, single CC} -setup { + SETUP_H +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{A B C D E}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.10 {connectedComponents, single CC} -setup { + SETUP_I +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{N1 N2 N3 N4 N5}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.11 {connectedComponents, multiple CC} -setup { + SETUP_J +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{1 4 5} 2 3 {6 7}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-connectedComponents-3.12 {connectedComponents, multiple CC} -setup { + SETUP_K +} -body { + setsetcanon [struct::graph::op::connectedComponents mygraph] +} -cleanup { + mygraph destroy +} -result {{No1 No2 No3 No4} No5} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/connected.test b/tcllib/modules/struct/graph/tests/ops/connected.test new file mode 100644 index 0000000..d459636 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/connected.test @@ -0,0 +1,120 @@ +# -*- tcl -*- +# Graph ops tests - Connected components. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: connected.test,v 1.3 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isConnected? G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-1.0 {isConnected?, wrong args, missing} { + catch {struct::graph::op::isConnected?} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isConnected? {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-1.1 {isConnected?, wrong args, too many} { + catch {struct::graph::op::isConnected? g x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::isConnected? {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.0 {isConnected?, empty graph} { + SETUP + set result [struct::graph::op::isConnected? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.1 {isConnected?, nodes, no arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.2 {isConnected?, single CC} { + SETUP_A + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.3 {isConnected?, single CC} { + SETUP_B + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.4 {isConnected?, single CC} { + SETUP_C + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.5 {isConnected?, single CC} { + SETUP_D + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.6 {isConnected?, single CC} { + SETUP_E + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.7 {isConnected?, single CC} { + SETUP_F + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.8 {isConnected?, single CC} { + SETUP_G + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.9 {isConnected?, single CC} { + SETUP_H + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.10 {isConnected?, single CC} { + SETUP_I + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.11 {isConnected?, multiple CC} { + SETUP_J + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isConnected?-3.12 {isConnected?, multiple CC} { + SETUP_K + set result [setsetcanon [struct::graph::op::isConnected? mygraph]] + mygraph destroy + set result +} 0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/cutvertex.test b/tcllib/modules/struct/graph/tests/ops/cutvertex.test new file mode 100644 index 0000000..d501142 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/cutvertex.test @@ -0,0 +1,97 @@ +# -*- tcl -*- +# Graph ops tests - Connected components II. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: cutvertex.test,v 1.3 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isCutVertex? G N + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-1.0 {isCutVertex?, wrong args, missing} { + catch {struct::graph::op::isCutVertex?} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isCutVertex? {g n} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-1.1 {isCutVertex?, wrong args, missing} { + catch {struct::graph::op::isCutVertex? g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isCutVertex? {g n} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-1.2 {isCutVertex?, wrong args, too many} { + catch {struct::graph::op::isCutVertex? g x y} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::isCutVertex? {g n}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-2.0 {isCutVertex?, bad node} { + SETUP + catch {struct::graph::op::isCutVertex? mygraph foo} result + mygraph destroy + set result +} {node "foo" does not exist in graph "mygraph"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.1 {isCutVertex?, nodes, no arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 0]] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.2 {isCutVertex?} { + SETUP_A + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 'node0']] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 4w]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 4b]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 5w]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 5b]] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 2w]] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isCutVertex?-3.3 {isCutVertex?} { + SETUP_G + set result [lsort -dict [struct::graph::op::isCutVertex? mygraph 3b]] + mygraph destroy + set result +} 0 + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/diameter.test b/tcllib/modules/struct/graph/tests/ops/diameter.test new file mode 100644 index 0000000..606a5e6 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/diameter.test @@ -0,0 +1,45 @@ +# -*- tcl -*- +# Graph ops tests - Dijkstra, distances, diameter +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: diameter.test,v 1.2 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::diameter G ?options? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-diameter-1.0 {diameter, wrong args, missing} { + catch {struct::graph::op::diameter} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::diameter {g args} 0] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {setup diameter undiameter} { + SETUP_A Inf 8 + SETUP_B Inf 6 +} { + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-diameter-3.$n "diameter, $setup/$node, directed" { + $setup + set result [struct::graph::op::diameter mygraph -arcmode directed] + mygraph destroy + set result + } $diameter + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-diameter-4.$n "diameter, $setup/$node, undirected" { + $setup + set result [struct::graph::op::diameter mygraph -arcmode undirected] + mygraph destroy + set result + } $undiameter + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/dijkstra.test b/tcllib/modules/struct/graph/tests/ops/dijkstra.test new file mode 100644 index 0000000..e034a26 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/dijkstra.test @@ -0,0 +1,107 @@ +# -*- tcl -*- +# Graph ops tests - Node distances, Dijkstra's algorithm +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: dijkstra.test,v 1.3 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::dijkstra G N ?-arcmode undirected|directed? ?-outputformat tree/distances? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-1.0 {dijkstra, wrong args, missing} { + catch {struct::graph::op::dijkstra} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::dijkstra {g node args} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-1.1 {dijkstra, wrong args, missing} { + catch {struct::graph::op::dijkstra g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::dijkstra {g node args} 1] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-2.0 {dijkstra, bad node} { + SETUP + catch {struct::graph::op::dijkstra mygraph foo} result + mygraph destroy + set result +} {node "foo" does not exist in graph "mygraph"} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-2.1 {dijkstra, bad option} { + SETUPx + catch {struct::graph::op::dijkstra mygraph %0 -foo bar} result + mygraph destroy + set result +} {Bad option "-foo", expected one of "-arcmode" or "-outputformat"} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-2.2 {dijkstra, bad option value} { + SETUPx + catch {struct::graph::op::dijkstra mygraph %0 -arcmode bar} result + mygraph destroy + set result +} {Bad value for -arcmode, expected one of "directed" or "undirected"} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-2.3 {dijkstra, bad option value} { + SETUPx + catch {struct::graph::op::dijkstra mygraph %0 -outputformat bar} result + mygraph destroy + set result +} {Bad value for -outputformat, expected one of "distances" or "tree"} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-2.4 {dijkstra, bad option value} { + SETUP_A2 + catch {struct::graph::op::dijkstra mygraph 'node0'} result + mygraph destroy + set result +} {Operation invalid for graph with unweighted arcs.} + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {setup start distances tree undistances untree} { + SETUP_A 'node0' + {'node0' 0 'node1' 2 'node2' 3 'node3' 1 'node4' 3 'node5' 6 'node6' 5} + {'node0' 'node0' 'node1' 'node0' 'node2' {'node3' 'node0'} 'node3' 'node0' 'node4' {'node3' 'node0'} 'node5' {'node6' 'node3' 'node0'} 'node6' {'node3' 'node0'}} + {'node0' 0 'node1' 2 'node2' 3 'node3' 1 'node4' 3 'node5' 6 'node6' 5} + {'node0' 'node0' 'node1' 'node0' 'node2' {'node3' 'node0'} 'node3' 'node0' 'node4' {'node3' 'node0'} 'node5' {'node6' 'node3' 'node0'} 'node6' {'node3' 'node0'}} + SETUP_A 'node6' + {'node0' Inf 'node1' Inf 'node2' Inf 'node3' Inf 'node4' Inf 'node5' 1 'node6' 0} + {'node5' 'node6' 'node6' 'node6'} + {'node0' 5 'node1' 7 'node2' 6 'node3' 4 'node4' 6 'node5' 1 'node6' 0} + {'node0' {'node3' 'node6'} 'node1' {'node3' 'node6'} 'node2' {'node5' 'node6'} 'node3' 'node6' 'node4' 'node6' 'node5' 'node6' 'node6' 'node6'} +} { + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-3.$n "dijkstra, $setup/$start, distances/directed" { + $setup + set result [dictsort [struct::graph::op::dijkstra mygraph $start -arcmode directed -outputformat distances]] + mygraph destroy + set result + } $distances + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-4.$n "dijkstra, $setup/$start, tree/directed" { + $setup + set result [dictsort [struct::graph::op::dijkstra mygraph $start -arcmode directed -outputformat tree]] + mygraph destroy + set result + } $tree + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-5.$n "dijkstra, $setup/$start, distances/undirected" { + $setup + set result [dictsort [struct::graph::op::dijkstra mygraph $start -arcmode undirected -outputformat distances]] + mygraph destroy + set result + } $undistances + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-dijkstra-6.$n "dijkstra, $setup/$start, tree/undirected" { + $setup + set result [dictsort [struct::graph::op::dijkstra mygraph $start -arcmode undirected -outputformat tree]] + mygraph destroy + set result + } $untree + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/dinicblockingflow.test b/tcllib/modules/struct/graph/tests/ops/dinicblockingflow.test new file mode 100644 index 0000000..725b459 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/dinicblockingflow.test @@ -0,0 +1,70 @@ +# -*- tcl -*- +#Blocking flow by MKM - Tests +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-1.0 { graph simulation } { + SETUP_BLOCKINGFLOW_1 + set result [dictsort [struct::graph::op::BlockingFlowByDinic mygraph s t]] + mygraph destroy + set result +} {{s v1} 3 {s v3} 2 {v1 v2} 2 {v1 v4} 1 {v2 v5} 2 {v3 v4} 1 {v3 v6} 1 {v4 v5} 1 {v4 v7} 1 {v5 t} 3 {v6 v7} 1 {v7 t} 2} + +# {{v1 v4} 1 {v2 v5} 2 {v3 v4} 1 {v3 v6} 1 {v4 v5} 1 {v5 t} 3 {v4 v7} 1 {v7 t} 2 {v6 v7} 1 {s v1} 3 {s v3} 2 {v1 v2} 2} + +#Test 1.1 - case when input residual graph is created from network that hasn't any flows yet +#Tcl does a 4/6 split at 1, C does a 2/8 split at 1. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-1.1 { graph simulation } { + SETUP_MAXIMUMFLOW_1 + set result [dictsort [struct::graph::op::BlockingFlowByDinic mygraph s t]] + mygraph destroy + set result +} [tmE \ + {{s v1} 10 {s v2} 4 {v1 v3} 4 {v1 v4} 6 {v2 v4} 4 {v3 t} 4 {v4 t} 10} \ + {{s v1} 10 {s v2} 2 {v1 v3} 2 {v1 v4} 8 {v2 v4} 2 {v3 t} 2 {v4 t} 10}] + +#Test 1.2 - case when input residual graph is created from network that has already some flows used in it +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-1.2 { graph simulation } { + SETUP_BLOCKINGFLOW_2 + set result [dictsort [struct::graph::op::BlockingFlowByDinic mygraph s t]] + mygraph destroy + set result +} {{s v2} 5 {v2 v4} 5 {v3 t} 5 {v4 v3} 5} + +#Test 1.3 - case when from residual graph we get level graph with no arcs - the blocking flow is not found +#cause there are no paths between sink and source in residual graph. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-1.3 { graph simulation } { + SETUP_BLOCKINGFLOW_3 + set result [dictsort [struct::graph::op::BlockingFlowByDinic mygraph s t]] + mygraph destroy + set result +} {} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-2.0 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByDinic} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByDinic {G s t} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-2.1 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByDinic G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByDinic {G s t} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-2.2 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByDinic G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByDinic {G s t} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowDinic-2.3 { BlockingFlow, wrong args, too many} { + catch {struct::graph::op::BlockingFlowByDinic G y x z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::BlockingFlowByDinic {G s t}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + diff --git a/tcllib/modules/struct/graph/tests/ops/dinicmaximumflow.test b/tcllib/modules/struct/graph/tests/ops/dinicmaximumflow.test new file mode 100644 index 0000000..ce069ec --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/dinicmaximumflow.test @@ -0,0 +1,137 @@ +# -*- tcl -*- +#Dinic's algorithm for computing maximum flow in flow network - Tests +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.0 { graph simulation } { + SETUP_MAXIMUMFLOW_1 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t dinic]] + mygraph destroy + set result +} {{s v1} 10 {s v2} 9 {v1 v3} 4 {v1 v4} 6 {v2 v4} 9 {v3 t} 9 {v4 t} 10 {v4 v3} 5} + +#Test 1.1 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.1 { graph simulation } { + SETUP_MAXIMUMFLOW_1 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t mkm]] + mygraph destroy + set result +} {{s v1} 10 {s v2} 9 {v1 v3} 4 {v1 v4} 6 {v2 v4} 9 {v3 t} 9 {v4 t} 10 {v4 v3} 5} + +#Test 1.2 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.2 { graph simulation } { + SETUP_FORDFULKERSON_1 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t mkm]] + mygraph destroy + set result +} {{s v1} 12 {s v2} 11 {v1 v3} 12 {v2 v4} 11 {v3 t} 19 {v4 t} 4 {v4 v3} 7} + +#Test 1.3 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.3 { graph simulation } { + SETUP_FORDFULKERSON_2 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph a d mkm]] + mygraph destroy + set result +} {{a b} 1000000 {a c} 1000000 {b d} 1000000 {c d} 1000000} + +#Test 1.4 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.4 { graph simulation } { + SETUP_FORDFULKERSON_3 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t mkm]] + mygraph destroy + set result +} {{s v1} 6 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 3 {v2 t} 8 {v3 t} 3} + +#Test 1.5 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.5 { graph simulation } { + SETUP_FORDFULKERSON_4 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t mkm]] + mygraph destroy + set result +} {{s v1} 4 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 1 {v2 t} 6 {v3 t} 3} + +#Test 1.6 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.6 { graph simulation } { + SETUP_FORDFULKERSON_5 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t mkm]] + mygraph destroy + set result +} {{s v1} 6.5 {s v2} 5.5 {s v3} 3.5 {v1 t} 3.1 {v1 v2} 3.4000000000000004 {v2 t} 8.9 {v3 t} 3.5} + +#Test 1.7 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.7 { graph simulation } { + SETUP_FORDFULKERSON_1 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t dinic]] + mygraph destroy + set result +} {{s v1} 12 {s v2} 11 {v1 v3} 12 {v2 v4} 11 {v3 t} 19 {v4 t} 4 {v4 v3} 7} + +#Test 1.8 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.8 { graph simulation } { + SETUP_FORDFULKERSON_2 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph a d dinic]] + mygraph destroy + set result +} {{a b} 1000000 {a c} 1000000 {b d} 1000000 {c d} 1000000} + +#Test 1.9 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.9 { graph simulation } { + SETUP_FORDFULKERSON_3 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t dinic]] + mygraph destroy + set result +} {{s v1} 6 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 3 {v2 t} 8 {v3 t} 3} + +#Test 1.10 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.10 { graph simulation } { + SETUP_FORDFULKERSON_4 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t dinic]] + mygraph destroy + set result +} {{s v1} 4 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 1 {v2 t} 6 {v3 t} 3} + +#Test 1.11 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-1.11 { graph simulation } { + SETUP_FORDFULKERSON_5 + set result [dictsort [struct::graph::op::MaximumFlowByDinic mygraph s t dinic]] + mygraph destroy + set result +} {{s v1} 6.5 {s v2} 5.5 {s v3} 3.5 {v1 t} 3.1 {v1 v2} 3.4000000000000004 {v2 t} 8.9 {v3 t} 3.5} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-2.0 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::MaximumFlowByDinic} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-2.1 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::MaximumFlowByDinic G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-2.2 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::MaximumFlowByDinic G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-2.3 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::MaximumFlowByDinic G s t} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} 3] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-2.4 { BlockingFlow, wrong args, too many} { + catch {struct::graph::op::MaximumFlowByDinic G a b c d} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-DinicMaximumFlow-3.0 { bad value of blocking flow algorithm variable } { + catch {struct::graph::op::MaximumFlowByDinic G s t blockingFlowAlg} msg + set msg +} "Uncorrect name of blocking flow algorithm. Choose \"mkm\" for Malhotra, Kumar and Maheshwari algorithm and \"dinic\" for Dinic algorithm." diff --git a/tcllib/modules/struct/graph/tests/ops/distance.test b/tcllib/modules/struct/graph/tests/ops/distance.test new file mode 100644 index 0000000..7317238 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/distance.test @@ -0,0 +1,70 @@ +# -*- tcl -*- +# Graph ops tests - Dijkstra, distances +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: distance.test,v 1.2 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::distance G N N' ?options? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-1.0 {distance, wrong args, missing} { + catch {struct::graph::op::distance} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::distance {g origin destination args} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-1.1 {distance, wrong args, missing} { + catch {struct::graph::op::distance g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::distance {g origin destination args} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-1.2 {distance, wrong args, missing} { + catch {struct::graph::op::distance g o} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::distance {g origin destination args} 2] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-2.0 {distance, bad node} { + SETUP + catch {struct::graph::op::distance mygraph foo bar} result + mygraph destroy + set result +} {node "foo" does not exist in graph "mygraph"} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-2.1 {distance, bad node} { + SETUP + mygraph node insert foo + catch {struct::graph::op::distance mygraph foo bar} result + mygraph destroy + set result +} {node "bar" does not exist in graph "mygraph"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {setup origin destination distance undistance} { + SETUP_A 'node0' 'node6' 5 5 + SETUP_A 'node0' 'node0' 0 0 +} { + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-3.$n "distance, $setup/$origin/$destination, directed" { + $setup + set result [struct::graph::op::distance mygraph $origin $destination -arcmode directed] + mygraph destroy + set result + } $distance + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-distance-4.$n "distance, $setup/$origin/$destination, undirected" { + $setup + set result [struct::graph::op::distance mygraph $origin $destination -arcmode undirected] + mygraph destroy + set result + } $undistance + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/eccentricity.test b/tcllib/modules/struct/graph/tests/ops/eccentricity.test new file mode 100644 index 0000000..939d7c2 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/eccentricity.test @@ -0,0 +1,57 @@ +# -*- tcl -*- +# Graph ops tests - Dijkstra, distances, eccentricity. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: eccentricity.test,v 1.2 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::eccentricity G N ?options? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-eccentricity-1.0 {eccentricity, wrong args, missing} { + catch {struct::graph::op::eccentricity} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::eccentricity {g node args} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-eccentricity-1.1 {eccentricity, wrong args, missing} { + catch {struct::graph::op::eccentricity g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::eccentricity {g node args} 1] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-eccentricity-2.0 {eccentricity, bad node} { + SETUP + catch {struct::graph::op::eccentricity mygraph foo} result + mygraph destroy + set result +} {node "foo" does not exist in graph "mygraph"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {setup node eccentricity uneccentricity} { + SETUP_A 'node0' 6 6 + SETUP_A 'node6' Inf 7 +} { + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-eccentricity-3.$n "eccentricity, $setup/$node, directed" { + $setup + set result [struct::graph::op::eccentricity mygraph $node -arcmode directed] + mygraph destroy + set result + } $eccentricity + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-eccentricity-4.$n "eccentricity, $setup/$node, undirected" { + $setup + set result [struct::graph::op::eccentricity mygraph $node -arcmode undirected] + mygraph destroy + set result + } $uneccentricity + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/edmondskarp.test b/tcllib/modules/struct/graph/tests/ops/edmondskarp.test new file mode 100644 index 0000000..d01fbca --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/edmondskarp.test @@ -0,0 +1,195 @@ +# -*- tcl -*- +#Edmonds Karp algorithm - computing maximum flow in a flow network +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +# ------------------------------------------------------------------------------------ +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.0 { graph simulation } { + SETUP_FORDFULKERSON_1 + set result [dictsort [struct::graph::op::FordFulkerson mygraph s t]] + mygraph destroy + set result +} {{s v1} 12 {s v2} 11 {v1 v3} 12 {v2 v4} 11 {v3 t} 19 {v4 t} 4 {v4 v3} 7} + +#Test 1.1 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.1 { graph simulation } { + SETUP_FORDFULKERSON_2 + set result [dictsort [struct::graph::op::FordFulkerson mygraph a d]] + mygraph destroy + set result +} {{a b} 1000000 {a c} 1000000 {b d} 1000000 {c d} 1000000} + +#Test 1.2 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.2 { graph simulation } { + SETUP_FORDFULKERSON_3 + set result [dictsort [struct::graph::op::FordFulkerson mygraph s t]] + mygraph destroy + set result +} {{s v1} 6 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 3 {v2 t} 8 {v3 t} 3} + +#Test 1.3 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.3 { graph simulation } { + SETUP_FORDFULKERSON_4 + set result [dictsort [struct::graph::op::FordFulkerson mygraph s t]] + mygraph destroy + set result +} {{s v1} 4 {s v2} 5 {s v3} 3 {v1 t} 3 {v1 v2} 1 {v2 t} 6 {v3 t} 3} + +#Test 1.4 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.4 { graph simulation } { + SETUP_FORDFULKERSON_5 + set result [dictsort [struct::graph::op::FordFulkerson mygraph s t]] + mygraph destroy + set result +} {{s v1} 6.5 {s v2} 5.5 {s v3} 3.5 {v1 t} 3.1 {v1 v2} 3.4000000000000004 {v2 t} 8.9 {v3 t} 3.5} + +#Test 1.5 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.5 { graph simulation } -setup { + SETUP_FORDFULKERSON_1 + set output {} + foreach arc [mygraph arcs] { + set u [mygraph arc source $arc] + set v [mygraph arc target $arc] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } +} -body { + set result [struct::graph::op::createResidualGraph mygraph $f] + foreach arc [$result arcs] { + set throughput [$result arc get $arc throughput] + if { $throughput } { + dict set output $arc $throughput + } + } + dictsort $output +} -cleanup { + unset throughput output f arc u v + $result destroy + mygraph destroy +} -result {{s v1} 16 {s v2} 13 {v1 v2} 10 {v1 v3} 12 {v2 v1} 4 {v2 v4} 14 {v3 t} 20 {v3 v2} 9 {v4 t} 4 {v4 v3} 7} + +#Test 1.6 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.6 { graph simulation } -setup { + SETUP_FORDFULKERSON_1 + set output {} + set f [SETUP_FLOWS_1 mygraph] +} -body { + set result [struct::graph::op::createResidualGraph mygraph $f] + foreach arc [$result arcs] { + set throughput [$result arc get $arc throughput] + if { $throughput } { + dict set output $arc $throughput + } + } + dictsort $output +} -cleanup { + unset throughput output f arc + $result destroy + mygraph destroy +} -result {{s v1} 12 {s v2} 13 {t v4} 4 {v1 s} 4 {v1 v2} 10 {v1 v3} 8 {v2 v1} 4 {v2 v3} 4 {v2 v4} 10 {v3 t} 20 {v3 v1} 4 {v3 v2} 5 {v4 v2} 4 {v4 v3} 7} + +#Test 1.7 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.7 { graph simulation } -setup { + SETUP_FORDFULKERSON_1 + set output {} + set f [SETUP_FLOWS_2 mygraph] +} -body { + set result [struct::graph::op::createResidualGraph mygraph $f] + foreach arc [$result arcs] { + set throughput [$result arc get $arc throughput] + if { $throughput } { + dict set output $arc $throughput + } + } + dictsort $output +} -cleanup { + unset throughput output f arc + $result destroy + mygraph destroy +} -result {{s v1} 5 {s v2} 13 {t v3} 7 {t v4} 4 {v1 s} 11 {v1 v2} 3 {v1 v3} 8 {v2 v1} 11 {v2 v3} 4 {v2 v4} 3 {v3 t} 13 {v3 v1} 4 {v3 v2} 5 {v3 v4} 7 {v4 v2} 11} + +#Test 1.8 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.8 { graph simulation } -setup { + SETUP_FORDFULKERSON_1 + set output {} + set f [SETUP_FLOWS_3 mygraph] +} -body { + set result [struct::graph::op::createResidualGraph mygraph $f] + foreach arc [$result arcs] { + set throughput [$result arc get $arc throughput] + if { $throughput } { + dict set output $arc $throughput + } + } + dictsort $output +} -cleanup { + unset throughput output f arc + $result destroy + mygraph destroy +} -result {{s v1} 5 {s v2} 5 {t v3} 15 {t v4} 4 {v1 s} 11 {v1 v2} 11 {v2 s} 8 {v2 v1} 3 {v2 v3} 4 {v2 v4} 3 {v3 t} 5 {v3 v1} 12 {v3 v2} 5 {v3 v4} 7 {v4 v2} 11} + +#Test 1.9 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-1.9 { graph simulation } -setup { + SETUP_FORDFULKERSON_1 + set output {} + set f [SETUP_FLOWS_4 mygraph] +} -body { + set result [struct::graph::op::createResidualGraph mygraph $f] + foreach arc [$result arcs] { + set throughput [$result arc get $arc throughput] + if { $throughput } { + dict set output $arc $throughput + } + } + dictsort $output +} -cleanup { + unset throughput output f arc + $result destroy + mygraph destroy +} -result {{s v1} 5 {s v2} 1 {t v3} 19 {t v4} 4 {v1 s} 11 {v1 v2} 11 {v2 s} 12 {v2 v1} 3 {v2 v4} 3 {v3 t} 1 {v3 v1} 12 {v3 v2} 9 {v3 v4} 7 {v4 v2} 11} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-2.0 { FordFulkerson, wrong args, missing } { + catch {struct::graph::op::FordFulkerson} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::FordFulkerson {G s t} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-2.1 { FordFulkerson, wrong args, missing } { + catch {struct::graph::op::FordFulkerson G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::FordFulkerson {G s t} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-2.2 { FordFulkerson, wrong args, missing } { + catch {struct::graph::op::FordFulkerson G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::FordFulkerson {G s t} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-2.3 { FordFulkerson, wrong args, too many} { + catch {struct::graph::op::FordFulkerson G s t z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::FordFulkerson {G s t}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when sink and source nodes given at input aren't nodes of input graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-3.0 {FordFulkerson, wrong sink or source } { + SETUP_FORDFULKERSON_1 + catch {struct::graph::op::FordFulkerson mygraph a b } result + mygraph destroy + set result +} [LackOfSinkOrSource a b] + +#Test 3.1 - case when input network has lacking attributes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FordFulkerson-3.1 {FordFulkerson, missing attributes } { + SETUP_BUSACKERGOWEN_2 + catch {struct::graph::op::FordFulkerson mygraph s t } result + mygraph destroy + set result +} [WrongAttributes throughput] + diff --git a/tcllib/modules/struct/graph/tests/ops/eulerpath.test b/tcllib/modules/struct/graph/tests/ops/eulerpath.test new file mode 100644 index 0000000..1ddcdff --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/eulerpath.test @@ -0,0 +1,215 @@ +# -*- tcl -*- +# Graph ops tests - Euler tours. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: eulerpath.test,v 1.4 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isSemiEulerian? G A + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many +if 0 { +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-1.0 {isSemiEulerian?, wrong args, missing} { + catch {struct::graph::op::isSemiEulerian?} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isSemiEulerian? {g ?eulervar?} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-1.1 {isSemiEulerian?, wrong args, too many} { + catch {struct::graph::op::isSemiEulerian? g x y} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::isSemiEulerian? {g ?eulervar?}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.0 {isSemiEulerian?, empty graph} { + SETUP + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.1 {isSemiEulerian?, nodes, no arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.2 {isSemiEulerian?} { + SETUP_A + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.3 {isSemiEulerian?} { + SETUP_B + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.4 {isSemiEulerian?} { + SETUP_B2 + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.5 {isSemiEulerian?} { + SETUP_C + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.6 {isSemiEulerian?} { + SETUP_D + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.7 {isSemiEulerian?} { + SETUP_E + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.8 {isSemiEulerian?} { + SETUP_F + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.9 {isSemiEulerian?} { + SETUP_G + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.10 {isSemiEulerian?} { + SETUP_H + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.11 {isSemiEulerian?} { + SETUP_I + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.12 {isSemiEulerian?} { + SETUP_J + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.13 {isSemiEulerian?} { + SETUP_K + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.14 {isSemiEulerian?} { + SETUP_K2 + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.15 {isSemiEulerian?} { + SETUP_L + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.16 {isSemiEulerian?} { + SETUP_M + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-3.17 {isSemiEulerian?} { + SETUP_N + set result [struct::graph::op::isSemiEulerian? mygraph] + mygraph destroy + set result +} 1 + +# --------------------------------------------------- + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.3 {isSemiEulerian?, and path} { + SETUP_B + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.4 {isSemiEulerian?, and path} { + SETUP_B2 + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} +} +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.5 {isSemiEulerian?, and path} -setup { + SETUP_C +} -body { + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + set result +} -cleanup { + mygraph destroy +} -result {1 ok} +if 0 { +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.10 {isSemiEulerian?, and path} { + SETUP_H + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.14 {isSemiEulerian?, and path} { + SETUP_K2 + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.16 {isSemiEulerian?, and path} { + SETUP_M + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isSemiEulerian?-4.17 {isSemiEulerian?, and path} { + SETUP_N + set result [struct::graph::op::isSemiEulerian? mygraph path] + lappend result [EulerPath mygraph $path] + mygraph destroy + set result +} {1 ok} +} +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/eulertour.test b/tcllib/modules/struct/graph/tests/ops/eulertour.test new file mode 100644 index 0000000..cfada68 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/eulertour.test @@ -0,0 +1,189 @@ +# -*- tcl -*- +# Graph ops tests - Euler tours. +# Copyright (c) 2008-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: eulertour.test,v 1.4 2009/09/21 23:48:03 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isEulerian? G A + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-1.0 {isEulerian?, wrong args, missing} { + catch {struct::graph::op::isEulerian?} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::isEulerian? {g ?eulervar? ?tourstart?} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-1.1 {isEulerian?, wrong args, too many} { + catch {struct::graph::op::isEulerian? g x y z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::isEulerian? {g ?eulervar? ?tourstart?}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.0 {isEulerian?, empty graph} { + SETUP + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.1 {isEulerian?, nodes, no arcs} { + SETUP + mygraph node insert 0 1 2 3 4 5 + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.2 {isEulerian?} { + SETUP_A + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.3 {isEulerian?} { + SETUP_B + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.4 {isEulerian?} { + SETUP_B2 + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.5 {isEulerian?} { + SETUP_C + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.6 {isEulerian?} { + SETUP_D + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.7 {isEulerian?} { + SETUP_E + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.8 {isEulerian?} { + SETUP_F + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.9 {isEulerian?} { + SETUP_G + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.10 {isEulerian?} { + SETUP_H + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.11 {isEulerian?} { + SETUP_I + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.12 {isEulerian?} { + SETUP_J + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.13 {isEulerian?} { + SETUP_K + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.14 {isEulerian?} { + SETUP_K2 + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.15 {isEulerian?} { + SETUP_L + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 0 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.16 {isEulerian?} { + SETUP_M + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 1 + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.17 {isEulerian?} { + SETUP_N + set result [struct::graph::op::isEulerian? mygraph] + mygraph destroy + set result +} 1 + +# --------------------------------------------------- + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-4.4 {isEulerian?, and tour} { + SETUP_B2 + set result [struct::graph::op::isEulerian? mygraph tour] + lappend result [EulerTour mygraph $tour] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-4.14 {isEulerian?, and tour} { + SETUP_K2 + set result [struct::graph::op::isEulerian? mygraph tour] + lappend result [EulerTour mygraph $tour] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-3.16 {isEulerian?, and tour} { + SETUP_M + set result [struct::graph::op::isEulerian? mygraph tour] + lappend result [EulerTour mygraph $tour] + mygraph destroy + set result +} {1 ok} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-isEulerian?-4.17 {isEulerian?, and tour} { + SETUP_N + set result [struct::graph::op::isEulerian? mygraph tour] + lappend result [EulerTour mygraph $tour] + mygraph destroy + set result +} {1 ok} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/floydwarshall.test b/tcllib/modules/struct/graph/tests/ops/floydwarshall.test new file mode 100644 index 0000000..cf103a9 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/floydwarshall.test @@ -0,0 +1,124 @@ +# -*- tcl -*- +#Floyd-Warshall's Algorithm - Tests +# +#Searching distances between all nodes. + +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + +#Test 1.0 - special case for pathfinding algorithm. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.0 { FloydWarshall, graph simulation } { + SETUP_BELLMANFORD_1 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 1 {node1 node3} 2 {node1 node4} 3 {node2 node1} 3 {node2 node2} 0 {node2 node3} 1 {node2 node4} 2 {node3 node1} 2 {node3 node2} 3 {node3 node3} 0 {node3 node4} 1 {node4 node1} 1 {node4 node2} 2 {node4 node3} 3 {node4 node4} 0} + +#Tests 1.1 - 1.3 - Test cases when there occur existance of cycle with negative sum of weights at edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.1 { FloydWarshall, negative cycles } { + SETUP_NEGATIVECYCLE_1 + catch { struct::graph::op::FloydWarshall mygraph} result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.2 { FloydWarshall, negative cycles } { + SETUP_NEGATIVECYCLE_2 + catch { struct::graph::op::FloydWarshall mygraph } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.3 { FloydWarshall, negative cycles } { + SETUP_NEGATIVECYCLE_3 + catch { struct::graph::op::FloydWarshall mygraph } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +#Test 1.4 - case when we are given a graph without any edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.4 { FloydWarshall, no edges } { + SETUP_NOEDGES_1 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} Inf {node1 node3} Inf {node1 node4} Inf {node2 node1} Inf {node2 node2} 0 {node2 node3} Inf {node2 node4} Inf {node3 node1} Inf {node3 node2} Inf {node3 node3} 0 {node3 node4} Inf {node4 node1} Inf {node4 node2} Inf {node4 node3} Inf {node4 node4} 0} + +#Test 1.5 - case when we are given a graph with all edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.5 { FloydWarshall, all weights set to 0 } { + SETUP_ZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 0 {node1 node3} 0 {node1 node4} 0 {node2 node1} 0 {node2 node2} 0 {node2 node3} 0 {node2 node4} 0 {node3 node1} 0 {node3 node2} 0 {node3 node3} 0 {node3 node4} 0 {node4 node1} 0 {node4 node2} 0 {node4 node3} 0 {node4 node4} 0} + +#Test 1.6 - case when we are given a graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.6 { FloydWarshall, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 0 {node1 node3} 0 {node1 node4} 1 {node2 node1} 2 {node2 node2} 0 {node2 node3} 0 {node2 node4} 1 {node3 node1} 2 {node3 node2} 2 {node3 node3} 0 {node3 node4} 1 {node4 node1} 1 {node4 node2} 1 {node4 node3} 1 {node4 node4} 0} + +#Test 1.7 - case when we are given a complete K4 graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.7 { FloydWarshall, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 0 {node1 node3} 0 {node1 node4} 0 {node2 node1} 0 {node2 node2} 0 {node2 node3} 0 {node2 node4} 0 {node3 node1} 0 {node3 node2} 0 {node3 node3} 0 {node3 node4} 0 {node4 node1} 0 {node4 node2} 0 {node4 node3} 0 {node4 node4} 0} + +#Tests 1.8 - 1.10 - counting right values for special cases of graphs +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.8 { FloydWarshall, graph simulation } { + SETUP_JOHNSONS_1 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} -4 {node1 node3} 1 {node1 node4} -1 {node1 node5} 3 {node2 node1} 4 {node2 node2} 0 {node2 node3} 5 {node2 node4} 3 {node2 node5} 7 {node3 node1} -1 {node3 node2} -5 {node3 node3} 0 {node3 node4} -2 {node3 node5} 2 {node4 node1} 5 {node4 node2} 1 {node4 node3} 6 {node4 node4} 0 {node4 node5} 8 {node5 node1} 1 {node5 node2} -3 {node5 node3} 2 {node5 node4} -4 {node5 node5} 0} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.9 { FloydWarshall, graph simulation } { + SETUP_JOHNSONS_2 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 8 {node1 node3} 7 {node1 node4} 5 {node1 node5} 3 {node1 node6} 5 {node2 node1} Inf {node2 node2} 0 {node2 node3} -1 {node2 node4} -3 {node2 node5} -5 {node2 node6} -3 {node3 node1} Inf {node3 node2} 1 {node3 node3} 0 {node3 node4} -2 {node3 node5} -4 {node3 node6} -2 {node4 node1} Inf {node4 node2} Inf {node4 node3} Inf {node4 node4} 0 {node4 node5} Inf {node4 node6} Inf {node5 node1} Inf {node5 node2} Inf {node5 node3} Inf {node5 node4} 2 {node5 node5} 0 {node5 node6} Inf {node6 node1} Inf {node6 node2} 3 {node6 node3} 2 {node6 node4} 0 {node6 node5} -2 {node6 node6} 0} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-1.10 { FloydWarshall, graph simulation } { + SETUP_BELLMANFORD_2 + set result [dictsort [struct::graph::op::FloydWarshall mygraph]] + mygraph destroy + set result +} {{node1 node1} 0 {node1 node2} 8 {node1 node3} 5 {node1 node4} 7 {node1 node5} 3 {node1 node6} 5 {node2 node1} Inf {node2 node2} 0 {node2 node3} -3 {node2 node4} -1 {node2 node5} -5 {node2 node6} -3 {node3 node1} Inf {node3 node2} 3 {node3 node3} 0 {node3 node4} 2 {node3 node5} -2 {node3 node6} 0 {node4 node1} Inf {node4 node2} 1 {node4 node3} -2 {node4 node4} 0 {node4 node5} -4 {node4 node6} -2 {node5 node1} Inf {node5 node2} Inf {node5 node3} Inf {node5 node4} Inf {node5 node5} 0 {node5 node6} 2 {node6 node1} Inf {node6 node2} Inf {node6 node3} Inf {node6 node4} Inf {node6 node5} Inf {node6 node6} 0} +# + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-2.0 { FloydWarshall, wrong args, missing } { + catch {struct::graph::op::FloydWarshall} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::FloydWarshall {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-2.1 { FloydWarshall, wrong args, too many} { + catch {struct::graph::op::FloydWarshall G y x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::FloydWarshall {G}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-3.0 {FloydWarshall, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::FloydWarshall mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.1 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-FloydWarshall-3.1 {FloydWarshall, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::FloydWarshall mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] diff --git a/tcllib/modules/struct/graph/tests/ops/johnsons.test b/tcllib/modules/struct/graph/tests/ops/johnsons.test new file mode 100644 index 0000000..8a19d8b --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/johnsons.test @@ -0,0 +1,130 @@ +# -*- tcl -*- +#Johnson's Algorithm - Tests +# +#Searching distances between all pairs of nodes + +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + + +#Tests 1.0 and 1.1 - couting right values for special cases of graphs +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.0 { Johnsons, graph simulation } { + SETUP_JOHNSONS_1 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} -4 {node1 node3} 1 {node1 node4} -1 {node1 node5} 3 {node2 node1} 4 {node2 node3} 5 {node2 node4} 3 {node2 node5} 7 {node3 node1} -1 {node3 node2} -5 {node3 node4} -2 {node3 node5} 2 {node4 node1} 5 {node4 node2} 1 {node4 node3} 6 {node4 node5} 8 {node5 node1} 1 {node5 node2} -3 {node5 node3} 2 {node5 node4} -4} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.1 { Johnsons, graph simulation } { + SETUP_JOHNSONS_2 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} 8 {node1 node3} 7 {node1 node4} 5 {node1 node5} 3 {node1 node6} 5 {node2 node1} Inf {node2 node3} -1 {node2 node4} -3 {node2 node5} -5 {node2 node6} -3 {node3 node1} Inf {node3 node2} 1 {node3 node4} -2 {node3 node5} -4 {node3 node6} -2 {node4 node1} Inf {node4 node2} Inf {node4 node3} Inf {node4 node5} Inf {node4 node6} Inf {node5 node1} Inf {node5 node2} Inf {node5 node3} Inf {node5 node4} 2 {node5 node6} Inf {node6 node1} Inf {node6 node2} 3 {node6 node3} 2 {node6 node4} 0 {node6 node5} -2} + +#Tests 1.2 and 1.3 - based on the same graphs as previous tests but checking the return value when using option -cutdisplay +#1.2 - cutting from return value 'Inf' ( returned when connection between two nodes doesn't exist ) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.2 { Johnsons, graph simulation, cutted display} { + SETUP_JOHNSONS_2 + set result [dictsort [struct::graph::op::Johnsons mygraph -filter]] + mygraph destroy + set result +} {{node1 node2} 8 {node1 node3} 7 {node1 node4} 5 {node1 node5} 3 {node1 node6} 5 {node2 node3} -1 {node2 node4} -3 {node2 node5} -5 {node2 node6} -3 {node3 node2} 1 {node3 node4} -2 {node3 node5} -4 {node3 node6} -2 {node5 node4} 2 {node6 node2} 3 {node6 node3} 2 {node6 node4} 0 {node6 node5} -2} + +#1.3 - case when there are no 'Inf' values and we use -cutdisplay option. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.3 { Johnsons, graph simulation, cutted display } { + SETUP_JOHNSONS_1 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} -4 {node1 node3} 1 {node1 node4} -1 {node1 node5} 3 {node2 node1} 4 {node2 node3} 5 {node2 node4} 3 {node2 node5} 7 {node3 node1} -1 {node3 node2} -5 {node3 node4} -2 {node3 node5} 2 {node4 node1} 5 {node4 node2} 1 {node4 node3} 6 {node4 node5} 8 {node5 node1} 1 {node5 node2} -3 {node5 node3} 2 {node5 node4} -4} + +#Tests 1.4 - 1.6 - Test cases when there occur existance of cycle with negative sum of weights at edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.4 { Johnsons, negative cycles } { + SETUP_NEGATIVECYCLE_1 + catch { struct::graph::op::Johnsons mygraph } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.5 { Johnsons, negative cycles } { + SETUP_NEGATIVECYCLE_2 + catch { struct::graph::op::Johnsons mygraph } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.6 { Johnsons, negative cycles } { + SETUP_NEGATIVECYCLE_3 + catch { struct::graph::op::Johnsons mygraph } result + mygraph destroy + set result +} [NegativeCycleOccurance {mygraph}] + +#Test 1.7 - case when we are given a graph without any edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.7 { Johnsons, no edges } { + SETUP_NOEDGES_1 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} Inf {node1 node3} Inf {node1 node4} Inf {node2 node1} Inf {node2 node3} Inf {node2 node4} Inf {node3 node1} Inf {node3 node2} Inf {node3 node4} Inf {node4 node1} Inf {node4 node2} Inf {node4 node3} Inf} + +#Test 1.8 - case when we are given a graph with all edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.8 { Johnsons, all weights set to 0 } { + SETUP_ZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} 0 {node1 node3} 0 {node1 node4} 0 {node2 node1} 0 {node2 node3} 0 {node2 node4} 0 {node3 node1} 0 {node3 node2} 0 {node3 node4} 0 {node4 node1} 0 {node4 node2} 0 {node4 node3} 0} + +#Test 1.9 - case when we are given a graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.9 { Johnsons, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} 0 {node1 node3} 0 {node1 node4} 1 {node2 node1} 2 {node2 node3} 0 {node2 node4} 1 {node3 node1} 2 {node3 node2} 2 {node3 node4} 1 {node4 node1} 1 {node4 node2} 1 {node4 node3} 1} + +#Test 1.10 - case when we are given a complete K4 graph with some edge's weights set to 0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-1.10 { Johnsons, some weights set to 0 } { + SETUP_PARTIALLYZEROWEIGHTED_K4 + set result [dictsort [struct::graph::op::Johnsons mygraph]] + mygraph destroy + set result +} {{node1 node2} 0 {node1 node3} 0 {node1 node4} 0 {node2 node1} 0 {node2 node3} 0 {node2 node4} 0 {node3 node1} 0 {node3 node2} 0 {node3 node4} 0 {node4 node1} 0 {node4 node2} 0 {node4 node3} 0} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-2.0 { Johnsons, wrong args, missing } { + catch {struct::graph::op::Johnsons} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::Johnsons {G args} 0] + + +# ------------------------------------------------------------------------- +# Logical arguments checks, failures and unproper graphs handling + +#Test 3.0 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-3.0 {Johnsons, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::Johnsons mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.1 - case when user sets wrong option to the procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-3.1 {Johnsons, bad option used } { + SETUP + catch {struct::graph::op::Johnsons mygraph -badoption} result + mygraph destroy + set result +} {Bad option "-badoption". Expected -filter} + +#Test 3.2 - case when given graph doesn't have weights at some edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-Johnsons-3.2 {Johnsons, partial lack of weights at edges } { + SETUP_PARTIALLYWEIGHTED_K4 + catch {struct::graph::op::Johnsons mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] diff --git a/tcllib/modules/struct/graph/tests/ops/kcenter.test b/tcllib/modules/struct/graph/tests/ops/kcenter.test new file mode 100644 index 0000000..66b2104 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/kcenter.test @@ -0,0 +1,179 @@ +# -*- tcl -*- +#Metric K-Center - Tests +# +#Set of tests includes also tests for subprocedures used by Unweighted Metric K-Center Algorithm: +#- Max Independent Set +#- Two Squared graph - create and extend. + +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.0 { Independent Set, 24 nodes graph } { + SETUP_INDEPENDENTSET_1 + set result [ismaxindependentset mygraph \ + [struct::graph::op::GreedyMaxIndependentSet mygraph]] + mygraph destroy + set result +} 1 +#{node5 node7 node9 node11 node13 node14 node15 node16} + +#Test 1.1 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.1 { Independent Set, complete K4 } { + SETUP_UNWEIGHTED_K4 + set result [ismaxindependentset mygraph \ + [struct::graph::op::GreedyMaxIndependentSet mygraph]] + mygraph destroy + set result +} 1 + +#Test 1.2 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.2 { Independent Set, C5 } { + SETUP_C5 + set result [ismaxindependentset mygraph \ + [struct::graph::op::GreedyMaxIndependentSet mygraph]] + mygraph destroy + set result +} 1 + +#Test 1.3 - Tight Example for K-Center, it chooses external node (with biggest adjacent edge weight = 2) +#when it's possible to choose central node ( with each adjacent edge weight = 1) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.3 { KCenter, Tight Example } { + # Note: Applied to non-complete graph, violating algorithm pre-conditions. + SETUP_KCENTER_1 + set result [lsort -dict [struct::graph::op::UnweightedKCenter mygraph 1]] + mygraph destroy + set result +} [tmE {node2} {node1}] + +#Test 1.4 - different k value +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.4 { KCenter, Tight Example } { + # Note: Applied to non-complete graph, violating algorithm pre-conditions. + SETUP_KCENTER_1 + set result [lsort -dict [struct::graph::op::UnweightedKCenter mygraph 2]] + mygraph destroy + set result +} [tmE {node2 node6} {node1 node2}] + +#Test 1.5 - case with max logical k value for that graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.5 { KCenter, Tight Example } { + # Note: Applied to non-complete graph, violating algorithm pre-conditions. + SETUP_KCENTER_1 + set result [lsort -dict [struct::graph::op::UnweightedKCenter mygraph 6]] + mygraph destroy + set result +} [tmE \ + {node2 node3 node4 node5 node6 node7} \ + {node1 node2 node3 node4 node5 node6}] + +#Test 1.6 - case when k is inexplicably big +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.6 { KCenter, Tight Example } { + # Note: Applied to non-complete graph, violating algorithm pre-conditions. + SETUP_KCENTER_1 + set result [lsort -dict [struct::graph::op::UnweightedKCenter mygraph 60]] + mygraph destroy + set result +} [tmE \ + {node2 node3 node4 node5 node6 node7} \ + {node1 node2 node3 node4 node5 node6}] + +#Test 1.7 - another graph test +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.7 { KCenter, graph simulation } { + SETUP_KCENTER_2 + set result [lsort -dict [struct::graph::op::UnweightedKCenter mygraph 2]] + mygraph destroy + set result +} [tmE {node2 node7} {node1 node8}] + +#Tests 1.8 - 1.12 - test cases for creating squared graphs operations +#Test 1.8 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.8 { KCenter, graph simulation } { + SETUP_TWOSQUARED_1 + set solution [struct::graph::op::createSquaredGraph mygraph] + set result [lsort -dict [undirected [$solution arcs]]] + $solution destroy + mygraph destroy + set result +} {{node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node2 node5} {node3 node4} {node3 node5} {node3 node6} {node3 node7} {node4 node5} {node5 node6} {node5 node7} {node5 node8} {node6 node7} {node7 node8}} + +#Test 1.9 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.9 { KCenter, graph simulation } { + SETUP_TWOSQUARED_2 + set solution [struct::graph::op::createSquaredGraph mygraph] + set result [lsort -dict [undirected [$solution arcs]]] + $solution destroy + mygraph destroy + set result +} {{node1 node2} {node1 node3} {node2 node3} {node2 node4} {node3 node4} {node3 node5} {node4 node5}} + +#Test 1.10 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.10 { KCenter, graph simulation } { + SETUP_TWOSQUARED_2 + SETUP_TWOSQUARED_3 + set solution [struct::graph::op::extendTwoSquaredGraph mygraph2 mygraph node4 node5] + set result [lsort -dict [undirected [$solution arcs]]] + mygraph destroy + mygraph2 destroy + set result +} {{node1 node2} {node1 node3} {node2 node3} {node2 node4} {node3 node4} {node3 node5} {node4 node5}} + +#Test 1.11 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.11 { KCenter, graph simulation } { + SETUP_TWOSQUARED_1 + mygraph arc delete "node3 node5" + SETUP_TWOSQUARED_4 + set solution [struct::graph::op::extendTwoSquaredGraph mygraph2 mygraph node3 node4] + set result [lsort -dict [undirected [$solution arcs]]] + mygraph destroy + mygraph2 destroy + set result +} {{node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node3 node4} {node5 node6} {node5 node7} {node5 node8} {node6 node7} {node7 node8}} + +#Test 1.12 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-1.12 { KCenter, graph simulation } { + SETUP_TWOSQUARED_1 + SETUP_TWOSQUARED_4 + set solution [struct::graph::op::extendTwoSquaredGraph mygraph2 mygraph node3 node5] + set result [lsort -dict [undirected [$solution arcs]]] + mygraph destroy + mygraph2 destroy + set result +} {{node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node2 node5} {node3 node4} {node3 node5} {node3 node6} {node3 node7} {node4 node5} {node5 node6} {node5 node7} {node5 node8} {node6 node7} {node7 node8}} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-2.0 { KCenter, wrong args, missing } { + catch {struct::graph::op::UnweightedKCenter} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::UnweightedKCenter {G k} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-2.1 { KCenter, wrong args, missing } { + catch {struct::graph::op::UnweightedKCenter G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::UnweightedKCenter {G k} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-2.2 { KCenter, wrong args, too many} { + catch {struct::graph::op::UnweightedKCenter G y x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::UnweightedKCenter {G k}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + + +#Test 3.1 - case when k is too low +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-3.0 { KCenter, wrong input } { + SETUP_KCENTER_1 + catch { struct::graph::op::UnweightedKCenter mygraph 0 } result + mygraph destroy + set result +} [WrongValueAtInput {k}] + +#Test 3.0 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-KCenter-3.1 {KCenter, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::UnweightedKCenter mygraph k} result + mygraph destroy + set result +} [UnweightedArcOccurance] diff --git a/tcllib/modules/struct/graph/tests/ops/kruskal.test b/tcllib/modules/struct/graph/tests/ops/kruskal.test new file mode 100644 index 0000000..fccee12 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/kruskal.test @@ -0,0 +1,59 @@ +# -*- tcl -*- +# Graph ops tests - Minimum spanning tree/forest per Kruskal +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: kruskal.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::kruskal G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-1.0 {kruskal, wrong args, missing} -body { + struct::graph::op::kruskal +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::kruskal {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-1.1 {kruskal, wrong args, too many} -body { + struct::graph::op::kruskal g x +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::kruskal {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-2.0 {kruskal, arcs without weights} -setup { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a +} -body { + struct::graph::op::kruskal mygraph +} -returnCodes error -result {Operation invalid for graph with unweighted arcs.} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-3.0 {kruskal, empty graph} -setup { + SETUP +} -body { + struct::graph::op::kruskal mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-3.1 {kruskal, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + struct::graph::op::kruskal mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-kruskal-3.2 {kruskal, nodes, arcs} -setup { + SETUP_A +} -body { + lsort -dict [struct::graph::op::kruskal mygraph] +} -cleanup { + mygraph destroy +} -result {'arc0_1' 'arc0_3' 'arc3_2' 'arc3_4' 'arc3_6' 'arc6_5'} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/maxcut.test b/tcllib/modules/struct/graph/tests/ops/maxcut.test new file mode 100644 index 0000000..ecf9f77 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/maxcut.test @@ -0,0 +1,138 @@ +# -*-tcl -*- +#Maximum Cut - Tests +# +#Searches for such division into two sets of nodes in graph G, that the amount of +#edges linking both sets is as big as possible. + +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + +#Test 1.0 - Tight Example - goes right -> ALG = OPT +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.0 { MaxCut, Tight Example } { + SETUP_MAXCUT_1 + set result [list [struct::graph::op::MaxCut mygraph U V] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {4 {node1 node3} {node2 node4}} + +#Test 1.1 - Tight Example - goes wrong -> ALG = 2 * OPT +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.1 { MaxCut, Tight Example } { + SETUP_MAXCUT_2 + set result [list [struct::graph::op::MaxCut mygraph U V] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {2 {node1 node3} {node2 node4}} + +#Test 1.2 - Another graph case for testing finding proper solution +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.2 { MaxCut, graph simulation } { + SETUP_MAXCUT_3 + set result [list [struct::graph::op::MaxCut mygraph U V] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {7 {node1 node4 node5} {node2 node3 node6}} + +#Test 1.3 - Another graph case for testing finding proper solution +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.3 { MaxCut, graph simulation } { + SETUP_MAXCUT_4 + set result [list [struct::graph::op::MaxCut mygraph U V] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {9 {node1 node3 node5} {node2 node4 node6}} + +#Test 1.4 - Graph 1.4 with another order of nodes - algorithm is mistaken by one. +# Note: This is strongly influenced by the ordering of nodes in +# results of commands like '$g nodes ...'. The tcl implementation has +# a node ordering which demonstrates the algorithm running into a +# local optimum. The critcl implementation uses different node +# ordering and returns the optimal cut. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.4a { MaxCut, graph simulation } { + SETUP_MAXCUT_5 + set result [list [struct::graph::op::MaxCut mygraph U V] [lsort $U] [lsort $V]] + mygraph destroy + set result +} [tmE \ + {8 {node1 node2 node5 node6} {node3 node4}} \ + {9 {node2 node3 node6} {node1 node4 node5}}] + +#Test 1.5 - Testing subprocedure countEdges - edges only between sets +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.5 { countEdges, graph simulation } { + SETUP_COUNTEDGES_1 U V + set result [struct::graph::op::countEdges mygraph $U $V] + mygraph destroy + set result +} 4 + +#Test 1.6 - Testing subprocedure countEdges - edges not only between sets +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.6 { countEdges, graph simulation } { + SETUP_COUNTEDGES_2 U V + set result [struct::graph::op::countEdges mygraph $U $V] + mygraph destroy + set result +} 4 + +#Test 1.7 - Testing subprocedure countEdges - no edges between sets +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.7 { countEdges, graph simulation } { + SETUP_COUNTEDGES_3 U V + set result [struct::graph::op::countEdges mygraph $U $V] + mygraph destroy + set result +} 0 + +#Test 1.8 - Testing subprocedure countEdges - mixed node sets U and V +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.8 { countEdges, graph simulation } { + SETUP_COUNTEDGES_4 U V + set result [struct::graph::op::countEdges mygraph $U $V] + mygraph destroy + set result +} 5 + +#Test 1.9 - Testing subprocedure cut - solution found +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.9 { cut, graph simulation } { + SETUP_CUT_1 U V param + set result [list [struct::graph::op::cut mygraph U V $param] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {0 {node1 node4 node5} {node2 node3 node6}} + +#Test 1.10 - Testing subprocedure cut - better solution possible to find +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-1.10 { cut, graph simulation } { + SETUP_CUT_2 U V param + set result [list [struct::graph::op::cut mygraph U V $param] [lsort $U] [lsort $V]] + mygraph destroy + set result +} {7 {node1 node4 node5} {node2 node3 node6}} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-2.0 { MaxCut, wrong args, missing } { + catch {struct::graph::op::MaxCut} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaxCut {G U V} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-2.1 { MaxCut, wrong args, missing } { + catch {struct::graph::op::MaxCut G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaxCut {G U V} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-2.2 { MaxCut, wrong args, missing } { + catch {struct::graph::op::MaxCut G U} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MaxCut {G U V} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-2.3 { MaxCut, wrong args, too many } { + catch {struct::graph::op::MaxCut G U V x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::MaxCut {G U V}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when given graph doesn't have edges at all +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MaxCut-3.0 { MaxCut, no edges } { + SETUP_NOEDGES_1 + set result [struct::graph::op::MaxCut mygraph U V] + mygraph destroy + set result +} 0 + diff --git a/tcllib/modules/struct/graph/tests/ops/maxmatching.test b/tcllib/modules/struct/graph/tests/ops/maxmatching.test new file mode 100644 index 0000000..054e081 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/maxmatching.test @@ -0,0 +1,137 @@ +# -*- tcl -*- +# Graph ops tests - Maximal matchings from bi-partitions. +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: maxmatching.test,v 1.3 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::isBipartite? G ?partitionvar? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-1.0 {max matching, wrong args, missing} { + catch {struct::graph::op::maxMatching} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::maxMatching {g X Y} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-1.1 {max matching, wrong args, missing} { + catch {struct::graph::op::maxMatching g} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::maxMatching {g X Y} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-1.2 {max matching, wrong args, missing} { + catch {struct::graph::op::maxMatching g x} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::maxMatching {g X Y} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-1.3 {max matching, wrong args, too many} { + catch {struct::graph::op::maxMatching g x y z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::maxMatching {g X Y}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-2.0 {max matching, bad bi-partition} knownBug { + SETUP_E + set result {} + struct::graph::op::isBipartite? mygraph result + foreach {A B} $result break + lappend A [lindex $B 0] ; # force intersection + catch {struct::graph::op::maxMatching mygraph $A $B} result + mygraph destroy + set result +} {Not a bi-partition} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-2.1 {max matching, bad bi-partition} knownBug { + SETUP_E + set result {} + struct::graph::op::isBipartite? mygraph result + foreach {A B} $result break + set A [lreplace $A end end] ; # force partial coverage + catch {struct::graph::op::maxMatching mygraph $A $B} result + mygraph destroy + set result +} {Not a bi-partition} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-2.2 {max matching, bad bi-partition} knownBug { + SETUP_E + set result {} + struct::graph::op::isBipartite? mygraph result + foreach {A B} $result break + lappend A bogus ; # force bogus node outside of graph + catch {struct::graph::op::maxMatching mygraph $A $B} result + mygraph destroy + set result +} {Not a bi-partition} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-2.3 {max matching, bad bi-partition} knownBug { + SETUP_E + set result {} + struct::graph::op::isBipartite? mygraph result + foreach {A B} $result break + mygraph arc insert [lindex $A 0] [lindex $A 1] ; # force arc violating bipart condition + catch {struct::graph::op::maxMatching mygraph $A $B} result + mygraph destroy + set result +} {Not a bi-partition} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.0 {max matching, empty graph} knownBug { + SETUP + set result {} + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.1 {max matching, nodes, no arcs} knownBug { + SETUP + set result {} + mygraph node insert 0 1 2 3 4 5 + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.3 {max matching} knownBug { + SETUP_E + set result {} + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.4 {max matching} knownBug { + SETUP_F + set result {} + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.5 {max matching} knownBug { + SETUP_G + set result {} + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-maxmatch-3.6 {max matching} knownBug { + SETUP_C + set result {} + struct::graph::op::isBipartite? mygraph result + set result [lsort -dict [struct::graph::op::maxMatching mygraph [lindex $result 0] [lindex $result 1]]] + mygraph destroy + set result +} {} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/mdst.test b/tcllib/modules/struct/graph/tests/ops/mdst.test new file mode 100644 index 0000000..12737d4 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/mdst.test @@ -0,0 +1,131 @@ +# -*- tcl -*- +#Tests for Spanning Tree Problems +#1) Minimum Degree Spanning Tree +#2) Minimum Diameter Spanning Tree +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +# ------------------------------------------------------------------------------------ +#Minimum Diameter Spanning Tree Tests +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-1.0 { graph simulation } { + SETUP_MDST_1 + set solution [struct::graph::op::MinimumDiameterSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} {{a b c d e f g h i j} {{a b} {b c} {c d} {c g} {d e} {d h} {e f} {g i} {h j}}} + +#Test 1.1 - case when given graph is a spanning tree already +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-1.1 { graph simulation } { + SETUP_MDST_3 + set solution [struct::graph::op::MinimumDiameterSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} {{a b c d e} {{a b} {b c} {c d} {d e}}} + +#Test 1.2 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-1.2 { graph simulation } { + SETUP_MDST_4 + set solution [struct::graph::op::MinimumDiameterSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} [tmE \ + {{a b c d e f g} {{a b} {b c} {c d} {d e} {d g} {e f}}} \ + {{a b c d e f g} {{a b} {b c} {c d} {d e} {d g} {f g}}}] + +#Test 1.3 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-1.3 { graph simulation } { + SETUP_MDST_5 + set solution [struct::graph::op::MinimumDiameterSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} {{a b c d e} {{a c} {b c} {c d} {c e}}} + +#Minimum Degree Spanning Tree Tests + +#Test 1.4 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDegreeSpanningTree-1.4 { graph simulation } { + SETUP_MDST_2 + set solution [struct::graph::op::MinimumDegreeSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} {{v1 v2 v3 v4 v5 v6 v7 v8} {{v1 v2} {v1 v3} {v2 v4} {v4 v5} {v5 v7} {v6 v8} {v7 v8}}} + +#Test 1.5 - case when graph is "wheel structured" (one central node and the rest of nodes around central one) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDegreeSpanningTree-1.5 { graph simulation } { + SETUP_MDST_6 + set solution [struct::graph::op::MinimumDegreeSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} [tmE [tmSE \ + {{a b c d e f g} {{a f} {a g} {b c} {c g} {d e} {e f}}} \ + {{a b c d e f g} {{a b} {a f} {b c} {c g} {d g} {e f}}}] \ + {{a b c d e f g} {{a f} {b c} {b g} {d e} {d g} {f g}}}] + +#Test 1.6 - case when graph is "wheel structured" (one central node and the rest of nodes around central one) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDegreeSpanningTree-1.6 { graph simulation } { + SETUP_MDST_7 + set solution [struct::graph::op::MinimumDegreeSpanningTree mygraph] + set result [list \ + [lsort -dict [$solution nodes]] \ + [lsort -dict [undirected [$solution arcs]]]] + $solution destroy + mygraph destroy + set result +} [tmE \ + {{a b c d e f} {{a f} {b c} {b d} {c e} {e f}}} \ + {{a b c d e f} {{a f} {b c} {c d} {d e} {e f}}}] + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many +# Minimum Diameter Spanning Tree Tests + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-2.0 { MinimumDiameterSpanningTree, wrong args, missing } { + catch {struct::graph::op::MinimumDiameterSpanningTree} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MinimumDiameterSpanningTree {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDiameterSpanningTree-2.1 { MinimumDiameterSpanningTree, wrong args, too many} { + catch {struct::graph::op::MinimumDiameterSpanningTree G s} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::MinimumDiameterSpanningTree {G}] + +#Minimum Degree Spanning Tree Tests + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDegreeSpanningTree-2.2 { MinimumDegreeSpanningTree, wrong args, missing } { + catch {struct::graph::op::MinimumDegreeSpanningTree} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MinimumDegreeSpanningTree {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MinimumDegreeSpanningTree-2.3 { MinimumDegreeSpanningTree, wrong args, too many} { + catch {struct::graph::op::MinimumDegreeSpanningTree G s} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::MinimumDegreeSpanningTree {G}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures diff --git a/tcllib/modules/struct/graph/tests/ops/metrictsp.test b/tcllib/modules/struct/graph/tests/ops/metrictsp.test new file mode 100644 index 0000000..79ab838 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/metrictsp.test @@ -0,0 +1,208 @@ +# -*- tcl -*- +#Metric Travelling Salesman Algorithm - Tests +# +#Finding Hamilton Cycle in graph satisfying triangle inequality. +#Set of tests covers also subprocedures used by MTSP algorithm. + +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + +#Test 1.0 - graph which can cause reaching maximum approximation factor +# - The Tcl implementation yields a near-optimal route (having a +# length of 7, over 6). +# - The C implementation with different node ordering yields route off +# by two (8 over 6), this is still within 2x approximation factor, +# and also demonstrates how this algorithm is a heuristic and easy +# to disturb by even small things. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.0 { MetricTravellingSalesman, graph simulation } -setup { + SETUP_TSP_1 +} -body { + toursort [struct::graph::op::MetricTravellingSalesman mygraph] +} -cleanup { + mygraph destroy +} -result [tmE \ + {node1 node4 node3 node2 node6 node5 node1} \ + {node1 node3 node2 node6 node5 node4 node1}] + +#Test 1.1 - case with double edges and different edge weights at them +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.1 { MetricTravellingSalesman, graph simulation } -setup { + SETUP_TSP_3 +} -body { + toursorta [struct::graph::op::MetricTravellingSalesman mygraph] +} -cleanup { + mygraph destroy +} -result {node1 node2 node3 node4 node1} + +#Test 1.2 - graph which can cause reaching maximum approximation factor. +# We have slightly different tours based on the chosen implementation +# (Not only of struct::graph, but also of struct::set). +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.2 { MetricTravellingSalesman, graph simulation } -setup { + SETUP_TSP_2 +} -body { + toursort [struct::graph::op::MetricTravellingSalesman mygraph] +} -cleanup { + mygraph destroy +} -result [tmE [tmSE \ + {node1 node2 node3 node4 node5 node1} \ + {node1 node4 node3 node2 node5 node1}] \ + {node1 node3 node2 node5 node4 node1}] + +#Test 1.3 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.3 { createTGraph, option 0 } -setup { + SETUP_CREATETGRAPH_1 E +} -body { + set tg [struct::graph::op::createTGraph mygraph $E 0] + list \ + [lsort [$tg arcs]] \ + [lsort [$tg nodes]] +} -cleanup { + $tg destroy + mygraph destroy +} -result {{{node1 node2} {node1 node4} {node2 node1} {node4 node1}} {node1 node2 node3 node4}} + +#Test 1.4 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.4 { createTGraph, option 1 } -setup { + SETUP_CREATETGRAPH_1 E +} -body { + set tg [struct::graph::op::createTGraph mygraph $E 1] + list \ + [lsort [$tg arcs]] \ + [lsort [$tg nodes]] +} -cleanup { + $tg destroy + mygraph destroy +} -result {{{node2 node1} {node4 node1}} {node1 node2 node3 node4}} + +#Test 1.5 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.5 { createTGraph, no edges exception } -setup { + SETUP_CREATETGRAPH_2 E +} -body { + struct::graph::op::createTGraph mygraph $E 0 +} -returnCodes 1 -cleanup { + mygraph destroy +} -result [LackOfEdgesOccurance {mygraph} {edge1}] + +#Test 1.6 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.6 { createTGraph, no edges exception } -setup { + SETUP_CREATETGRAPH_2 E +} -body { + struct::graph::op::createTGraph mygraph $E 1 +} -returnCodes 1 -cleanup { + mygraph destroy +} -result [LackOfEdgesOccurance {mygraph} {edge1}] + +#Test 1.7 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.7 { createTGraph, option 1 } -setup { + SETUP_CREATETGRAPH_3 E +} -body { + set tg [struct::graph::op::createTGraph mygraph $E 1] + list \ + [lsort [$tg arcs]] \ + [lsort [$tg nodes]] +} -cleanup { + $tg destroy + mygraph destroy +} -result {{{node1 node4} {node3 node1} {node4 node1}} {node1 node2 node3 node4}} + +#Test 1.8 - testing subprocedure createTGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.8 { createTGraph, option 0 } -setup { + SETUP_CREATETGRAPH_3 E +} -body { + set tg [struct::graph::op::createTGraph mygraph $E 0] + list \ + [lsort [$tg arcs]] \ + [lsort [$tg nodes]] +} -cleanup { + $tg destroy + mygraph destroy +} -result {{{node1 node3} {node1 node4} {node3 node1} {node4 node1}} {node1 node2 node3 node4}} + +#Test 1.9 - testing subprocedure createCompleteGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.9 { createCompleteGraph, no edges } -setup { + SETUP_NOEDGES_1 +} -body { + struct::graph::op::createCompleteGraph mygraph originalEdges + list \ + [lsort [undirected [mygraph arcs]]] \ + [lsort [mygraph nodes]] \ + [lsort $originalEdges] +} -cleanup { + mygraph destroy +} -result {{{node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node3 node4}} {node1 node2 node3 node4} {}} + +#Test 1.10 - testing subprocedure createCompleteGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.10 { createCompleteGraph, complete graph } -setup { + SETUP_UNDIRECTED_K4 +} -body { + struct::graph::op::createCompleteGraph mygraph originalEdges + list \ + [lsort [mygraph arcs]] \ + [lsort [mygraph nodes]] \ + [lsort $originalEdges] +} -cleanup { + mygraph destroy +} -result {{edge12 edge13 edge14 edge23 edge24 edge34} {node1 node2 node3 node4} {{node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node3 node4}}} + +#Test 1.11 - testing subprocedure createCompleteGraph used by Metric Travelling Salesman procedure +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.11 { createCompleteGraph, partially connected graph } -setup { + SETUP_PARTIALLYCONNECTED_1 +} -body { + struct::graph::op::createCompleteGraph mygraph originalEdges + list \ + [lsort [undirected [mygraph arcs]]] \ + [lsort [mygraph nodes]] \ + [lsort $originalEdges] +} -cleanup { + mygraph destroy +} -result {{arc1 arc2 arc3 arc4 {node1 node2} {node1 node3} {node1 node4} {node2 node3} {node2 node4} {node3 node4}} {node1 node2 node3 node4 node5} {{node1 node5} {node2 node5} {node3 node5} {node4 node5}}} + +#Test 1.12 - graph which can cause reaching maximum approximation factor +# this also has considerable freedom in the order it can choose the nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-1.12 { MetricTravellingSalesman, graph simulation } -setup { + SETUP_PARTIALLYCONNECTED_1 +} -body { + toursort [struct::graph::op::MetricTravellingSalesman mygraph] +} -cleanup { + mygraph destroy +} -result {node1 node5 node4 node5 node3 node5 node2 node5 node1} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-2.0 { MetricTravellingSalesman, wrong args, missing } { + catch {struct::graph::op::MetricTravellingSalesman} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::MetricTravellingSalesman {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-2.1 { MetricTravellingSalesman, wrong args, too many} { + catch {struct::graph::op::MetricTravellingSalesman G y x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::MetricTravellingSalesman {G}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +#Test 3.0 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-3.0 {MetricTravellingSalesman, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::MetricTravellingSalesman mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.1 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-3.1 {MetricTravellingSalesman, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::MetricTravellingSalesman mygraph} result + mygraph destroy + set result +} [UnweightedArcOccurance] + +#Test 3.2 - case when given graph is not a connected graph +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-MetricTravellingSalesman-3.2 { MetricTravellingSalesman, unconnected graph } { + SETUP_NOEDGES_1 + catch { struct::graph::op::MetricTravellingSalesman mygraph } result + mygraph destroy + set result +} [UnconnectedGraphOccurance {mygraph}] diff --git a/tcllib/modules/struct/graph/tests/ops/mkmblockingflow.test b/tcllib/modules/struct/graph/tests/ops/mkmblockingflow.test new file mode 100644 index 0000000..56d9bf8 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/mkmblockingflow.test @@ -0,0 +1,67 @@ +# -*- tcl -*- +#Blocking flow by MKM - Tests +# +# + +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 - +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-1.0 { Tight Example, n+4 - nodes graph } { + SETUP_BLOCKINGFLOW_1 + set result [dictsort [struct::graph::op::BlockingFlowByMKM mygraph s t]] + mygraph destroy + set result +} {{s v1} 3 {s v3} 2 {v1 v2} 2 {v1 v4} 1 {v2 v5} 2 {v3 v4} 1 {v3 v6} 1 {v4 v5} 1 {v4 v7} 1 {v5 t} 3 {v6 v7} 1 {v7 t} 2} + +#Test 1.1 - case when input residual graph is created from network that hasn't any flows yet +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-1.1 { graph simulation } { + SETUP_MAXIMUMFLOW_1 + set result [dictsort [struct::graph::op::BlockingFlowByMKM mygraph s t]] + mygraph destroy + set result +} {{s v1} 10 {s v2} 4 {v1 v3} 4 {v1 v4} 6 {v2 v4} 4 {v3 t} 4 {v4 t} 10} + +#Test 1.2 - case when input residual graph is created from network that has already some flows used in it +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-1.2 { graph simulation } { + SETUP_BLOCKINGFLOW_2 + set result [dictsort [struct::graph::op::BlockingFlowByMKM mygraph s t]] + mygraph destroy + set result +} {{s v2} 5 {v2 v4} 5 {v3 t} 5 {v4 v3} 5} + +#Test 1.3 - case when from residual graph we get level graph with no arcs - the blocking flow is not found +#cause there are no paths between sink and source in residual graph. +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-1.3 { graph simulation } { + SETUP_BLOCKINGFLOW_3 + set result [dictsort [struct::graph::op::BlockingFlowByMKM mygraph s t]] + mygraph destroy + set result +} {} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-2.0 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByMKM} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByMKM {G s t} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-2.1 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByMKM G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByMKM {G s t} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-2.2 { BlockingFlow, wrong args, missing } { + catch {struct::graph::op::BlockingFlowByMKM G s} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::BlockingFlowByMKM {G s t} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-BlockingFlowMKM-2.3 { BlockingFlow, wrong args, too many} { + catch {struct::graph::op::BlockingFlowByMKM G y x z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::BlockingFlowByMKM {G s t}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + diff --git a/tcllib/modules/struct/graph/tests/ops/prim.test b/tcllib/modules/struct/graph/tests/ops/prim.test new file mode 100644 index 0000000..0e06ddb --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/prim.test @@ -0,0 +1,67 @@ +# -*- tcl -*- +# Graph ops tests - Minimum spanning tree/forest per Prim +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: prim.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::prim G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-1.0 {prim, wrong args, missing} -body { + struct::graph::op::prim +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::prim {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-1.1 {prim, wrong args, too many} -body { + struct::graph::op::prim g x +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::prim {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-2.0 {prim, arcs without weights} -setup { + SETUP + mygraph node insert 0 1 + mygraph arc insert 0 1 a +} -body { + struct::graph::op::prim mygraph +} -returnCodes error -result {Operation invalid for graph with unweighted arcs.} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-3.0 {prim, empty graph} -setup { + SETUP +} -body { + struct::graph::op::prim mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-3.1 {prim, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + struct::graph::op::prim mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-3.2 {prim, nodes, arcs} -setup { + SETUP_A +} -body { + lsort -dict [struct::graph::op::prim mygraph] +} -cleanup { + mygraph destroy +} -result {'arc0_1' 'arc0_3' 'arc3_2' 'arc3_4' 'arc3_6' 'arc6_5'} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-prim-3.3 {prim, nodes, arcs} -setup { + SETUP_B +} -body { + lsort -dict [struct::graph::op::prim mygraph] +} -cleanup { + mygraph destroy +} -result {A_B A_C C_D D_E S_B} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/radius.test b/tcllib/modules/struct/graph/tests/ops/radius.test new file mode 100644 index 0000000..50d1883 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/radius.test @@ -0,0 +1,45 @@ +# -*- tcl -*- +# Graph ops tests - Dijkstra, distances, radius +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: radius.test,v 1.2 2009/09/15 19:24:12 andreas_kupries Exp $ + +# Syntax: struct::graph::op::radius G ?options? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-radius-1.0 {radius, wrong args, missing} { + catch {struct::graph::op::radius} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::radius {g args} 0] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +set n 0 +foreach {setup radius unradius} { + SETUP_A 6 5 + SETUP_B 6 4 +} { + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-radius-3.$n "radius, $setup, directed" { + $setup + set result [struct::graph::op::radius mygraph -arcmode directed] + mygraph destroy + set result + } $radius + + test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-radius-4.$n "radius, $setup, undirected" { + $setup + set result [struct::graph::op::radius mygraph -arcmode undirected] + mygraph destroy + set result + } $unradius + + incr n +} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/tarjan.test b/tcllib/modules/struct/graph/tests/ops/tarjan.test new file mode 100644 index 0000000..179e6e3 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/tarjan.test @@ -0,0 +1,99 @@ +# -*- tcl -*- +# Graph ops tests - Strongly connected components per Tarjan's algorithm +# Copyright (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: tarjan.test,v 1.4 2010/09/09 21:48:27 andreas_kupries Exp $ + +# Syntax: struct::graph::op::tarjan G + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-1.0 {tarjan, wrong args, missing} -body { + struct::graph::op::tarjan +} -returnCodes error -result [tcltest::wrongNumArgs struct::graph::op::tarjan {g} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-1.1 {tarjan, wrong args, too many} -body { + struct::graph::op::tarjan g x +} -returnCodes error -result [tcltest::tooManyArgs struct::graph::op::tarjan {g}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.0 {tarjan, empty graph} -setup { + SETUP +} -body { + struct::graph::op::tarjan mygraph +} -cleanup { + mygraph destroy +} -result {} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.1 {tarjan, nodes, no arcs} -setup { + SETUP + mygraph node insert 0 1 2 3 4 5 +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {0 1 2 3 4 5} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.2 {tarjan, nodes, arcs} -setup { + SETUP_A +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {{'node0' 'node1' 'node2' 'node3'} 'node4' 'node5' 'node6'} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.3 {tarjan, nodes, arcs} -setup { + SETUP_B +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {A B C D E S} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.4 {tarjan, nodes, arcs} -setup { + SETUP_C +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {{A B C D} E F} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.5 {tarjan, nodes, arcs} -setup { + SETUP_D +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {{a b c d} {f g h} i j} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.6 {tarjan, nodes, arcs} -setup { + SETUP_E +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b {3w 4b} 4w 5b 5w 6b 6w {7b 7w 8b 8w}} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.7 {tarjan, nodes, arcs} -setup { + SETUP_F +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b 3w 4b 4w} + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-tarjan-3.8 {tarjan, nodes, arcs} -setup { + SETUP_G +} -body { + setsetcanon [struct::graph::op::tarjan mygraph] +} -cleanup { + mygraph destroy +} -result {1b 1w 2b 2w 3b 3w 4b 4w 5b 5w} + +# --------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/ops/tspheuristics.test b/tcllib/modules/struct/graph/tests/ops/tspheuristics.test new file mode 100644 index 0000000..814b685 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/tspheuristics.test @@ -0,0 +1,44 @@ +#-*- tcl -*- +#Tests for heuristics of local searching for Traveling Salesman Problem. +#2 and 3 approximation algorithms. +# +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-TSPHeuristic2OPT-1.0 { graph simulation } -setup { + SETUP_TSPHEURISTIC_1 C +} -body { + lsort -dict [struct::graph::op::TSPLocalSearching mygraph $C] +} -cleanup { + mygraph destroy + unset C +} -result {{a b} {a c} {b e} {c d} {d e}} + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-TSPHeuristic2OPT-2.0 { wrong args, missing } { + catch {struct::graph::op::TSPLocalSearching} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::TSPLocalSearching {G C} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-TSPHeuristic2OPT-2.1 { wrong args, missing } { + catch {struct::graph::op::TSPLocalSearching G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::TSPLocalSearching {G C} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-TSPHeuristic2OPT-2.2 { wrong args, too many} { + catch {struct::graph::op::TSPLocalSearching G a b} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::TSPLocalSearching {G C}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-TSPHeuristic2OPT-2.0 { wrong args, missing } -setup { + SETUP_TSPHEURISTIC_1 C +} -body { + struct::graph::op::TSPLocalSearching mygraph {h j k} +} -returnCodes error -cleanup { + mygraph destroy +} -result {Given cycle has arcs not included in graph G.} diff --git a/tcllib/modules/struct/graph/tests/ops/verticescover.test b/tcllib/modules/struct/graph/tests/ops/verticescover.test new file mode 100644 index 0000000..354f724 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/verticescover.test @@ -0,0 +1,81 @@ +# -*- tcl -*- +#Vertices Cover, 2 approximation algorithm - Tests +# +#Algorithm searches for the minimum set of vertices such that each edge of the graph +#is incident to at least one vertex of the set. +# +#------------------------------------------------------------------------------------ +#Tests concerning returning right values by algorithm + +#Test 1.0 - case when graph is complete - the same degrees and even number of nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.0 { VerticesCover, complete K4 } { + SETUP_UNDIRECTED_K4 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} {node1 node2 node3 node4} + +#Test 1.1 - case with big degree differences at nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.1 { VerticesCover, graph simulation } { + SETUP_VC_1 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} [tmE {node1 node3} {node2 node3}] + +#Test 1.2 - another test case testing the improvement given by degree conditions +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.2 { VerticesCover, graph simulation } { + SETUP_VC_2 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} {node2 node3 node4 node5} + +#Test 1.3 - case when graph is a cycle - degrees are the same for all nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.3 { VerticesCover, cycle C5 } { + SETUP_C5 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} [tmE {node2 node3 node4 node5} {node1 node3 node4 node5}] +# should custom match code verifying that result is a cover. + +#Test 1.4 - case when given graph is a K4, but with doubled arcs (directed) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.4 { VerticesCover, directed K4 } { + SETUP_K4 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} {node1 node2 node3 node4} + +#Test 1.5 - graph from Test 1.1, but with doubled arcs (directed) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.5 { VerticesCover, directed, complete } { + SETUP_VC_1_2 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} [tmE {node1 node3} {node2 node3}] + +#Test 1.6 - graph from Test 1.1, but with some doubled arcs (directed) +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-1.6 { VerticesCover, directed, uncomplete } { + SETUP_VC_1_3 + set result [lsort -dict [struct::graph::op::VerticesCover mygraph]] + mygraph destroy + set result +} [tmE {node1 node3} {node2 node3}] + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-2.0 { VerticesCover, wrong args, missing } { + catch {struct::graph::op::VerticesCover} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::VerticesCover {G} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-VerticesCover-2.1 { VerticesCover, wrong args, too many} { + catch {struct::graph::op::VerticesCover G y x} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::VerticesCover {G}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failure diff --git a/tcllib/modules/struct/graph/tests/ops/weightedkcenter.test b/tcllib/modules/struct/graph/tests/ops/weightedkcenter.test new file mode 100644 index 0000000..acaf2d5 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/ops/weightedkcenter.test @@ -0,0 +1,137 @@ +# -*- tcl -*- +#Metric Weighted K-Center - Tests +# +# +#Set of tests includes also tests for subprocedures used by Weighted Metric K-Center Algorithm: +#- Max Weighted Independent Set + +# ------------------------------------------------------------------------------------ +# Tests concerning returning right values by algorithm + +#Test 1.0 - Tight Example simulation for graph with 8 nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.0 { Tight Example, n+4 - nodes graph } { + SETUP_WEIGHTEDKCENTER_1 nodeWeights + set result [lsort -dict [struct::graph::op::WeightedKCenter mygraph $nodeWeights 3]] + mygraph destroy + set result +} {node1 node4} + +#Test 1.1 - Tight Example simulation for graph with 8 nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.1 { Tight Example, n+4 - nodes graph } { + SETUP_WEIGHTEDKCENTER_1 nodeWeights + set result [lsort -dict [struct::graph::op::WeightedKCenter mygraph $nodeWeights 9]] + mygraph destroy + set result +} {node1 node4} + +#Test 1.2 - Tight Example simulation for graph with 8 nodes +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.2 { Tight Example, n+4 - nodes graph } { + SETUP_WEIGHTEDKCENTER_1 nodeWeights + catch { struct::graph::op::WeightedKCenter mygraph $nodeWeights 1 } result + mygraph destroy + set result +} {No k-center found for restriction W = 1} + +#Test 1.3 - +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.3 { } { + SETUP_WEIGHTEDKCENTER_2 nodeWeights + set result [lsort -dict [struct::graph::op::WeightedKCenter mygraph $nodeWeights 2]] + mygraph destroy + set result +} {node6} + +#Test 1.4 - +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.4 { } { + SETUP_WEIGHTEDKCENTER_3 nodeWeights + set result [lsort -dict [struct::graph::op::WeightedKCenter mygraph $nodeWeights 1]] + mygraph destroy + set result +} {node1} + +#Test 1.5 - +# Tcl: 12345->1234->124 | Initial different sorting of the arcs causes selection of different maximal +# C: 12346->1246->146->14 | independent sets, which then drives the heuristics to different solutions. + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.5 { } { + SETUP_WEIGHTEDKCENTER_3 nodeWeights + set result [lsort -dict [struct::graph::op::WeightedKCenter mygraph $nodeWeights 3]] + mygraph destroy + set result +} [tmE {node1 node2 node4} {node1 node4}] + +#Test 1.6 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.6 { Independent Set, 24 nodes graph } { + SETUP_INDEPENDENTSET_1 + set nodeWeights {} + foreach node [mygraph nodes] { + lappend nodeWeights [list $node 1] + } + set result [struct::graph::op::GreedyWeightedMaxIndependentSet mygraph $nodeWeights] + set result [list [ismaxindependentset mygraph $result] [llength $result]] + mygraph destroy + set result +} {1 8} + +#Test 1.7 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.7 { Independent Set, complete K4 } { + SETUP_UNWEIGHTED_K4 + set nodeWeights {{node1 1} {node2 2} {node3 2} {node4 2}} + set result [lsort -dict [struct::graph::op::GreedyWeightedMaxIndependentSet mygraph \ + $nodeWeights]] + mygraph destroy + set result +} {node1} + +#Test 1.8 +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-1.8 { Independent Set, C5 } { + SETUP_C5 + set nodeWeights {{node1 1} {node2 2} {node3 3} {node4 4} {node5 5}} + set result [lsort -dict [struct::graph::op::GreedyWeightedMaxIndependentSet mygraph \ + $nodeWeights]] + mygraph destroy + set result +} {node1 node3} + + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-2.0 { WeightedKCenter, wrong args, missing } { + catch {struct::graph::op::WeightedKCenter} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::WeightedKCenter {G nodeWeights W} 0] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-2.1 { WeightedKCenter, wrong args, missing } { + catch {struct::graph::op::WeightedKCenter G} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::WeightedKCenter {G nodeWeights W} 1] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-2.2 { WeightedKCenter, wrong args, missing } { + catch {struct::graph::op::WeightedKCenter G x} msg + set msg +} [tcltest::wrongNumArgs struct::graph::op::WeightedKCenter {G nodeWeights W} 2] + +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-2.3 { WeightedKCenter, wrong args, too many} { + catch {struct::graph::op::WeightedKCenter G y x z} msg + set msg +} [tcltest::tooManyArgs struct::graph::op::WeightedKCenter {G nodeWeights W}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + + +#Test 3.0 - case when W is too low +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-3.0 { WeightedKCenter, wrong input } { + SETUP_KCENTER_1 + catch { struct::graph::op::WeightedKCenter mygraph nodeWeights 0 } result + mygraph destroy + set result +} [WrongValueAtInput {W}] + +#Test 3.1 - case when given graph doesn't have weights at all edges +test graphop-t${treeimpl}-g${impl}-s${setimpl}-st${stkimpl}-q${queimpl}-WeightedKCenter-3.1 {WeightedKCenter, lack of weights at edges } { + SETUP_UNWEIGHTED_K4 + catch {struct::graph::op::WeightedKCenter mygraph nodeWeights 5 } result + mygraph destroy + set result +} [UnweightedArcOccurance] diff --git a/tcllib/modules/struct/graph/tests/rassign.test b/tcllib/modules/struct/graph/tests/rassign.test new file mode 100644 index 0000000..046dc19 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/rassign.test @@ -0,0 +1,75 @@ +# -*- tcl -*- +# Graph tests - revers assignment (-->) +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: rassign.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph --> GRAPH + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-revers-assign-1.0 {revers assign, wrong#args, missing} { + SETUP + catch {mygraph -->} result + mygraph destroy + set result +} [tmWrong --> dest 0] + +test graph-${impl}-${setimpl}-revers-assign-1.1 {revers assign, wrong#args, too many} { + SETUP + catch {mygraph --> foo bar} result + mygraph destroy + set result +} [tmTooMany --> dest] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-revers-assign-2.0 {revers assign, bad src command} { + SETUP + catch {mygraph --> foo} result + mygraph destroy + set result +} {invalid command name "foo"} + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-revers-assign-3.0 {revers assign, direct} { + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + SETUP + SETUP bgraph + + mygraph deserialize $serial + + set result [validate_serial bgraph $serial] + mygraph --> bgraph + lappend result [validate_serial bgraph $serial] + + mygraph destroy + bgraph destroy + set result +} {attr/graph/data-mismatch ok} + +test graph-${impl}-${setimpl}-revers-assign-3.1 {revers assign, deserial/serial} { + set serial {%3 {} {{f 6 {}}} %0 {foo bar} {{a 6 {}} {b 9 {bar snarf}} {c 0 {}}} %1 {} {{d 9 {}}} %2 {} {{e 0 {}}} {data foo}} + + SETUP + SETUP bgraph + proc bwrap {args} {uplevel #0 [linsert $args 0 bgraph]} + + mygraph deserialize $serial + + set result [validate_serial bgraph $serial] + mygraph --> bwrap + lappend result [validate_serial bgraph $serial] + + mygraph destroy + bgraph destroy + rename bwrap {} + set result +} {attr/graph/data-mismatch ok} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/serialize.test b/tcllib/modules/struct/graph/tests/serialize.test new file mode 100644 index 0000000..8c614eb --- /dev/null +++ b/tcllib/modules/struct/graph/tests/serialize.test @@ -0,0 +1,199 @@ +# -*- tcl -*- +# Graph tests - serialize +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: serialize.test,v 1.3 2008/10/11 23:23:48 andreas_kupries Exp $ + +# Syntax: graph serialize ?NODE...? + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +# Cannot have missing arguments, nor too many. + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-serialize-1.0 {serialize, missing node} { + SETUP + catch {mygraph serialize foo} result + mygraph destroy + set result +} [MissingNode $MY foo] + +# ------------------------------------------------------------------------- +# Ok arguments. + +test graph-${impl}-${setimpl}-serialize-2.0 {serialize, empty graph} { + SETUP + set serial [mygraph serialize] + set result [validate_serial mygraph $serial] + mygraph destroy + set result + + # serial = {{}} +} ok + +test graph-${impl}-${setimpl}-serialize-2.1 {serialize, complete graph} { + SETUP + + mygraph node insert %0 %1 %2 %3 + mygraph arc insert %0 %1 a + mygraph arc insert %0 %2 b + mygraph arc insert %0 %3 c + mygraph arc insert %1 %2 d + mygraph arc insert %2 %3 e + mygraph arc insert %3 %1 f + + mygraph set data foo + mygraph node set %0 foo bar + mygraph arc set b bar snarf + + set serial [mygraph serialize] + set result [validate_serial mygraph $serial] + mygraph destroy + set result + + # serial = + # %3 {} { /0 + # {f 6 {}} + # } + # %0 {foo bar} { /3 + # {a 6 {}} + # {b 9 {bar snarf}} + # {c 0 {}} + # } + # %1 {} { /6 + # {d 9 {}} + # } + # %2 {} { /9 + # {e 0 {}} + # } + # {data foo} +} ok + + +test graph-${impl}-${setimpl}-serialize-2.2 {serialize, complete graph, no attributes} { + SETUP + + mygraph node insert %0 %1 %2 %3 + mygraph arc insert %0 %1 a + mygraph arc insert %0 %2 b + mygraph arc insert %0 %3 c + mygraph arc insert %1 %2 d + mygraph arc insert %2 %3 e + mygraph arc insert %3 %1 f + + set serial [mygraph serialize] + set result [validate_serial mygraph $serial] + mygraph destroy + set result + + # serial = + # %3 {} { /0 + # {f 6 {}} + # } + # %0 {} { /3 + # {a 6 {}} + # {b 9 {}} + # {c 0 {}} + # } + # %1 {} { /6 + # {d 9 {}} + # } + # %2 {} { /9 + # {e 0 {}} + # } + # {} +} ok + +test graph-${impl}-${setimpl}-serialize-2.3 {serialize, subgraph} { + SETUP + + mygraph node insert %0 %1 %2 %3 + mygraph arc insert %0 %1 a + mygraph arc insert %0 %2 b + mygraph arc insert %0 %3 c + mygraph arc insert %1 %2 d + mygraph arc insert %2 %3 e + mygraph arc insert %3 %1 f + + mygraph set data foo + mygraph node set %0 foo bar + mygraph arc set b bar snarf + + set serial [mygraph serialize %0 %1 %3] + set result [validate_serial mygraph $serial {%0 %1 %3}] + mygraph destroy + set result + + # serial = + # %0 {foo bar} {{a 3 {}} {c 6 {}}} /0 + # %1 {} {} /3 + # %3 {} {{f 3 {}}} /6 + # {data foo} +} ok + + +test graph-${impl}-${setimpl}-serialize-2.4 {serialize, subgraph, duplicate nodes} { + SETUP + + mygraph node insert %0 %1 %2 %3 + mygraph arc insert %0 %1 a + mygraph arc insert %0 %2 b + mygraph arc insert %0 %3 c + mygraph arc insert %1 %2 d + mygraph arc insert %2 %3 e + mygraph arc insert %3 %1 f + + mygraph set data foo + mygraph node set %0 foo bar + mygraph arc set b bar snarf + + set serial [mygraph serialize %0 %1 %3 %0] + set result [validate_serial mygraph $serial {%0 %1 %3}] + mygraph destroy + set result + + # serial = + # %0 {foo bar} {{a 3 {}} {c 6 {}}} /0 + # %1 {} {} /3 + # %3 {} {{f 3 {}}} /6 + # {data foo} +} ok + +test graph-${impl}-${setimpl}-serialize-2.5 {serialize, complete graph, some weights} { + SETUP + + mygraph node insert %0 %1 %2 %3 + mygraph arc insert %0 %1 a + mygraph arc insert %0 %2 b + mygraph arc insert %0 %3 c + mygraph arc insert %1 %2 d ; mygraph arc setweight d 100 + mygraph arc insert %2 %3 e ; mygraph arc setweight e 200 + mygraph arc insert %3 %1 f ; mygraph arc setweight f 400 + + set serial [mygraph serialize] + set result [validate_serial mygraph $serial] + mygraph destroy + set result + + # serial = + # %3 {} { /0 + # {f 6 {} 400} + # } + # %0 {} { /3 + # {a 6 {}} + # {b 9 {}} + # {c 0 {}} + # } + # %1 {} { /6 + # {d 9 {} 100} + # } + # %2 {} { /9 + # {e 0 {} 200} + # } + # {} +} ok + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/swap.test b/tcllib/modules/struct/graph/tests/swap.test new file mode 100644 index 0000000..c785b38 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/swap.test @@ -0,0 +1,121 @@ +# -*- tcl -*- +# Graph tests - swap +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: swap.test,v 1.2 2007/04/12 03:01:55 andreas_kupries Exp $ + +# Syntax: graph swap NODE-1 NODE-2 + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-swap-1.0 {swap, wrong#args, missing} { + SETUP + catch {mygraph swap} msg + mygraph destroy + set msg +} [tmWrong swap {node1 node2} 0] + +test graph-${impl}-${setimpl}-swap-1.1 {swap, wrong#args, missing} { + SETUP + catch {mygraph swap a} msg + mygraph destroy + set msg +} [tmWrong swap {node1 node2} 1] + +test graph-${impl}-${setimpl}-swap-1.2 {swap, wrong#args, too many} { + SETUP + catch {mygraph swap a b c} msg + mygraph destroy + set msg +} [tmTooMany swap {node1 node2}] + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-swap-2.0 {swap, missing node} { + SETUP + mygraph node insert node1 + catch {mygraph swap node0 node1} msg + mygraph destroy + set msg +} [MissingNode $MY node0] + +test graph-${impl}-${setimpl}-swap-2.1 {swap, missing node} { + SETUP + mygraph node insert node0 + catch {mygraph swap node0 node1} msg + mygraph destroy + set msg +} [MissingNode $MY node1] + +test graph-${impl}-${setimpl}-swap-2.2 {swap, self} { + SETUP + mygraph node insert node0 + catch {mygraph swap node0 node0} msg + mygraph destroy + set msg +} "cannot swap node \"node0\" with itself" + +# ------------------------------------------------------------------------- +# Ok arguments. + +proc SETUP_2 {} { + + # +--/a4/-> n4 + # | + # n0 -/a1/-> n1 -/a3/-> n3 + # | + # +--/a2/-> n2 + + mygraph node insert n0 n1 n2 n3 n4 + mygraph arc insert n0 n1 a1 + mygraph arc insert n0 n2 a2 + mygraph arc insert n1 n3 a3 + mygraph arc insert n1 n4 a4 + return +} + +test graph-${impl}-${setimpl}-swap-3.0 {swap, node relationships} { + SETUP + SETUP_2 + + mygraph swap n0 n1 + + set result {} + lappend result [lsort [mygraph nodes -out n0]] + lappend result [lsort [mygraph nodes -out n1]] + + mygraph destroy + set result +} {{n3 n4} {n0 n2}} + +test graph-${impl}-${setimpl}-swap-3.1 {swap, node relationships} { + SETUP + SETUP_2 + + mygraph swap n0 n3 + + set result {} + lappend result [lsort [mygraph nodes -out n0]] + lappend result [lsort [mygraph nodes -out n3]] + + mygraph destroy + set result +} {{} {n1 n2}} + +test graph-${impl}-${setimpl}-swap-3.2 {swap, node relationships} { + SETUP + SETUP_2 + + mygraph swap n1 n0 + + set result {} + lappend result [lsort [mygraph nodes -out n0]] + lappend result [lsort [mygraph nodes -out n1]] + + mygraph destroy + set result +} {{n3 n4} {n0 n2}} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/tests/walk.test b/tcllib/modules/struct/graph/tests/walk.test new file mode 100644 index 0000000..1741af5 --- /dev/null +++ b/tcllib/modules/struct/graph/tests/walk.test @@ -0,0 +1,207 @@ +# -*- tcl -*- +# Graph tests - walk +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# RCS: @(#) $Id: walk.test,v 1.3 2008/12/13 03:57:33 andreas_kupries Exp $ + +# Syntax: graph walk NODE ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd + +# ------------------------------------------------------------------------- +# Wrong # args: Missing, Too many + +test graph-${impl}-${setimpl}-walk-1.0 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk} msg + mygraph destroy + set msg +} [tmWrong walk {node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd} 0 {node args}] + +test graph-${impl}-${setimpl}-walk-1.1 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk %0} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-1.2 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk %0 -dir} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-1.3 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk %0 -order} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-1.4 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk %0 -type} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-1.5 {walk, wrong#args, missing} {} { + SETUP + catch {mygraph walk %0 -command} msg + mygraph destroy + set msg +} "wrong # args: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +# ------------------------------------------------------------------------- +# Logical arguments checks and failures + +test graph-${impl}-${setimpl}-walk-2.0 {walk, missing node} { + SETUP + catch {mygraph walk node0 -command {}} msg + mygraph destroy + set msg +} [MissingNode $MY node0] + +test graph-${impl}-${setimpl}-walk-2.1 {walk, unknown option} { + SETUPwalk + catch {mygraph walk i -foo x -command {}} msg + mygraph destroy + set msg +} "unknown option \"-foo\": should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-2.2 {walk, empty command} { + SETUPwalk + catch {mygraph walk i -command {}} msg + mygraph destroy + set msg +} "no command specified: should be \"$MY walk node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd\"" + +test graph-${impl}-${setimpl}-walk-2.3 {walk, bad search type} { + SETUPwalk + catch {mygraph walk i -command foo -type foo} msg + mygraph destroy + set msg +} {bad search type "foo": must be bfs or dfs} + +test graph-${impl}-${setimpl}-walk-2.4 {walk, bad search direction} { + SETUPwalk + catch {mygraph walk i -command foo -type dfs -dir oneway} msg + mygraph destroy + set msg +} {bad search direction "oneway": must be backward or forward} + +test graph-${impl}-${setimpl}-walk-2.5 {walk, bad search order} { + SETUPwalk + catch {mygraph walk i -command foo -order none} msg + mygraph destroy + set msg +} {bad search order "none": must be both, pre, or post} + +test graph-${impl}-${setimpl}-walk-2.6 {walk, bad order/type combination} { + SETUPwalk + catch {mygraph walk i -command foo -order both -type bfs} msg + mygraph destroy + set msg +} {unable to do a both-order breadth first walk} + +test graph-${impl}-${setimpl}-walk-2.7 {walk, bad order/type combination} { + SETUPwalk + catch {mygraph walk i -command foo -order post -type bfs} msg + mygraph destroy + set msg +} {unable to do a post-order breadth first walk} + +# ------------------------------------------------------------------------- +# Ok arguments. + +proc record {a g n} {global t ; lappend t $a $n ; return} + +test graph-${impl}-${setimpl}-walk-3.0 {walk, forward pre dfs, default} { + SETUPwalk + set t {} + mygraph walk i -command record + mygraph destroy + set t +} [tmE {enter i enter ii enter iii enter iv enter v enter vi enter viii enter ix enter vii} \ + {enter i enter vii enter vi enter viii enter ix enter ii enter iii enter iv enter v}] + +test graph-${impl}-${setimpl}-walk-3.1 {walk, forward post dfs} { + SETUPwalk + set t [list ] + mygraph walk i -order post -command record + mygraph destroy + set t +} [tmE {leave viii leave vi leave v leave iv leave iii leave ii leave ix leave vii leave i} \ + {leave viii leave vi leave vii leave ix leave v leave iv leave iii leave ii leave i}] + +test graph-${impl}-${setimpl}-walk-3.1.1 {walk, forward post dfs} { + SETUP + mygraph node insert i ii iii + mygraph arc insert i ii 1 + mygraph arc insert i iii 2 + mygraph arc insert ii iii 3 + set t [list ] + mygraph walk i -order post -command record + mygraph destroy + set t +} [tmE {leave iii leave ii leave i} \ + {leave iii leave ii leave i}] + +test graph-${impl}-${setimpl}-walk-3.2 {walk, forward both dfs} { + SETUPwalk + set t [list ] + mygraph walk i -order both -command record + mygraph destroy + set t +} [tmE {enter i enter ii enter iii enter iv enter v enter vi enter viii leave viii leave vi leave v leave iv leave iii leave ii enter ix leave ix enter vii leave vii leave i} \ + {enter i enter vii enter vi enter viii leave viii leave vi leave vii enter ix leave ix enter ii enter iii enter iv enter v leave v leave iv leave iii leave ii leave i}] + +test graph-${impl}-${setimpl}-walk-3.3 {walk, forward pre bfs} { + SETUPwalk + set t [list ] + mygraph walk i -type bfs -command record + mygraph destroy + set t +} [tmE {enter i enter ii enter ix enter vii enter iii enter vi enter iv enter viii enter v} \ + {enter i enter vii enter ix enter ii enter vi enter iii enter viii enter iv enter v}] + +test graph-${impl}-${setimpl}-walk-3.4 {walk, backward pre bfs} { + SETUPwalk + set t [list ] + mygraph walk ix -type bfs -dir backward -command record + mygraph destroy + set t +} [tmE {enter ix enter i enter viii enter vi enter v enter vii enter iv enter iii enter ii} \ + {enter ix enter i enter viii enter vi enter vii enter v enter iv enter iii enter ii}] + +test graph-${impl}-${setimpl}-walk-3.5 {walk, backward pre dfs} { + SETUPwalk + set t [list ] + mygraph walk ix -dir backward -command record + mygraph destroy + set t +} [tmE {enter ix enter i enter viii enter vi enter v enter iv enter iii enter ii enter vii} \ + {enter ix enter i enter viii enter vi enter vii enter v enter iv enter iii enter ii}] + +test graph-${impl}-${setimpl}-walk-3.6 {walk, backward post dfs} { + SETUPwalk + set t [list ] + mygraph walk ix -dir backward -order post -command record + mygraph destroy + set t +} [tmE {leave ii leave iii leave iv leave v leave vii leave vi leave viii leave i leave ix} \ + {leave vii leave ii leave iii leave iv leave v leave vi leave viii leave i leave ix}] + +test graph-${impl}-${setimpl}-walk-3.7 {walk, backward both dfs} { + SETUPwalk + set t [list ] + mygraph walk ix -dir backward -order both -command record + mygraph destroy + set t +} [tmE {enter ix enter i enter viii enter vi enter v enter iv enter iii enter ii leave ii leave iii leave iv leave v enter vii leave vii leave vi leave viii leave i leave ix} \ + {enter ix enter i enter viii enter vi enter vii leave vii enter v enter iv enter iii enter ii leave ii leave iii leave iv leave v leave vi leave viii leave i leave ix}] + +# ------------------------------------------------------------------------- + +rename record {} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/struct/graph/util.c b/tcllib/modules/struct/graph/util.c new file mode 100644 index 0000000..0295094 --- /dev/null +++ b/tcllib/modules/struct/graph/util.c @@ -0,0 +1,115 @@ +/* struct::tree - critcl - support - stack/queue of nodes. + * definitions. + */ + +#include "tcl.h" +#include <util.h> + +static NL* newitem (void* n); + + +/* Initialize queue data structure. + */ + +void +g_nlq_init (NLQ* q) +{ + q->start = q->end = NULL; +} + +/* Add item to end of the list + */ + +void +g_nlq_append (NLQ* q, void* n) +{ + NL* qi = newitem (n); + + if (!q->end) { + q->start = q->end = qi; + } else { + q->end->next = qi; + q->end = qi; + } +} + +/* Add item to the front of the list + */ + +void +g_nlq_push (NLQ* q, void* n) +{ + NL* qi = newitem (n); + + if (!q->end) { + q->start = q->end = qi; + } else { + qi->next = q->start; + q->start = qi; + } +} + +/* Return item at front of the list. + */ + +void* +g_nlq_pop (NLQ* q) +{ + NL* qi = NULL; + void* n = NULL; + + if (!q->start) { + return NULL; + } + + qi = q->start; + n = qi->n; + + q->start = qi->next; + if (q->end == qi) { + q->end = NULL; + } + + ckfree ((char*) qi); + return n; +} + +/* Delete all items in the list. + */ + +void* +g_nlq_clear (NLQ* q) +{ + NL* next; + NL* qi = q->start; + + while (qi) { + next = qi->next; + ckfree ((char*) qi); + qi = next; + } + q->start = NULL; + q->end = NULL; +} + +/* INTERNAL - Create new item to put into the list. + */ + +static NL* +newitem (void* n) +{ + NL* qi = (NL*) ckalloc (sizeof (NL)); + + qi->n = n; + qi->next = NULL; + + return qi; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/util.h b/tcllib/modules/struct/graph/util.h new file mode 100644 index 0000000..f41c593 --- /dev/null +++ b/tcllib/modules/struct/graph/util.h @@ -0,0 +1,66 @@ +/* struct::graph - critcl - layer 0 declarations + * API general utilities + */ + +#ifndef _G_UTIL_H +#define _G_UTIL_H 1 + +#include <tcl.h> + +/* Allocation macros for common situations. + */ + +#define ALLOC(type) (type *) ckalloc (sizeof (type)) +#define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type)) +#define REALLOC(x,n,type) (type *) ckrealloc ((char*) x, (n) * sizeof (type)) + +/* Assertions in general, and asserting the proper range of an array index. + */ + +#undef GRAPH_DEBUG +#define GRAPH_DEBUG 1 + +#ifdef GRAPH_DEBUG +#define XSTR(x) #x +#define STR(x) XSTR(x) +#define RANGEOK(i,n) ((0 <= (i)) && (i < (n))) +#define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__));} +#define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " > " STR(n)) +#else +#define ASSERT(x,msg) +#define ASSERT_BOUNDS(i,n) +#endif + +/* .................................................. */ + +/* NL = Node List. Actually a list of generic pointers. + * NLQ = NL Queue. Also useable as stack. + */ + +typedef struct NL *NLptr; + +typedef struct NL { + NLptr next; + void* n; +} NL; + +typedef struct NLQ { + NLptr start; + NLptr end; +} NLQ; + +void g_nlq_init (NLQ* q); +void g_nlq_append (NLQ* q, void* n); +void g_nlq_push (NLQ* q, void* n); +void* g_nlq_pop (NLQ* q); +void* g_nlq_clear (NLQ* q); + +#endif /* _G_UTIL_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/walk.c b/tcllib/modules/struct/graph/walk.c new file mode 100644 index 0000000..11953fe --- /dev/null +++ b/tcllib/modules/struct/graph/walk.c @@ -0,0 +1,553 @@ + +#include "tcl.h" +#include <graph.h> +#include <util.h> +#include <walk.h> + +/* .................................................. */ + +static int walkdfspre (Tcl_Interp* interp, GN* n, int dir, + Tcl_HashTable* v, int cc, Tcl_Obj** ev, + Tcl_Obj* action); +static int walkdfspost (Tcl_Interp* interp, GN* n, int dir, + Tcl_HashTable* v, int cc, Tcl_Obj** ev, + Tcl_Obj* action); +static int walkdfsboth (Tcl_Interp* interp, GN* n, int dir, + Tcl_HashTable* v, int cc, Tcl_Obj** ev, + Tcl_Obj* enter, Tcl_Obj* leave); +static int walkbfspre (Tcl_Interp* interp, GN* n, int dir, + Tcl_HashTable* v, int cc, Tcl_Obj** ev, + Tcl_Obj* action); + +static int walk_invoke (Tcl_Interp* interp, GN* n, + int cc, Tcl_Obj** ev, Tcl_Obj* action); + +static int walk_neighbours (GN* n, Tcl_HashTable* v, int dir, + int* nc, GN*** nv); + +/* .................................................. */ + +int +g_walkoptions (Tcl_Interp* interp, + int objc, Tcl_Obj* const* objv, + int* type, int* order, int* dir, + int* cc, Tcl_Obj*** cv) +{ + int xcc, xtype, xorder, xdir, i; + Tcl_Obj** xcv; + Tcl_Obj* wtype = NULL; + Tcl_Obj* worder = NULL; + Tcl_Obj* wdir = NULL; + Tcl_Obj* wcmd = NULL; + + static CONST char* wtypes [] = { + "bfs", "dfs", NULL + }; + static CONST char* worders [] = { + "both", "pre", "post", NULL + }; + static CONST char* wdirs [] = { + "backward", "forward", NULL + }; + + for (i = 3; i < objc; ) { + ASSERT_BOUNDS (i, objc); + if (0 == strcmp ("-type", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) { + wrongargs: + Tcl_AppendResult (interp, + "value for \"", Tcl_GetString (objv[i]), + "\" missing, should be \"", + Tcl_GetString (objv [0]), " walk ", + W_USAGE, "\"", NULL); + return TCL_ERROR; + } + + ASSERT_BOUNDS (i+1, objc); + wtype = objv [i+1]; + i += 2; + + } else if (0 == strcmp ("-order", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) goto wrongargs; + + ASSERT_BOUNDS (i+1, objc); + worder = objv [i+1]; + i += 2; + + } else if (0 == strcmp ("-dir", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) goto wrongargs; + + ASSERT_BOUNDS (i+1, objc); + wdir = objv [i+1]; + i += 2; + + } else if (0 == strcmp ("-command", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) goto wrongargs; + + ASSERT_BOUNDS (i+1, objc); + wcmd = objv [i+1]; + i += 2; + + } else { + Tcl_AppendResult (interp, "unknown option \"", + Tcl_GetString (objv [i]), "\": should be \"", + Tcl_GetString (objv [0]), " walk ", + W_USAGE, "\"", NULL); + return TCL_ERROR; + break; + } + } + + if (i < objc) { + Tcl_WrongNumArgs (interp, 2, objv, W_USAGE); + return TCL_ERROR; + } + + if (!wcmd) { + no_command: + Tcl_AppendResult (interp, + "no command specified: should be \"", + Tcl_GetString (objv [0]), " walk ", + W_USAGE, "\"", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements (interp, wcmd, &xcc, &xcv) != TCL_OK) { + return TCL_ERROR; + } else if (xcc == 0) { + goto no_command; + } + + xtype = WG_DFS; + xorder = WO_PRE; + xdir = WD_FORWARD; + + if (wtype && + (Tcl_GetIndexFromObj (interp, wtype, wtypes, + "search type", 0, &xtype) != TCL_OK)) { + return TCL_ERROR; + } + + if (worder && + (Tcl_GetIndexFromObj (interp, worder, worders, + "search order", 0, &xorder) != TCL_OK)) { + return TCL_ERROR; + } + + if (wdir && + (Tcl_GetIndexFromObj (interp, wdir, wdirs, + "search direction", 0, &xdir) != TCL_OK)) { + return TCL_ERROR; + } + + if (xtype == WG_BFS) { + if (xorder == WO_BOTH) { + Tcl_AppendResult (interp, + "unable to do a both-order breadth first walk", + NULL); + return TCL_ERROR; + } + if (xorder == WO_POST) { + Tcl_AppendResult (interp, + "unable to do a post-order breadth first walk", + NULL); + return TCL_ERROR; + } + } + + *type = xtype; + *order = xorder; + *dir = xdir; + *cc = xcc; + *cv = xcv; + + return TCL_OK; +} + +/* .................................................. */ + +int +g_walk (Tcl_Interp* interp, Tcl_Obj* go, GN* n, + int type, int order, int dir, + int cc, Tcl_Obj** cv) +{ + int ec, res, i; + Tcl_Obj** ev; + Tcl_Obj* la = NULL; + Tcl_Obj* lb = NULL; + + Tcl_HashTable v; + + /* Area to remember which nodes have been visited already */ + Tcl_InitHashTable (&v, TCL_ONE_WORD_KEYS); + + ec = cc + 3; + ev = NALLOC (ec, Tcl_Obj*); + + for (i=0;i<cc;i++) { + ev [i] = cv [i]; + Tcl_IncrRefCount (ev [i]); + } + + /* cc+0 action + * cc+1 graph ** + * cc+2 node + */ + + ev [cc+1] = go; + Tcl_IncrRefCount (ev [cc+1]); + + switch (type) { + case WG_DFS: + switch (order) { + case WO_BOTH: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb); + + res = walkdfsboth (interp, n, dir, &v, cc, ev, la, lb); + + Tcl_DecrRefCount (la); + Tcl_DecrRefCount (lb); + break; + + case WO_PRE: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + + res = walkdfspre (interp, n, dir, &v, cc, ev, la); + + Tcl_DecrRefCount (la); + break; + + case WO_POST: + la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la); + + res = walkdfspost (interp, n, dir, &v, cc, ev, la); + + Tcl_DecrRefCount (la); + break; + } + break; + + case WG_BFS: + switch (order) { + case WO_BOTH: + case WO_POST: Tcl_Panic ("impossible combination bfs/(both|post)"); break; + case WO_PRE: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + + res = walkbfspre (interp, n, dir, &v, cc, ev, la); + + Tcl_DecrRefCount (la); + break; + } + break; + } + + for (i=0; i<cc; i++) { + Tcl_DecrRefCount (ev [i]); + } + Tcl_DecrRefCount (ev [cc+1]); + ckfree ((char*) ev); + + Tcl_DeleteHashTable (&v); + + /* Error and Return are passed unchanged. Everything else is ok */ + + if (res == TCL_ERROR) {return res;} + if (res == TCL_RETURN) {return res;} + return TCL_OK; +} + + +/* .................................................. */ + +int +walk_invoke (Tcl_Interp* interp, GN* n, + int cc, Tcl_Obj** ev, Tcl_Obj* action) +{ + int res; + + /* cc+0 action ** + * cc+1 graph + * cc+2 node ** + */ + + ev [cc+0] = action; /* enter/leave */ + ev [cc+2] = n->base.name ; /* node */ + /* ec = cc+3 */ + + Tcl_IncrRefCount (ev [cc+0]); + Tcl_IncrRefCount (ev [cc+2]); + + res = Tcl_EvalObjv (interp, cc+3, ev, 0); + + Tcl_DecrRefCount (ev [cc+0]); + Tcl_DecrRefCount (ev [cc+2]); + + return res; +} + +/* .................................................. */ + +static int +walk_neighbours (GN* n, Tcl_HashTable* vn, int dir, + int* nc, GN*** nv) +{ + GLA* neigh; + GL* il; + int c, i; + GN** v; + + if (dir == WD_BACKWARD) { + neigh = &n->in; + } else { + neigh = &n->out; + } + + c = 0; + v = NULL; + + if (neigh->n) { + /* We make a copy of the neighbours. This emulates the behaviour of + * the Tcl implementation, which will walk to a neighbour of this + * node, even if the command moved it to a different node before it + * was reached by the loop here. If the node the neighbours is moved + * to was already visited nothing else will happen. Ortherwise the + * neighbours will be visited multiple times. + */ + + c = neigh->n; + v = NALLOC (c, GN*); + + if (dir == WD_BACKWARD) { + for (i=0, il = neigh->first; + il != NULL; + il = il->next) { + if (Tcl_FindHashEntry (vn, (char*) il->a->start->n)) continue; + ASSERT_BOUNDS (i, c); + v [i] = il->a->start->n; + i++; + } + } else { + for (i=0, il = neigh->first; + il != NULL; + il = il->next) { + if (Tcl_FindHashEntry (vn, (char*) il->a->end->n)) continue; + ASSERT_BOUNDS (i, c); + v [i] = il->a->end->n; + i++; + } + } + + c = i; + if (!c) { + ckfree ((char*) v); + v = NULL; + } + } + + *nc = c; + *nv = v; +} + +/* .................................................. */ + +static int +walkdfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v, + int cc, Tcl_Obj** ev, Tcl_Obj* action) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + */ + + int nc, res, new; + GN** nv; + + /* Current node before neighbours, action is 'enter'. */ + + res = walk_invoke (interp, n, cc, ev, action); + + if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + Tcl_CreateHashEntry (v, (char*) n, &new); + walk_neighbours (n, v, dir, &nc, &nv); + + if (nc) { + int i; + for (i = 0; i < nc; i++) { + /* Skip nodes already visited deeper in the recursion */ + if (Tcl_FindHashEntry (v, (char*) nv[i])) continue; + + res = walkdfspre (interp, nv [i], dir, v, cc, ev, action); + + /* continue cannot occur, were transformed into ok by the + * neighbour. + */ + + if (res != TCL_OK) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + return TCL_OK; +} + +static int +walkdfspost (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v, + int cc, Tcl_Obj** ev, Tcl_Obj* action) +{ + int nc, res, new; + GN** nv; + + /* Current node after neighbours, action is 'leave'. */ + + Tcl_CreateHashEntry (v, (char*) n, &new); + walk_neighbours (n, v, dir, &nc, &nv); + + if (nc) { + int i; + for (i = 0; i < nc; i++) { + /* Skip nodes already visited deeper in the recursion */ + if (Tcl_FindHashEntry (v, (char*) nv[i])) continue; + + res = walkdfspost (interp, nv [i], dir, v, cc, ev, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + res = walk_invoke (interp, n, cc, ev, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + return res; + } + + return TCL_OK; +} + +static int +walkdfsboth (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v, + int cc, Tcl_Obj** ev, Tcl_Obj* enter, Tcl_Obj* leave) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + */ + + int nc, res, new; + GN** nv; + + /* Current node before and after neighbours, action is 'enter' & 'leave'. */ + + res = walk_invoke (interp, n, cc, ev, enter); + + if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + Tcl_CreateHashEntry (v, (char*) n, &new); + walk_neighbours (n, v, dir, &nc, &nv); + + if (nc) { + int i; + for (i = 0; i < nc; i++) { + /* Skip nodes already visited deeper in the recursion */ + if (Tcl_FindHashEntry (v, (char*) nv[i])) continue; + + res = walkdfsboth (interp, nv [i], dir, v, cc, ev, enter, leave); + + /* continue cannot occur, were transformed into ok by the + * neighbour. + */ + + if (res != TCL_OK) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + res = walk_invoke (interp, n, cc, ev, leave); + + if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + return TCL_OK; +} + +static int +walkbfspre (Tcl_Interp* interp, GN* n, int dir, Tcl_HashTable* v, + int cc, Tcl_Obj** ev, Tcl_Obj* action) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + */ + + int nc, res, new; + GN** nv; + NLQ q; + + g_nlq_init (&q); + g_nlq_append (&q, n); + + while (1) { + n = g_nlq_pop (&q); + if (!n) break; + + /* Skip nodes already visited deeper in the recursion */ + if (Tcl_FindHashEntry (v, (char*) n)) continue; + + res = walk_invoke (interp, n, cc, ev, action); + + if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + g_nlq_clear (&q); + return res; + } + + Tcl_CreateHashEntry (v, (char*) n, &new); + walk_neighbours (n, v, dir, &nc, &nv); + + if (nc) { + int i; + for (i = 0; i < nc; i++) { + g_nlq_append (&q, nv [i]); + } + + ckfree ((char*) nv); + } + } + + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph/walk.h b/tcllib/modules/struct/graph/walk.h new file mode 100644 index 0000000..bae1436 --- /dev/null +++ b/tcllib/modules/struct/graph/walk.h @@ -0,0 +1,46 @@ +/* struct::graph - critcl - layer 1 declarations + * (c) Graph functions + */ + +#ifndef _G_WALK_H +#define _G_WALK_H 1 +/* .................................................. */ + +#include "tcl.h" +#include <ds.h> + +#define W_USAGE "node ?-dir forward|backward? ?-order pre|post|both? ?-type bfs|dfs? -command cmd" + +/* .................................................. */ + +enum wtypes { + WG_BFS, WG_DFS +}; + +enum worder { + WO_BOTH, WO_PRE, WO_POST +}; + +enum wdir { + WD_BACKWARD, WD_FORWARD +}; + +int g_walkoptions (Tcl_Interp* interp, + int objc, Tcl_Obj* const* objv, + int* type, int* order, int* dir, + int* cc, Tcl_Obj*** cv); + +int g_walk (Tcl_Interp* interp, Tcl_Obj* go, GN* n, + int type, int order, int dir, + int cc, Tcl_Obj** cv); + +/* .................................................. */ +#endif /* _G_WALK_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/graph1.man b/tcllib/modules/struct/graph1.man new file mode 100644 index 0000000..e548575 --- /dev/null +++ b/tcllib/modules/struct/graph1.man @@ -0,0 +1,375 @@ +[comment {-*- tcl -*-}] +[manpage_begin {struct::graph_v1} n 1.2.1] +[keywords cgraph] +[keywords graph] +[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate directed graph objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::graph [opt 1.2.1]] +[description] +[para] + +The [cmd ::struct::graph] command creates a new graph object with an +associated global Tcl command whose name is [arg graphName]. This +command may be used to invoke various operations on the graph. It has +the following general form: + +[list_begin definitions] +[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] + +[para] + +A directed graph is a structure containing two collections of +elements, called [emph nodes] and [emph arcs] respectively, together +with a relation ("connectivity") that places a general structure upon +the nodes and arcs. + +[para] + +Each arc is connected to two nodes, one of which is called the + +[emph source] and the other the [emph target]. This imposes a +direction upon the arc, which is said to go from the source to the +target. It is allowed that source and target of an arc are the same +node. Such an arc is called a [emph loop]. Whenever a node is source +or target of an arc both are said to be [emph adjacent]. This extends +into a relation between nodes, i.e. if two nodes are connected through +at least one arc they are said to be [emph adjacent] too. + +[para] + +Each node can be the source and target for any number of arcs. The +former are called the [emph {outgoing arcs}] of the node, the latter +the [emph {incoming arcs}] of the node. The number of edges in either +set is called the [emph in-] resp. the [emph out-degree] of the node. + +[para] + +In addition to maintaining the node and arc relationships, this graph +implementation allows any number of keyed values to be associated with +each node and arc. + +[para] + +The following commands are possible for graph objects: + +[list_begin definitions] + +[call [arg graphName] [method destroy]] + +Destroy the graph, including its storage space and associated command. + +[call [arg graphName] [method {arc append}] [arg arc] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +[arg arc]. If no [arg key] is specified, the key [const data] is +assumed. + +[call [arg graphName] [method {arc delete}] [arg arc] [opt "[arg arc] ..."]] + +Remove the specified arcs from the graph. + +[call [arg graphName] [method {arc exists}] [arg arc]] + +Return true if the specified [arg arc] exists in the graph. + +[call [arg graphName] [method {arc get}] [arg arc] [opt "-key [arg key]"]] + +Return the value associated with the key [arg key] for the [arg arc]. +If no key is specified, the key [const data] is assumed. + +[call [arg graphName] [method {arc getall}] [arg arc]] + +Returns a serialized list of key/value pairs (suitable for use with +[lb][cmd {array set}][rb]) for the [arg arc]. + +[call [arg graphName] [method {arc keys}] [arg arc]] + +Returns a list of keys for the [arg arc]. + +[call [arg graphName] [method {arc keyexists}] [arg arc] [opt "-key [arg key]"]] + +Return true if the specified [arg key] exists for the [arg arc]. If no +[arg key] is specified, the key [const data] is assumed. + +[call [arg graphName] [method {arc insert}] [arg start] [arg end] [opt [arg child]]] + +Insert an arc named [arg child] into the graph beginning at the node +[arg start] and ending at the node [arg end]. If the name of the new +arc is not specified the system will generate a unique name of the +form [emph arc][arg x]. + +[call [arg graphName] [method {arc lappend}] [arg arc] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg arc]. If no [arg key] is specified, the key +[const data] is assumed. + +[call [arg graphName] [method {arc set}] [arg arc] [opt "-key [arg key]"] [opt [arg value]]] + +Set or get one of the keyed values associated with an arc. If no key +is specified, the key [const data] is assumed. Each arc that is +added to a graph has the empty string assigned to the key + +[const data] automatically. An arc may have any number of keyed +values associated with it. If [arg value] is not specified, this +command returns the current value assigned to the key; if [arg value] +is specified, this command assigns that value to the key. + +[call [arg graphName] [method {arc source}] [arg arc]] + +Return the node the given [arg arc] begins at. + +[call [arg graphName] [method {arc target}] [arg arc]] + +Return the node the given [arg arc] ends at. + +[call [arg graphName] [method {arc unset}] [arg arc] [opt "-key [arg key]"]] + +Remove a keyed value from the arc [arg arc]. If no key is specified, +the key [const data] is assumed. + +[call [arg graphName] [method arcs] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]] + +Return a list of arcs in the graph. If no restriction is specified a +list containing all arcs is returned. Restrictions can limit the list +of returned arcs based on the nodes that are connected by the arc, on +the keyed values associated with the arc, or both. The restrictions +that involve connected nodes have a list of nodes as argument, +specified after the name of the restriction itself. + +[list_begin definitions] +[def [option -in]] + +Return a list of all arcs whose target is one of the nodes in the +[arg nodelist]. + +[def [option -out]] + +Return a list of all arcs whose source is one of the nodes in the +[arg nodelist]. + +[def [option -adj]] + +Return a list of all arcs adjacent to at least one of the nodes in the +[arg nodelist]. This is the union of the nodes returned by + +[option -in] and [option -out]. + +[def [option -inner]] + +Return a list of all arcs adjacent to two of the nodes in the + +[arg nodelist]. This is the set of arcs in the subgraph spawned by the +specified nodes. + +[def [option -embedding]] + +Return a list of all arcs adjacent to exactly one of the nodes in the +[arg nodelist]. This is the set of arcs connecting the subgraph +spawned by the specified nodes to the rest of the graph. + +[def "[option -key] [arg key]"] + +Limit the list of arcs that are returned to those arcs that have an +associated key [arg key]. + +[def "[option -value] [arg value]"] + +This restriction can only be used in combination with + +[option -key]. It limits the list of arcs that are returned to those +arcs whose associated key [arg key] has the value [arg value]. + +[list_end] +[para] + +The restrictions imposed by either [option -in], [option -out], +[option -adj], [option -inner], or [option -embedded] are applied +first. Specifying more than one of them is illegal. + +At last the restrictions set via [option -key] (and [option -value]) +are applied. +Specifying more than one [option -key] (and [option -value]) is +illegal. + +[call [arg graphName] [method {node append}] [arg node] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +[arg node]. If no [arg key] is specified, the key [const data] is +assumed. + +[call [arg graphName] [method {node degree}] [opt -in|-out] [arg node]] + +Return the number of arcs adjacent to the specified [arg node]. If one +of the restrictions [option -in] or [option -out] is given only the +incoming resp. outgoing arcs are counted. + +[call [arg graphName] [method {node delete}] [arg node] [opt "[arg node] ..."]] + +Remove the specified nodes from the graph. All of the nodes' arcs +will be removed as well to prevent unconnected arcs. + +[call [arg graphName] [method {node exists}] [arg node]] + +Return true if the specified [arg node] exists in the graph. + +[call [arg graphName] [method {node get}] [arg node] [opt "-key [arg key]"]] + +Return the value associated with the key [arg key] for the [arg node]. +If no key is specified, the key [const data] is assumed. + +[call [arg graphName] [method {node getall}] [arg node]] + +Returns a serialized list of key/value pairs (suitable for use with +[lb][cmd {array set}][rb]) for the [arg node]. + +[call [arg graphName] [method {node keys}] [arg node]] + +Returns a list of keys for the [arg node]. + +[call [arg graphName] [method {node keyexists}] [arg node] [opt "-key [arg key]"]] + +Return true if the specified [arg key] exists for the [arg node]. If +no [arg key] is specified, the key [const data] is assumed. + +[call [arg graphName] [method {node insert}] [opt [arg child]]] + +Insert a node named [arg child] into the graph. The nodes has no arcs +connected to it. If the name of the new child is not specified the +system will generate a unique name of the form [emph node][arg x]. + +[call [arg graphName] [method {node lappend}] [arg node] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg node]. If no [arg key] is specified, the key +[const data] is assumed. + +[call [arg graphName] [method {node opposite}] [arg node] [arg arc]] + +Return the node at the other end of the specified [arg arc], which has +to be adjacent to the given [arg node]. + +[call [arg graphName] [method {node set}] [arg node] [opt "-key [arg key]"] [opt [arg value]]] + +Set or get one of the keyed values associated with a node. If no key +is specified, the key [const data] is assumed. Each node that is +added to a graph has the empty string assigned to the key + +[const data] automatically. A node may have any number of keyed +values associated with it. If [arg value] is not specified, this +command returns the current value assigned to the key; if [arg value] +is specified, this command assigns that value to the key. + +[call [arg graphName] [method {node unset}] [arg node] [opt "-key [arg key]"]] + +Remove a keyed value from the node [arg node]. If no key is +specified, the key [method data] is assumed. + +[call [arg graphName] [method nodes] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]] + +Return a list of nodes in the graph. Restrictions can limit the list +of returned nodes based on neighboring nodes, or based on the keyed +values associated with the node. The restrictions that involve +neighboring nodes have a list of nodes as argument, specified after +the name of the restriction itself. + +[para] + +The possible restrictions are the same as for method + +[method arcs]. The set of nodes to return is computed as the union of +all source and target nodes for all the arcs satisfying the +restriction as defined for [method arcs]. + +[call [arg graphName] [method get] [opt "-key [arg key]"]] + +Return the value associated with the key [arg key] for the graph. If +no key is specified, the key [const data] is assumed. + +[call [arg graphName] [method getall]] + +Returns a serialized list of key/value pairs (suitable for use with +[lb][cmd {array set}][rb]) for the whole graph. + +[call [arg graphName] [method keys]] + +Returns a list of keys for the whole graph. + +[call [arg graphName] [method keyexists] [opt "-key [arg key]"]] + +Return true if the specified [arg key] exists for the whole graph. If no +[arg key] is specified, the key [const data] is assumed. + +[call [arg graphName] [method set] [opt "-key [arg key]"] [opt [arg value]]] + +Set or get one of the keyed values associated with a graph. If no key +is specified, the key [const data] is assumed. Each graph has the +empty string assigned to the key [const data] automatically. A graph +may have any number of keyed values associated with it. If [arg value] +is not specified, this command returns the current value assigned to +the key; if [arg value] is specified, this command assigns that value +to the key. + +[call [arg graphName] [method swap] [arg node1] [arg node2]] + +Swap the position of [arg node1] and [arg node2] in the graph. + +[call [arg graphName] [method unset] [opt "-key [arg key]"]] + +Remove a keyed value from the graph. If no key is specified, the key +[const data] is assumed. + +[call [arg graphName] [method walk] [arg node] [opt "-order [arg order]"] [opt "-type [arg type]"] [opt "-dir [arg direction]"] -command [arg cmd]] + +Perform a breadth-first or depth-first walk of the graph starting at +the node [arg node] going in either the direction of outgoing or +opposite to the incoming arcs. + +[para] + +The type of walk, breadth-first or depth-first, is determined by the +value of [arg type]; [const bfs] indicates breadth-first, + +[const dfs] indicates depth-first. Depth-first is the default. + +[para] + +The order of the walk, pre-order, post-order or both-order is +determined by the value of [arg order]; [const pre] indicates +pre-order, [const post] indicates post-order, [const both] indicates +both-order. Pre-order is the default. Pre-order walking means that a +node is visited before any of its neighbors (as defined by the + +[arg direction], see below). Post-order walking means that a parent is +visited after any of its neighbors. Both-order walking means that a +node is visited before [emph and] after any of its neighbors. The +combination of a bread-first walk with post- or both-order is illegal. + +[para] + +The direction of the walk is determined by the value of [arg dir]; +[const backward] indicates the direction opposite to the incoming +arcs, [const forward] indicates the direction of the outgoing arcs. + +[para] + +As the walk progresses, the command [arg cmd] will be evaluated at +each node, with the mode of the call ([const enter] or +[const leave]) and values [arg graphName] and the name of the current +node appended. For a pre-order walk, all nodes are [const enter]ed, for a +post-order all nodes are left. In a both-order walk the first visit of +a node [const enter]s it, the second visit [const leave]s it. + +[list_end] + +[vset CATEGORY {struct :: graph}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/graph1.tcl b/tcllib/modules/struct/graph1.tcl new file mode 100644 index 0000000..80c2459 --- /dev/null +++ b/tcllib/modules/struct/graph1.tcl @@ -0,0 +1,2154 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph1.tcl,v 1.5 2008/08/13 20:30:58 mic42 Exp $ + +# Create the namespace before determining cgraph vs. tcl +# Otherwise the loading 'struct.tcl' may get into trouble +# when trying to import commands from them + +namespace eval ::struct {} +namespace eval ::struct::graph {} + +# Try to load the cgraph package + +if {![catch {package require cgraph 0.6}]} { + # the cgraph package takes over, so we can return + return +} + +namespace eval ::struct {} +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # commands is the list of subcommands recognized by the graph + variable commands [list \ + "arc" \ + "arcs" \ + "destroy" \ + "get" \ + "getall" \ + "keys" \ + "keyexists" \ + "node" \ + "nodes" \ + "set" \ + "swap" \ + "unset" \ + "walk" \ + ] + + variable arcCommands [list \ + "append" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "set" \ + "source" \ + "target" \ + "unset" \ + ] + + variable nodeCommands [list \ + "append" \ + "degree" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "opposite" \ + "set" \ + "unset" \ + ] + + # Only export one command, the one used to instantiate a new graph + namespace export graph +} + +# ::struct::graph::graph -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph {{name ""}} { + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "graph${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval ::struct::graph::graph$name { + + # Set up the map for values associated with the graph itself + variable graphData + array set graphData {data ""} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + } + + # Create the command to manipulate the graph + interp alias {} ::$name {} ::struct::graph::GraphProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [list ::struct::graph::_$cmd $name] $args +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } { + variable arcCommands + set optlist [join $arcCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__arc_$cmd $name] $args +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + + foreach arc $args { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + # FRINK: nocheck + unset ::struct::graph::graph${name}::arc$arc + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + set outArcs($source) [lreplace $outArcs($source) $index $index] + + set index [lsearch -exact $inArcs($target) $arc] + set inArcs($target) [lreplace $inArcs($target) $index $index] + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existance of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ::struct::graph::graph${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array get data] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array names data] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existance of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } else { + set arc [lindex $args 0] + } + + if { [__arc_exists $name $arc] } { + error "arc \"$arc\" already exists in graph \"$name\"" + } + + if { ![__node_exists $name $source] } { + error "source node \"$source\" does not exist in graph \"$name\"" + } + + if { ![__node_exists $name $target] } { + error "target node \"$target\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::arc${arc} data + + # Set up the new arc + set data(data) "" + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name arc set $arc ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc append $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc lappend $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name arc unset\ + $arc ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set arcs [list] + + switch -exact -- $cond { + in { + # Result is all arcs going to at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. IOW the [info exists] below + # is never true. Found through coverage analysis + # and then trying to think up a testcase invoking + # the continue. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + out { + # Result is all arcs coming from at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + # See above 'in', same reasoning, one source per arc. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + adj { + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + inner { + # Result is all arcs running between nodes in the list. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + embedding { + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } + none { + set arcs [array names arcNodes] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredArcs [list] + + if {$haveKey} { + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc -key $key] + if {$haveValue} { + if {$aval == $value} { + lappend filteredArcs $arc + } + } else { + lappend filteredArcs $arc + } + } + } + } else { + set filteredArcs $arcs + } + + return $filteredArcs +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete ::struct::graph::graph$name + interp alias {} ::$name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + + return $data($key) +} + +# ::struct::graph::_getall -- +# +# Get a serialized list of key/value pairs from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array get data] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array names data] +} + +# ::struct::graph::_keyexists -- +# +# Test for existance of a given key in a graph. +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name {flag -key} {key data}} { + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::graphData data + return [info exists data($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } { + variable nodeCommands + set optlist [join $nodeCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__node_$cmd $name] $args +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + error "invalid option \"$opt\": should be -in or -out" + } + } + + # Validate the node + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do <set> arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + + foreach node $args { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + # FRINK: nocheck + unset ::struct::graph::graph${name}::node$node + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existance of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ::struct::graph::graph${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array get data] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array names data] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existance of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The namee of the new node. + +proc ::struct::graph::__node_insert {name args} { + + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set node [__generateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [__node_exists $name $node] } { + error "node \"$node\" already exists in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::node${node} data + + # Set up the new node + set inArcs($node) [list] + set outArcs($node) [list] + set data(data) "" + + return $node +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to <node,arc> + +proc ::struct::graph::__node_opposite {name node arc} { + if {![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if {![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name node set $node ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node append $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node lappend $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name node unset\ + $node ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set nodes [list] + array set coll {} + + switch -exact -- $cond { + in { + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + out { + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + adj { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + inner { + # Result is all nodes from the list! with at least one arc + # coming from or going to at least one node in the list of + # arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + embedding { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments, + # but not in the list itself! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + none { + set nodes [array names inArcs] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredNodes [list] + + if {$haveKey} { + foreach node $nodes { + catch { + set nval [__node_get $name $node -key $key] + if {$haveValue} { + if {$nval == $value} { + lappend filteredNodes $node + } + } else { + lappend filteredNodes $node + } + } + } + } else { + set filteredNodes $nodes + } + + return $filteredNodes +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args ?-key key? ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name args} { + upvar ::struct::graph::graph${name}::graphData data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name set ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + return $data($key) + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + if { ![__node_exists $name $node1] } { + error "node \"$node1\" does not exist in graph \"$name\"" + } + if { ![__node_exists $name $node2] } { + error "node \"$node2\" does not exist in graph \"$name\"" + } + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::node${node1} node1Vals + upvar ::struct::graph::graph${name}::node${node2} node2Vals + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node2] + } + foreach e $inArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node1] + } + foreach e $outArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2] + } + foreach e $outArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1] + } + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + set value1 [array get node1Vals] + unset node1Vals + array set node1Vals [array get node2Vals] + unset node2Vals + array set node2Vals $value1 + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::_unset {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name unset\ + ?-key key?\"" + } + + if { [info exists data($key)] } { + unset data($key) + } + + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk $node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd" + + if {[llength $args] > 8 || [llength $args] < 2} { + error "wrong # args: should be \"$usage\"" + } + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + "-dir" { + set dir [string tolower [lindex $args $i]] + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + error "invalid search order \"$order\": should be both,\ + pre or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + error "invalid search direction \"$dir\": should be\ + forward or backward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'graph::graph' into the general structure namespace. + namespace import -force graph::graph + namespace export graph +} +package provide struct::graph 1.2.1 diff --git a/tcllib/modules/struct/graph1.test b/tcllib/modules/struct/graph1.test new file mode 100644 index 0000000..13813f9 --- /dev/null +++ b/tcllib/modules/struct/graph1.test @@ -0,0 +1,1905 @@ +# -*- tcl -*- +# graph.test: tests for the graph structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: graph1.test,v 1.10 2009/11/03 17:38:30 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal graph1.tcl struct::graph +} + +# --------------------------------------------------- + +test graph1-0.1 {graph errors} { + struct::graph mygraph + catch {struct::graph mygraph} msg + mygraph destroy + set msg +} "command \"mygraph\" already exists, unable to create graph" + +test graph1-0.2 {graph errors} { + struct::graph mygraph + catch {mygraph} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph option ?arg arg ...?\"" + +test graph1-0.3 {graph errors} { + struct::graph mygraph + catch {mygraph foo} msg + mygraph destroy + set msg +} "bad option \"foo\": must be arc, arcs, destroy, get, getall, keys, keyexists, node, nodes, set, swap, unset, or walk" + +test graph1-0.4 {graph errors} { + catch {struct::graph set} msg + set msg +} "command \"set\" already exists, unable to create graph" + +test graph1-0.5 {graph errors} { + struct::graph mygraph + catch {mygraph arc foo} msg + mygraph destroy + set msg +} "bad option \"foo\": must be append, delete, exists, get, getall, insert, keys, keyexists, lappend, set, source, target, or unset" + +test graph1-0.6 {graph errors} { + struct::graph mygraph + catch {mygraph node foo} msg + mygraph destroy + set msg +} "bad option \"foo\": must be append, degree, delete, exists, get, getall, insert, keys, keyexists, lappend, opposite, set, or unset" + +# --------------------------------------------------- + +test graph1-1.1 {create} { + struct::graph mygraph + set result [string equal [info commands ::mygraph] "::mygraph"] + mygraph destroy + set result +} 1 + +test graph1-1.2 {create} { + set name [struct::graph] + set result [list $name [string equal [info commands ::$name] "::$name"]] + $name destroy + set result +} [list graph1 1] + +test graph1-1.3 {destroy} { + struct::graph mygraph + mygraph destroy + string equal [info commands ::mygraph] "" +} 1 + +# --------------------------------------------------- + +test graph1-2.1 {arc delete} { + struct::graph mygraph + catch {mygraph arc delete arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-2.2 {arc delete} { + struct::graph mygraph + + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc delete arc0 + + set result [mygraph arc exists arc0] + mygraph destroy + set result +} {0} + +# --------------------------------------------------- + +test graph1-3.1 {arc exists} { + struct::graph mygraph + set result [list] + lappend result [mygraph arc exists arc1] + mygraph node insert node1 + mygraph node insert node2 + mygraph arc insert node1 node2 arc1 + lappend result [mygraph arc exists arc1] + mygraph arc delete arc1 + lappend result [mygraph arc exists arc1] + mygraph destroy + set result +} {0 1 0} + +# --------------------------------------------------- + +test graph1-4.1 {arc get gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc get arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-4.2 {arc get gives error on bogus key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc get arc0 -key bogus} msg + mygraph destroy + set msg +} "invalid key \"bogus\" for arc \"arc0\"" + +test graph1-4.3 {arc get uses data as default key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 foobar + set result [mygraph arc get arc0] + mygraph destroy + set result +} "foobar" + +test graph1-4.4 {arc get respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key boom foobar + set result [mygraph arc get arc0 -key boom] + mygraph destroy + set result +} "foobar" + +# --------------------------------------------------- + +test graph1-5.1 {arc insert gives error on duplicate arc name} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" already exists in graph \"mygraph\"" + +test graph1-5.2 {arc insert creates and initializes arc} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [list ] + lappend result [mygraph arc exists arc0] + lappend result [mygraph arc source arc0] + lappend result [mygraph arc target arc0] + lappend result [mygraph arc set arc0] + mygraph destroy + set result +} {1 node0 node1 {}} + +test graph1-5.3 {arc insert arcs in correct location} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + + mygraph arc insert node0 node1 arc0 + mygraph arc insert node0 node1 arc1 + mygraph arc insert node0 node1 arc2 + set result [lsort [mygraph arcs -out node0]] + mygraph destroy + set result +} {arc0 arc1 arc2} + +test graph1-5.4 {arc insert gives error when trying to insert to a fake node} { + struct::graph mygraph + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} "source node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-5.5 {arc insert gives error when trying to insert to a fake node} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph arc insert node0 node1 arc0} msg + mygraph destroy + set msg +} "target node \"node1\" does not exist in graph \"mygraph\"" + +test graph1-5.6 {arc insert generates arc name when none is given} { + struct::graph mygraph + mygraph node insert n0 + + set result [list [mygraph arc insert n0 n0]] + lappend result [mygraph arc insert n0 n0] + mygraph arc insert n0 n0 arc3 + lappend result [mygraph arc insert n0 n0] + mygraph destroy + set result +} [list arc1 arc2 arc4] + +if {0} { + # if feature used, fix this test... + test graph1-5.6 {arc insert generates arc name when none is given} { + struct::graph mygraph + set result [list [mygraph insert root end]] + lappend result [mygraph insert root end] + mygraph insert root end arc3 + lappend result [mygraph insert root end] + mygraph destroy + set result + } [list arc1 arc2 arc4] ; # {} +} + +# --------------------------------------------------- + +test graph1-6.1 {arc set gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc set arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-6.2 {arc set with arc name gets/sets "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 foobar + set result [mygraph arc set arc0] + mygraph destroy + set result +} "foobar" + +test graph1-6.3 {arc set with arc name and key gets/sets key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key baz foobar + set result [list [mygraph arc set arc0] [mygraph arc set arc0 -key baz]] + mygraph destroy + set result +} [list "" "foobar"] + +test graph1-6.4 {arc set with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc set arc0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph arc set arc0 ?-key key? ?value?\"" + +test graph1-6.5 {arc set with bad args} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc set arc0 foo bar} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-6.6 {arc set with bad args} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc set arc0 foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-6.7 {arc set with bad key gives error} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc set arc0 -key foo} msg + mygraph destroy + set msg +} "invalid key \"foo\" for arc \"arc0\"" + +# --------------------------------------------------- + +test graph1-7.1 {arc source gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc source arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-7.2 {arc source} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc source arc0] + mygraph destroy + set result +} node0 + +# --------------------------------------------------- + +test graph1-8.1 {arc target gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc target arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-8.2 {arc target} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc target arc0] + mygraph destroy + set result +} node1 + +# --------------------------------------------------- + +test graph1-9.1 {arc unset gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc unset arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-9.2 {arc unset does not give error on bogus key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [catch {mygraph arc unset arc0 -key bogus}] + mygraph destroy + set result +} 0 + +test graph1-9.3 {arc unset removes a keyed value from a arc} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key foobar foobar + mygraph arc unset arc0 -key foobar + catch {mygraph arc get arc0 -key foobar} msg + mygraph destroy + set msg +} "invalid key \"foobar\" for arc \"arc0\"" + +test graph1-9.4 {arc unset requires -key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key foobar foobar + catch {mygraph arc unset arc0 flaboozle foobar} msg + mygraph destroy + set msg +} "invalid option \"flaboozle\": should be \"mygraph arc unset arc0 ?-key key?\"" + +# --------------------------------------------------- + +test graph1-10.1 {arcs} { + struct::graph mygraph + set result [mygraph arcs] + mygraph destroy + set result +} {} + +test graph1-10.2 {arcs} { + struct::graph mygraph + catch {mygraph arcs -foo} msg + mygraph destroy + set msg +} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value} + +test graph1-10.3 {arcs} { + struct::graph mygraph + catch {mygraph arcs -in} msg + mygraph destroy + set msg +} {no nodes specified: should be "mygraph arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"} + +test graph1-10.4 {arcs} { + struct::graph mygraph + catch {mygraph arcs -in node0} msg + mygraph destroy + set msg +} {node "node0" does not exist in graph "mygraph"} + +test graph1-10.5 {arcs} { + struct::graph mygraph + mygraph node insert node1 + mygraph node insert node2 + mygraph node insert node3 + mygraph node insert node4 + mygraph node insert node5 + mygraph node insert node6 + + mygraph arc insert node4 node1 arcA + mygraph arc insert node5 node2 arcB + mygraph arc insert node6 node3 arcC + mygraph arc insert node3 node1 arcD + mygraph arc insert node1 node2 arcE + mygraph arc insert node2 node3 arcF + + set result [list \ + [lsort [mygraph arcs ]] \ + \ + [lsort [mygraph arcs -in node1 node2 node3]] \ + [lsort [mygraph arcs -out node1 node2 node3]] \ + [lsort [mygraph arcs -adj node1 node2 node3]] \ + [lsort [mygraph arcs -inner node1 node2 node3]] \ + [lsort [mygraph arcs -embedding node1 node2 node3]] \ + \ + [lsort [mygraph arcs -in node4 node5 node6]] \ + [lsort [mygraph arcs -out node4 node5 node6]] \ + [lsort [mygraph arcs -adj node4 node5 node6]] \ + [lsort [mygraph arcs -inner node4 node5 node6]] \ + [lsort [mygraph arcs -embedding node4 node5 node6]] \ + ] + mygraph destroy + set result +} [list \ + {arcA arcB arcC arcD arcE arcF} \ + \ + {arcA arcB arcC arcD arcE arcF} \ + {arcD arcE arcF} \ + {arcA arcB arcC arcD arcE arcF} \ + {arcD arcE arcF} \ + {arcA arcB arcC} \ + \ + {} \ + {arcA arcB arcC} \ + {arcA arcB arcC} \ + {} \ + {arcA arcB arcC} \ + ] + +test graph1-10.6 {arcs} { + struct::graph mygraph + mygraph node insert node1 + mygraph node insert node2 + mygraph arc insert node1 node2 arcE + mygraph arc insert node2 node1 arcF + set result [lsort [mygraph arcs -adj node1 node2]] + mygraph destroy + set result +} {arcE arcF} + +test graph1-10.7 {arcs} { + struct::graph mygraph + mygraph node insert n0 + mygraph node insert n1 + mygraph arc insert n0 n1 a1 + mygraph arc insert n0 n1 a2 + mygraph arc set a1 -key foobar 1 + mygraph arc set a2 -key blubber 2 + catch {mygraph arcs -key foobar} msg + mygraph destroy + set msg +} {a1} + +test graph1-10.8 {arcs} { + struct::graph mygraph + mygraph node insert n0 + mygraph node insert n1 + mygraph arc insert n0 n1 a1 + mygraph arc insert n0 n1 a2 + mygraph arc set a1 -key foobar 1 + mygraph arc set a2 -key foobar 2 + catch {mygraph arcs -key foobar -value 1} msg + mygraph destroy + set msg +} {a1} + +test graph1-10.9 {arcs, multiple -key, illegal} { + struct::graph mygraph + catch {mygraph arcs -key foobar -value 1 -key foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-key"} + +test graph1-10.10 {arcs, multiple -value, illegal} { + struct::graph mygraph + catch {mygraph arcs -key foobar -value 1 -value foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-value"} + +test graph1-10.11 {arcs, multiple -in, illegal} { + struct::graph mygraph + catch {mygraph arcs -key foobar -in -value foo -in} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} + +test graph1-10.12 {arcs, -in / -out exclusion, illegal} { + struct::graph mygraph + catch {mygraph arcs -key foobar -out -value foo -in} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} + +# --------------------------------------------------- + +test graph1-11.1 {node degree} { + struct::graph mygraph + catch {mygraph node degree} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph node degree ?-in|-out? node\"" + +test graph1-11.2 {node degree} { + struct::graph mygraph + catch {mygraph node degree foo bar baz} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph node degree ?-in|-out? node\"" + +test graph1-11.3 {node degree} { + struct::graph mygraph + catch {mygraph node degree node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-11.4 {node degree} { + struct::graph mygraph + catch {mygraph node degree -foo node0} msg + mygraph destroy + set msg +} "invalid option \"-foo\": should be -in or -out" + +test graph1-11.5 {node degree} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph node insert node2 + mygraph node insert node3 + mygraph node insert node4 + mygraph node insert node5 + + mygraph arc insert node1 node2 arc0 + mygraph arc insert node3 node3 arc1 + mygraph arc insert node4 node5 arc2 + mygraph arc insert node4 node5 arc3 + mygraph arc insert node4 node5 arc4 + mygraph arc insert node5 node2 arc5 + + set result [list \ + [mygraph node degree node0] \ + [mygraph node degree -in node0] \ + [mygraph node degree -out node0] \ + [mygraph node degree node1] \ + [mygraph node degree -in node1] \ + [mygraph node degree -out node1] \ + [mygraph node degree node2] \ + [mygraph node degree -in node2] \ + [mygraph node degree -out node2] \ + [mygraph node degree node3] \ + [mygraph node degree -in node3] \ + [mygraph node degree -out node3] \ + [mygraph node degree node4] \ + [mygraph node degree -in node4] \ + [mygraph node degree -out node4] \ + [mygraph node degree node5] \ + [mygraph node degree -in node5] \ + [mygraph node degree -out node5] \ + ] + + mygraph destroy + set result +} [list 0 0 0 \ + 1 0 1 \ + 2 2 0 \ + 2 1 1 \ + 3 0 3 \ + 4 3 1 + ] + +# --------------------------------------------------- + +test graph1-12.1 {node delete} { + struct::graph mygraph + catch {mygraph node delete node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-12.2 {node delete} { + struct::graph mygraph + mygraph node insert node0 + mygraph node delete node0 + set result [mygraph node exists node0] + mygraph destroy + set result +} {0} + +test graph1-12.3 {node delete} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph node delete node0 + + set result [list \ + [mygraph node exists node0] \ + [mygraph node exists node1] \ + [mygraph arc exists arc0] \ + ] + mygraph destroy + set result +} {0 1 0} + +test graph1-12.4 {node delete} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph node delete node1 + + set result [list \ + [mygraph node exists node0] \ + [mygraph node exists node1] \ + [mygraph arc exists arc0] \ + ] + mygraph destroy + set result +} {1 0 0} + +# --------------------------------------------------- + +test graph1-13.1 {node exists} { + struct::graph mygraph + set result [list] + lappend result [mygraph node exists node1] + mygraph node insert node1 + lappend result [mygraph node exists node1] + mygraph node delete node1 + lappend result [mygraph node exists node1] + mygraph destroy + set result +} {0 1 0} + +# --------------------------------------------------- + +test graph1-14.1 {node get gives error on bogus node} { + struct::graph mygraph + catch {mygraph node get node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-14.2 {node get gives error on bogus key} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node get node0 -key bogus} msg + mygraph destroy + set msg +} "invalid key \"bogus\" for node \"node0\"" + +test graph1-14.3 {node get uses data as default key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 foobar + set result [mygraph node get node0] + mygraph destroy + set result +} "foobar" + +test graph1-14.4 {node get respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key boom foobar + set result [mygraph node get node0 -key boom] + mygraph destroy + set result +} "foobar" + +# --------------------------------------------------- + +test graph1-15.1 {node insert gives error on duplicate node name} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node insert node0} msg + mygraph destroy + set msg +} "node \"node0\" already exists in graph \"mygraph\"" + +test graph1-15.2 {node insert creates and initializes node} { + struct::graph mygraph + mygraph node insert node0 + set result [list ] + lappend result [mygraph node exists node0] + lappend result [mygraph node set node0] + mygraph destroy + set result +} {1 {}} + +test graph1-15.3 {node insert generates node name when none is given} { + struct::graph mygraph + set result [list [mygraph node insert]] + + lappend result [mygraph node insert] + mygraph node insert node3 + lappend result [mygraph node insert] + mygraph destroy + set result +} [list node1 node2 node4] + +if {0} { + # fix if this feature is used ... + test graph1-15.x {node insert generates node name when none is given} { + struct::graph mygraph + set result [list [mygraph node insert root end]] + lappend result [mygraph node insert root end] + mygraph node insert root end node3 + lappend result [mygraph node insert root end] + mygraph destroy + set result + } [list node1 node2 node4] ; # {} +} + +# --------------------------------------------------- + +test graph1-16.1 {node opposite gives error on bogus node} { + struct::graph mygraph + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-16.2 {node opposite gives error on bogus arc} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" + +test graph1-16.3 {node opposite gives error on bogus node/arc combination} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph node insert node2 + mygraph arc insert node1 node2 arc0 + + catch {mygraph node opposite node0 arc0} msg + mygraph destroy + set msg +} "node \"node0\" and arc \"arc0\" are not connected in graph \"mygraph\"" + +test graph1-16.4 {node opposite} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + + set result [list \ + [mygraph node opposite node0 arc0] \ + [mygraph node opposite node1 arc0] \ + ] + mygraph destroy + set result +} {node1 node0} + +test graph1-16.5 {node opposite} { + struct::graph mygraph + mygraph node insert node0 + mygraph arc insert node0 node0 arc0 + set result [mygraph node opposite node0 arc0] + mygraph destroy + set result +} {node0} + +# --------------------------------------------------- + +test graph1-17.1 {node set gives error on bogus node} { + struct::graph mygraph + catch {mygraph node set node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-17.2 {node set with node name gets/sets "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 foobar + set result [mygraph node set node0] + mygraph destroy + set result +} "foobar" + +test graph1-17.3 {node set with node name and key gets/sets key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key baz foobar + set result [list [mygraph node set node0] [mygraph node set node0 -key baz]] + mygraph destroy + set result +} [list "" "foobar"] + +test graph1-17.4 {node set with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node set node0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph node set node0 ?-key key? ?value?\"" + +test graph1-17.5 {node set with bad args} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node set node0 foo bar} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-17.6 {node set with bad args} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node set node0 foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-17.7 {node set with bad key gives error} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node set node0 -key foo} msg + mygraph destroy + set msg +} "invalid key \"foo\" for node \"node0\"" + +# --------------------------------------------------- + +test graph1-18.1 {node unset gives error on bogus node} { + struct::graph mygraph + catch {mygraph node unset node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-18.2 {node unset does not give error on bogus key} { + struct::graph mygraph + mygraph node insert node0 + set result [catch {mygraph node unset node0 -key bogus}] + mygraph destroy + set result +} 0 + +test graph1-18.3 {node unset removes a keyed value from a node} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key foobar foobar + mygraph node unset node0 -key foobar + catch {mygraph node get node0 -key foobar} msg + mygraph destroy + set msg +} "invalid key \"foobar\" for node \"node0\"" + +test graph1-18.4 {unset requires -key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key foobar foobar + catch {mygraph node unset node0 flaboozle foobar} msg + mygraph destroy + set msg +} "invalid option \"flaboozle\": should be \"mygraph node unset node0 ?-key key?\"" + +# --------------------------------------------------- + +test graph1-19.1 {nodes} { + struct::graph mygraph + set result [mygraph nodes] + mygraph destroy + set result +} {} + +test graph1-19.2 {nodes} { + struct::graph mygraph + catch {mygraph nodes -foo} msg + mygraph destroy + set msg +} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value} + +test graph1-19.3 {nodes} { + struct::graph mygraph + catch {mygraph nodes -in} msg + mygraph destroy + set msg +} {no nodes specified: should be "mygraph nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"} + +test graph1-19.4 {nodes} { + struct::graph mygraph + catch {mygraph nodes -in node0} msg + mygraph destroy + set msg +} {node "node0" does not exist in graph "mygraph"} + +test graph1-19.5 {nodes} { + struct::graph mygraph + mygraph node insert node1 + mygraph node insert node2 + mygraph node insert node3 + mygraph node insert node4 + mygraph node insert node5 + mygraph node insert node6 + + mygraph arc insert node4 node1 arcA + mygraph arc insert node5 node2 arcB + mygraph arc insert node6 node3 arcC + mygraph arc insert node3 node1 arcD + mygraph arc insert node1 node2 arcE + mygraph arc insert node2 node3 arcF + + set result [list \ + [lsort [mygraph nodes ]] \ + \ + [lsort [mygraph nodes -in node1 node2 node3]] \ + [lsort [mygraph nodes -out node1 node2 node3]] \ + [lsort [mygraph nodes -adj node1 node2 node3]] \ + [lsort [mygraph nodes -inner node1 node2 node3]] \ + [lsort [mygraph nodes -embedding node1 node2 node3]] \ + \ + [lsort [mygraph nodes -in node4 node5 node6]] \ + [lsort [mygraph nodes -out node4 node5 node6]] \ + [lsort [mygraph nodes -adj node4 node5 node6]] \ + [lsort [mygraph nodes -inner node4 node5 node6]] \ + [lsort [mygraph nodes -embedding node4 node5 node6]] \ + ] + mygraph destroy + set result +} [list \ + {node1 node2 node3 node4 node5 node6} \ + \ + {node1 node2 node3 node4 node5 node6} \ + {node1 node2 node3} \ + {node1 node2 node3 node4 node5 node6} \ + {node1 node2 node3} \ + {node4 node5 node6} \ + \ + {} \ + {node1 node2 node3} \ + {node1 node2 node3} \ + {} \ + {node1 node2 node3} \ + ] + +test graph1-19.6 {nodes} { + struct::graph mygraph + mygraph node insert node1 + mygraph node insert node2 + mygraph node insert node3 + + mygraph arc insert node1 node2 arcE + mygraph arc insert node1 node2 arcD + mygraph arc insert node2 node3 arcF + mygraph arc insert node2 node3 arcG + + set result [lsort [mygraph nodes -embedding node1 node3]] + mygraph destroy + set result +} {node2} + + +test graph1-19.7 {nodes} { + struct::graph mygraph + mygraph node insert n0 + mygraph node insert n1 + mygraph node set n0 -key foobar 1 + mygraph node set n1 -key blubber 2 + catch {mygraph nodes -key foobar} msg + mygraph destroy + set msg +} {n0} + +test graph1-19.8 {nodes} { + struct::graph mygraph + mygraph node insert n0 + mygraph node insert n1 + mygraph node set n0 -key foobar 1 + mygraph node set n1 -key foobar 2 + catch {mygraph nodes -key foobar -value 1} msg + mygraph destroy + set msg +} {n0} + +test graph1-19.9 {nodes, multiple -keys, illegal} { + struct::graph mygraph + catch {mygraph nodes -key foobar -key 1} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-key"} + +test graph1-19.10 {nodes, multiple -value, illegal} { + struct::graph mygraph + catch {mygraph nodes -key foobar -value 1 -value foo} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-value"} + +test graph1-19.11 {nodes, multiple -in, illegal} { + struct::graph mygraph + catch {mygraph nodes -key foobar -in -value foo -in} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} + +test graph1-19.12 {nodes, -in / -out exclusion, illegal} { + struct::graph mygraph + catch {mygraph nodes -key foobar -out -value foo -in} msg + mygraph destroy + set msg +} {invalid restriction: illegal multiple use of "-in"|"-out"|"-adj"|"-inner"|"-embedding"} + +# --------------------------------------------------- + +test graph1-20.1 {swap gives error when trying to swap non existant node} { + struct::graph mygraph + catch {mygraph swap node0 node1} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-20.2 {swap gives error when trying to swap non existant node} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph swap node0 node1} msg + mygraph destroy + set msg +} "node \"node1\" does not exist in graph \"mygraph\"" + +test graph1-20.3 {swap gives error when trying to swap node with self} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph swap node0 node0} msg + mygraph destroy + set msg +} "cannot swap node \"node0\" with itself" + +test graph1-20.4 {swap swaps node relationships correctly} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node0.1 + mygraph node insert node0.2 + mygraph node insert node0.1.1 + mygraph node insert node0.1.2 + + mygraph arc insert node0 node0.1 a1 + mygraph arc insert node0 node0.2 a2 + mygraph arc insert node0.1 node0.1.1 a3 + mygraph arc insert node0.1 node0.1.2 a4 + + mygraph swap node0 node0.1 + + set result [list \ + [lsort [mygraph nodes -out node0]] \ + [lsort [mygraph nodes -out node0.1]] \ + ] + mygraph destroy + set result +} {{node0.1.1 node0.1.2} {node0 node0.2}} + +test graph1-20.5 {swap swaps node relationships correctly} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node0.1 + mygraph node insert node0.2 + mygraph node insert node0.1.1 + mygraph node insert node0.1.2 + + mygraph arc insert node0 node0.1 a1 + mygraph arc insert node0 node0.2 a2 + mygraph arc insert node0.1 node0.1.1 a3 + mygraph arc insert node0.1 node0.1.2 a4 + + mygraph swap node0 node0.1.1 + + set result [list \ + [lsort [mygraph nodes -out node0]] \ + [lsort [mygraph nodes -out node0.1.1]] \ + ] + mygraph destroy + set result +} {{} {node0.1 node0.2}} + +test graph1-20.6 {swap swaps node relationships correctly} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node0.1 + mygraph node insert node0.2 + mygraph node insert node0.1.1 + mygraph node insert node0.1.2 + + mygraph arc insert node0 node0.1 a1 + mygraph arc insert node0 node0.2 a2 + mygraph arc insert node0.1 node0.1.1 a3 + mygraph arc insert node0.1 node0.1.2 a4 + + mygraph swap node0.1 node0 + + set result [list \ + [lsort [mygraph nodes -out node0]] \ + [lsort [mygraph nodes -out node0.1]] \ + ] + mygraph destroy + set result +} {{node0.1.1 node0.1.2} {node0 node0.2}} + +test graph1-22.1 {arc getall gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc getall arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" +test graph1-22.2 {arc getall gives error when key specified} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc getall arc0 -key data} msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-22.3 {arc getall with node name returns list of key/value pairs} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 foobar + mygraph arc set arc0 -key other thing + set results [mygraph arc getall arc0] + mygraph destroy + lsort $results +} "data foobar other thing" + +test graph1-23.1 {node getall gives error on bogus node} { + struct::graph mygraph + catch {mygraph node getall node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" +test graph1-23.2 {node getall gives error when key specified} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node getall node0 -key data} msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-23.3 {node getall with node name returns list of key/value pairs} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 foobar + mygraph node set node0 -key other thing + set results [mygraph node getall node0] + mygraph destroy + lsort $results +} "data foobar other thing" + +test graph1-24.1 {arc keys gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc keys arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" +test graph1-24.2 {arc keys gives error when key specified} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch { mygraph arc keys arc0 -key bogus } msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-24.3 {arc keys with arc name returns list of keys} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key other things + set results [mygraph arc keys arc0] + mygraph destroy + lsort $results +} "data other" + +test graph1-25.1 {node keys gives error on bogus node} { + struct::graph mygraph + catch {mygraph node keys node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" +test graph1-25.2 {node keys gives error when key specified} { + struct::graph mygraph + mygraph node insert node0 + catch { mygraph node keys node0 -key bogus } msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-25.3 {node keys with node name returns list of keys} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key other things + set results [mygraph node keys node0] + mygraph destroy + lsort $results +} "data other" + +test graph1-26.1 {arc keyexists gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc keyexists arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" +test graph1-26.2 {arc keyexists returns false on non-existant key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc keyexists arc0 -key bogus] + mygraph destroy + set result +} "0" +test graph1-26.3 {arc keyexists uses data as default key} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + set result [mygraph arc keyexists arc0] + mygraph destroy + set result +} "1" +test graph1-26.4 {arc keyexists respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key boom foobar + set result [mygraph arc keyexists arc0 -key boom] + mygraph destroy + set result +} "1" + +test graph1-27.1 {node keyexists gives error on bogus node} { + struct::graph mygraph + catch {mygraph node keyexists node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" +test graph1-27.2 {node keyexists returns false on non-existant key} { + struct::graph mygraph + mygraph node insert node0 + set result [mygraph node keyexists node0 -key bogus] + mygraph destroy + set result +} "0" +test graph1-27.3 {node keyexists uses data as default key} { + struct::graph mygraph + mygraph node insert node0 + set result [mygraph node keyexists node0] + mygraph destroy + set result +} "1" +test graph1-27.4 {node keyexists respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key boom foobar + set result [mygraph node keyexists node0 -key boom] + mygraph destroy + set result +} "1" + +test graph1-28.1 {arc append gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc append arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" +test graph1-28.2 {arc append with arc name appends to "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 foo + set result [mygraph arc append arc0 bar] + mygraph destroy + set result +} "foobar" +test graph1-28.3 {arc append with arc name and key appends key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key baz foo + set result [mygraph arc append arc0 -key baz bar] + mygraph destroy + set result +} "foobar" +test graph1-28.4 {arc append with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc append arc0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph arc append arc0 ?-key key? value\"" +test graph1-28.5 {arc append with bad args} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc append arc0 -foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"-foo\": should be -key" +test graph1-28.6 {arc append respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key baz foo + set result [mygraph arc append arc0 -key baz bar] + mygraph destroy + set result +} "foobar" + +test graph1-29.1 {arc lappend gives error on bogus arc} { + struct::graph mygraph + catch {mygraph arc lappend arc0} msg + mygraph destroy + set msg +} "arc \"arc0\" does not exist in graph \"mygraph\"" +test graph1-29.2 {arc lappend with node arc lappends to "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 foo + set result [mygraph arc lappend arc0 bar] + mygraph destroy + set result +} "foo bar" +test graph1-29.3 {arc lappend with arc name and key lappends key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key baz foo + set result [mygraph arc lappend arc0 -key baz bar] + mygraph destroy + set result +} "foo bar" +test graph1-29.4 {arc lappend with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc lappend arc0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph arc lappend arc0 ?-key key? value\"" +test graph1-29.5 {arc lappend with bad args} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + catch {mygraph arc lappend arc0 -foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"-foo\": should be -key" +test graph1-29.6 {arc lappend respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node insert node1 + mygraph arc insert node0 node1 arc0 + mygraph arc set arc0 -key baz foo + set result [mygraph arc lappend arc0 -key baz bar] + mygraph destroy + set result +} "foo bar" + +test graph1-30.1 {node append gives error on bogus node} { + struct::graph mygraph + catch {mygraph node append node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" +test graph1-30.2 {node append with node name appends to "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 foo + set result [mygraph node append node0 bar] + mygraph destroy + set result +} "foobar" +test graph1-30.3 {node append with node name and key appends key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key baz foo + set result [mygraph node append node0 -key baz bar] + mygraph destroy + set result +} "foobar" +test graph1-30.4 {node append with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node append node0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph node append node0 ?-key key? value\"" +test graph1-30.5 {node append with bad args} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node append node0 -foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"-foo\": should be -key" +test graph1-30.6 {node append respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key baz foo + set result [mygraph node append node0 -key baz bar] + mygraph destroy + set result +} "foobar" + +test graph1-31.1 {node lappend gives error on bogus node} { + struct::graph mygraph + catch {mygraph node lappend node0} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" +test graph1-32.2 {node lappend with node name lappends to "data" value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 foo + set result [mygraph node lappend node0 bar] + mygraph destroy + set result +} "foo bar" +test graph1-32.3 {node lappend with node name and key lappends key value} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key baz foo + set result [mygraph node lappend node0 -key baz bar] + mygraph destroy + set result +} "foo bar" +test graph1-32.4 {node lappend with too many args gives error} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node lappend node0 foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph node lappend node0 ?-key key? value\"" +test graph1-32.5 {node lappend with bad args} { + struct::graph mygraph + mygraph node insert node0 + catch {mygraph node lappend node0 -foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"-foo\": should be -key" +test graph1-32.6 {node lappend respects -key flag} { + struct::graph mygraph + mygraph node insert node0 + mygraph node set node0 -key baz foo + set result [mygraph node lappend node0 -key baz bar] + mygraph destroy + set result +} "foo bar" + + +# --------------------------------------------------- + +proc makegraph {} { + struct::graph mygraph + + mygraph node insert i + mygraph node insert ii + mygraph node insert iii + mygraph node insert iv + mygraph node insert v + mygraph node insert vi + mygraph node insert vii + mygraph node insert viii + mygraph node insert ix + + mygraph arc insert i ii 1 + mygraph arc insert ii iii 2 + mygraph arc insert ii iii 3 + mygraph arc insert ii iii 4 + mygraph arc insert iii iv 5 + mygraph arc insert iii iv 6 + mygraph arc insert iv v 7 + mygraph arc insert v vi 8 + mygraph arc insert vi viii 9 + mygraph arc insert viii i 10 + mygraph arc insert i ix 11 + mygraph arc insert ix ix 12 + mygraph arc insert i vii 13 + mygraph arc insert vii vi 14 +} + + +test graph1-21.1 {walk with too few args} {badTest} { + struct::graph mygraph + catch {mygraph walk} msg + mygraph destroy + set msg +} "no value given for parameter \"node\" to \"::struct::graph::_walk\"" + +test graph1-21.2 {walk with too few args} { + struct::graph mygraph + catch {mygraph walk node0} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" + +test graph1-21.3 {walk with too many args} { + struct::graph mygraph + catch {mygraph walk node0 -foo bar -baz boo -foo2 boo -foo3 baz -foo4 baz} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" + +test graph1-21.4 {walk with fake node} { + struct::graph mygraph + catch {mygraph walk node0 -command {}} msg + mygraph destroy + set msg +} "node \"node0\" does not exist in graph \"mygraph\"" + +test graph1-21.5 {walk using unknown option} { + makegraph + catch {mygraph walk i -foo x -command {}} msg + mygraph destroy + set msg +} "unknown option \"-foo\": should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" + +test graph1-21.6 {walk with empty command} { + makegraph + catch {mygraph walk i -command {}} msg + mygraph destroy + set msg +} "no command specified: should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" + +test graph1-21.7 {walk with illegal specifications} { + makegraph + catch {mygraph walk i -command foo -type foo} msg + mygraph destroy + set msg +} "invalid search type \"foo\": should be dfs, or bfs" + +test graph1-21.8 {walk with illegal specifications} { + makegraph + catch {mygraph walk i -command foo -type dfs -dir oneway} msg + mygraph destroy + set msg +} "invalid search direction \"oneway\": should be forward or backward" + +test graph1-21.9 {walk with illegal specifications} { + makegraph + catch {mygraph walk i -command foo -type dfs -dir forward -order none} msg + mygraph destroy + set msg +} "invalid search order \"none\": should be both, pre or post" + + +test graph1-21.10 {forward pre-order dfs is default walk} { + makegraph + set t [list ] + mygraph walk i -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph i enter mygraph ii enter mygraph iii \ + enter mygraph iv enter mygraph v enter mygraph vi \ + enter mygraph viii enter mygraph ix enter mygraph vii \ + ] + +test graph1-21.11 {forward post-order dfs walk} { + makegraph + set t [list ] + mygraph walk i -order post -command {lappend t} + mygraph destroy + set t +} [list \ + leave mygraph viii leave mygraph vi leave mygraph v \ + leave mygraph iv leave mygraph iii leave mygraph ii \ + leave mygraph ix leave mygraph vii leave mygraph i \ + ] + +test graph1-21.12 {forward both-order dfs walk} { + makegraph + set t [list ] + mygraph walk i -order both -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph i enter mygraph ii enter mygraph iii \ + enter mygraph iv enter mygraph v enter mygraph vi \ + enter mygraph viii leave mygraph viii leave mygraph vi \ + leave mygraph v leave mygraph iv leave mygraph iii \ + leave mygraph ii enter mygraph ix leave mygraph ix \ + enter mygraph vii leave mygraph vii leave mygraph i \ + ] + +test graph1-21.13 {forward pre-order bfs walk} { + makegraph + set t [list ] + mygraph walk i -type bfs -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph i enter mygraph ii enter mygraph ix \ + enter mygraph vii enter mygraph iii enter mygraph vi \ + enter mygraph iv enter mygraph viii enter mygraph v \ + ] + +test graph1-21.14 {backward pre-order bfs walk} { + makegraph + set t [list ] + mygraph walk ix -type bfs -dir backward -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph ix enter mygraph i enter mygraph viii \ + enter mygraph vi enter mygraph v enter mygraph vii \ + enter mygraph iv enter mygraph iii enter mygraph ii \ + ] + +test graph1-21.15 {backward pre-order dfs walk} { + makegraph + set t [list ] + mygraph walk ix -dir backward -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph ix enter mygraph i enter mygraph viii \ + enter mygraph vi enter mygraph v enter mygraph iv \ + enter mygraph iii enter mygraph ii enter mygraph vii \ + ] + +test graph1-21.16 {backward post-order dfs walk} { + makegraph + set t [list ] + mygraph walk ix -dir backward -order post -command {lappend t} + mygraph destroy + set t +} [list \ + leave mygraph ii leave mygraph iii leave mygraph iv \ + leave mygraph v leave mygraph vii leave mygraph vi \ + leave mygraph viii leave mygraph i leave mygraph ix \ + ] + +test graph1-21.17 {backward both-order dfs walk} { + makegraph + set t [list ] + mygraph walk ix -dir backward -order both -command {lappend t} + mygraph destroy + set t +} [list \ + enter mygraph ix enter mygraph i enter mygraph viii \ + enter mygraph vi enter mygraph v enter mygraph iv \ + enter mygraph iii enter mygraph ii leave mygraph ii \ + leave mygraph iii leave mygraph iv leave mygraph v \ + enter mygraph vii leave mygraph vii leave mygraph vi \ + leave mygraph viii leave mygraph i leave mygraph ix \ + ] + +test graph1-21.18 {walk, option without value} { + makegraph + catch {mygraph walk ix -type dfs -order} msg + mygraph destroy + set msg +} "value for \"-order\" missing: should be \"mygraph walk ix ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\"" + +test graph1-21.19 {forward post-order bfs walk not implemented} { + makegraph + catch {mygraph walk i -order post -type bfs -command {lappend t}} msg + mygraph destroy + set msg +} {unable to do a post-order breadth first walk} + +test graph1-21.20 {forward both-order bfs walk not implemented} { + makegraph + catch {mygraph walk i -order both -type bfs -command {lappend t}} msg + mygraph destroy + set msg +} {unable to do a both-order breadth first walk} + +test graph1-21.21 {backward post-order bfs walk not implemented} { + makegraph + catch {mygraph walk i -dir backward -order post -type bfs -command {lappend t}} msg + mygraph destroy + set msg +} {unable to do a post-order breadth first walk} + +test graph1-21.22 {backward both-order bfs walk not implemented} { + makegraph + catch {mygraph walk i -dir backward -order both -type bfs -command {lappend t}} msg + mygraph destroy + set msg +} {unable to do a both-order breadth first walk} + + +# --------------------------------------------------- + +test graph1-33.1 {get gives error on bogus key} { + struct::graph mygraph + catch {mygraph get -key bogus} msg + mygraph destroy + set msg +} "invalid key \"bogus\" for graph \"mygraph\"" + +test graph1-33.2 {get uses data as default key} { + struct::graph mygraph + mygraph set foobar + set result [mygraph get] + mygraph destroy + set result +} "foobar" + +test graph1-33.3 {get respects -key flag} { + struct::graph mygraph + mygraph set -key boom foobar + set result [mygraph get -key boom] + mygraph destroy + set result +} "foobar" + +# --------------------------------------------------- + +test graph1-34.1 {set alone gets/sets "data" value} { + struct::graph mygraph + mygraph set foobar + set result [mygraph set] + mygraph destroy + set result +} "foobar" + +test graph1-34.2 {set with key gets/sets key value} { + struct::graph mygraph + mygraph set -key baz foobar + set result [list [mygraph set] [mygraph set -key baz]] + mygraph destroy + set result +} [list "" "foobar"] + +test graph1-34.3 {set with too many args gives error} { + struct::graph mygraph + catch {mygraph set foo bar baz boo} msg + mygraph destroy + set msg +} "wrong # args: should be \"mygraph set ?-key key? ?value?\"" + +test graph1-34.4 {set with bad args} { + struct::graph mygraph + catch {mygraph set foo bar} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-34.5 {set with bad args} { + struct::graph mygraph + catch {mygraph set foo bar baz} msg + mygraph destroy + set msg +} "invalid option \"foo\": should be key" + +test graph1-34.6 {set with bad key gives error} { + struct::graph mygraph + catch {mygraph set -key foo} msg + mygraph destroy + set msg +} "invalid key \"foo\" for graph \"mygraph\"" + +# --------------------------------------------------- + +test graph1-35.1 {unset does not give error on bogus key} { + struct::graph mygraph + set result [catch {mygraph unset -key bogus}] + mygraph destroy + set result +} 0 + +test graph1-35.2 {unset removes a keyed value} { + struct::graph mygraph + mygraph set -key foobar foobar + mygraph unset -key foobar + catch {mygraph get -key foobar} msg + mygraph destroy + set msg +} "invalid key \"foobar\" for graph \"mygraph\"" + +test graph1-35.3 {unset requires -key} { + struct::graph mygraph + mygraph set -key foobar foobar + catch {mygraph unset flaboozle foobar} msg + mygraph destroy + set msg +} "invalid option \"flaboozle\": should be \"mygraph unset ?-key key?\"" + +# --------------------------------------------------- + +test graph1-36.1 {getall gives error when key specified} { + struct::graph mygraph + catch {mygraph getall -key data} msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-36.2 {getall returns list of key/value pairs} { + struct::graph mygraph + mygraph set foobar + mygraph set -key other thing + set results [mygraph getall] + mygraph destroy + lsort $results +} "data foobar other thing" + +test graph1-37.1 {keys gives error when key specified} { + struct::graph mygraph + catch { mygraph keys -key bogus } msg + mygraph destroy + set msg +} "wrong # args: should be none" +test graph1-37.2 {keys returns list of keys} { + struct::graph mygraph + mygraph set -key other things + set results [mygraph keys] + mygraph destroy + lsort $results +} "data other" + +test graph1-38.1 {keyexists returns false on non-existant key} { + struct::graph mygraph + set result [mygraph keyexists -key bogus] + mygraph destroy + set result +} "0" +test graph1-38.2 {keyexists uses data as default key} { + struct::graph mygraph + set result [mygraph keyexists] + mygraph destroy + set result +} "1" +test graph1-38.3 {keyexists respects -key flag} { + struct::graph mygraph + mygraph set -key boom foobar + set result [mygraph keyexists -key boom] + mygraph destroy + set result +} "1" + +# --------------------------------------------------- +# Big cleanup, get out of the way of graph v2. +# +# Currently the order of test files is graph, graph1, graphops, and +# the first and last use graph v2. Leaving the class command of graph +# v1 in place will mess up the handling of accelerated operations. + +rename struct::graph {} + +# --------------------------------------------------- +testsuiteCleanup diff --git a/tcllib/modules/struct/graph_c.tcl b/tcllib/modules/struct/graph_c.tcl new file mode 100644 index 0000000..b910f7b --- /dev/null +++ b/tcllib/modules/struct/graph_c.tcl @@ -0,0 +1,160 @@ +# graphc.tcl -- +# +# Implementation of a graph data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_graphc +package provide struct_graphc 2.1 +package require Tcl 8.2 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders graph/*.h + critcl::csources graph/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include <global.h> + #include <objcmd.h> + #include <graph.h> + + #define USAGE "?name ?=|:=|as|deserialize source??" + + static void gg_delete (ClientData clientData) + { + /* Release the whole graph. */ + g_delete ((G*) clientData); + } + } + + # Main command, graph creation. + + critcl::ccommand graph_critcl {dummy interp objc objv} { + /* Syntax */ + /* - epsilon |1 */ + /* - name |2 */ + /* - name =|:=|as|deserialize source |4 */ + + CONST char* name; + G* g; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = gg_new (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, Tcl_GetString (fqn), &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + /* Construction with immediate initialization */ + /* through deserialization */ + + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + G_ASSIGN, G_IS, G_AS, G_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + g = g_new (); + + switch (srctype) { + case G_ASSIGN: + case G_AS: + case G_IS: + if (g_ms_assign (interp, g, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case G_DESER: + if (g_deserialize (g, interp, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + g = g_new (); + } + + g->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + g_objcmd, (ClientData) g, + gg_delete); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/tcllib/modules/struct/graph_tcl.tcl b/tcllib/modules/struct/graph_tcl.tcl new file mode 100644 index 0000000..a9e4ef7 --- /dev/null +++ b/tcllib/modules/struct/graph_tcl.tcl @@ -0,0 +1,3244 @@ +# graph_tcl.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net> +# Copyright (c) 2008 by Alejandro Paz <vidriloco@gmail.com> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph_tcl.tcl,v 1.5 2009/11/26 04:42:16 andreas_kupries Exp $ + +package require Tcl 8.4 +package require struct::list +package require struct::set + +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # Only export one command, the one used to instantiate a new graph + namespace export graph_tcl +} + +# ::struct::graph::graph_tcl -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "graph${counter}" + } + 2 { + # Standard call. New empty graph. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype graph + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval $name { + + # Set up the map for values associated with the graph itself + variable graphAttr + array set graphAttr {} + + # Set up the node attribute mapping + variable nodeAttr + array set nodeAttr {} + + # Set up the arc attribute mapping + variable arcAttr + array set arcAttr {} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + + # Set up a counter for use in creating attribute arrays. + variable nextAttr + set nextAttr 0 + + # Set up a map from arcs to their weights. Note: Only arcs + # which actually have a weight are recorded in the map, to + # keep memory usage down. + variable arcWeight + array set arcWeight {} + } + + # Create the command to manipulate the graph + interp alias {} $name {} ::struct::graph::GraphProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + graph {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::_= -- +# +# Assignment operator. Copies the source graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# source Name of the graph object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::graph::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::graph::_--> -- +# +# Reverse assignment operator. Copies this graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object to copy +# dest Name of the graph object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::graph::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::graph::_append -- +# +# Append a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_append {name key value} { + variable ${name}::graphAttr + return [append graphAttr($key) $value] +} + +# ::struct::graph::_lappend -- +# +# lappend a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_lappend {name key value} { + variable ${name}::graphAttr + return [lappend graphAttr($key) $value] +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + # Split the args into command and args components + + set sub __arc_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__arc_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__arc_delete name arc arc..."} + } + + foreach arc $args {CheckMissingArc $name $arc} + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcAttr + variable ${name}::arcWeight + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + + if {[info exists arcAttr($arc)]} { + unset ${name}::$arcAttr($arc) ;# Note the double indirection here + unset arcAttr($arc) + } + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + ldelete outArcs($source) $index + + set index [lsearch -exact $inArcs($target) $arc] + ldelete inArcs($target) $index + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existence of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_flip -- +# +# Exchanges origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# +# Results: +# None + +proc ::struct::graph::__arc_flip {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + set oldtarget [lindex $arcNodes($arc) 1] + + if {[string equal $oldsource $oldtarget]} return + + set newtarget $oldsource + set newsource $oldtarget + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key has to be invalid. + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + + upvar ${name}::$arcAttr($arc) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array get data $pattern] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array names data $pattern] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existence of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key cannot exist. + return 0 + } + + upvar ${name}::$arcAttr($arc) data + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } elseif { [llength $args] > 1 } { + return {wrong # args: should be "::struct::graph::__arc_insert name source target ?arc?"} + } else { + set arc [lindex $args 0] + } + + CheckDuplicateArc $name $arc + CheckMissingNode $name $source {source } + CheckMissingNode $name $target {target } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Set up the new arc + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_rename -- +# +# Rename a arc in place. +# +# Arguments: +# name name of the graph. +# arc Name of the arc to rename +# newname The new name of the arc. +# +# Results: +# The new name of the arc. + +proc ::struct::graph::__arc_rename {name arc newname} { + CheckMissingArc $name $arc + CheckDuplicateArc $name $newname + + set oldname $arc + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, arc independent. + # - nodeAttr - not required, arc independent. + # - counters - not required + + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcWeight + + # Arc relocation + + set arcNodes($newname) [set nodes $arcNodes($oldname)] + unset arcNodes($oldname) + + # Update the two nodes ... + foreach {start end} $nodes break + + set pos [lsearch -exact $inArcs($end) $oldname] + lset inArcs($end) $pos $newname + + set pos [lsearch -exact $outArcs($start) $oldname] + lset outArcs($start) $pos $newname + + if {[info exists arcAttr($oldname)]} { + set arcAttr($newname) $arcAttr($oldname) + unset arcAttr($oldname) + } + + if {[info exists arcWeight($oldname)]} { + set arcWeight($newname) $arcWeight($oldname) + unset arcWeight($oldname) + } + + return $newname +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name arc set arc key ?value?\"" + } + CheckMissingArc $name $arc + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__arc_get $name $arc $key] + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [append data($key) $value] +} + +# ::struct::graph::__arc_attr -- +# +# Return attribute data for one key and multiple arcs, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping arcs to attribute data. + +proc ::struct::graph::__arc_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -arcs {arclist} + # t attr key -glob arcpattern + # t attr key -regexp arcpattern + + variable ${name}::arcAttr + + set usage "wrong # args: should be \"[list $name] arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to arcs which can have the attribute + # in question. + + set arcs [array names arcAttr] + } else { + # Determine a list of arcs to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -arcs { + # This is the only branch where we have to + # perform an explicit restriction to the + # arcs which have attributes. + set arcs {} + foreach n $value { + if {![info exists arcAttr($n)]} continue + lappend arcs $n + } + } + -glob { + set arcs [array names arcAttr $value] + } + -regexp { + set arcs {} + foreach n [array names arcAttr] { + if {![regexp -- $value $n]} continue + lappend arcs $n + } + } + default { + return -code error "bad type \"$mode\": must be -arcs, -glob, or -regexp" + } + } + } + + # Without possibly matching arcs + # the result has to be empty. + + if {![llength $arcs]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $arcs { + upvar ${name}::$arcAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_nodes -- +# +# Return a list containing both source and target nodes of the arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# nodes list containing the names of the connected nodes node. +# None + +proc ::struct::graph::__arc_nodes {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return $arcNodes($arc) +} + +# ::struct::graph::__arc_move-target -- +# +# Change the destination node of the specified arc. +# The arc is rotated around its origin to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-target {name arc newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::inArcs + + set oldtarget [lindex $arcNodes($arc) 1] + if {[string equal $oldtarget $newtarget]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_move-source -- +# +# Change the origin node of the specified arc. +# The arc is rotated around its destination to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-source {name arc newsource} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + + variable ${name}::arcNodes + variable ${name}::outArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {[string equal $oldsource $newsource]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + return +} + +# ::struct::graph::__arc_move -- +# +# Changes both origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move {name arc newsource newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {![string equal $oldsource $newsource]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + } + + set oldtarget [lindex $arcNodes($arc) 1] + if {![string equal $oldtarget $newtarget]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + } + return +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # nothing to do. + return + } + + upvar ${name}::$arcAttr($arc) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this arc, squash the whole array. + unset arcAttr($arc) + unset data + } + return +} + +# ::struct::graph::__arc_getunweighted -- +# +# Return the arcs which have no weight defined. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs without weights. + +proc ::struct::graph::__arc_getunweighted {name} { + variable ${name}::arcNodes + variable ${name}::arcWeight + return [struct::set difference \ + [array names arcNodes] \ + [array names arcWeight]] +} + +# ::struct::graph::__arc_getweight -- +# +# Get the weight given to an arc in a graph. +# Throws an error if the arc has no weight defined for it. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# weight The weight defined for the arc. + +proc ::struct::graph::__arc_getweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {![info exists arcWeight($arc)]} { + return -code error "arc \"$arc\" has no weight" + } + return $arcWeight($arc) +} + +# ::struct::graph::__arc_setunweighted -- +# +# Define a weight for all arcs which have no weight defined. +# After this call no arc will be unweighted. +# +# Arguments: +# name name of the graph. +# defval weight to give to all unweighted arcs +# +# Results: +# None + +proc ::struct::graph::__arc_setunweighted {name {weight 0}} { + variable ${name}::arcWeight + foreach arc [__arc_getunweighted $name] { + set arcWeight($arc) $weight + } + return +} + +# ::struct::graph::__arc_setweight -- +# +# Define a weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# weight the weight to set for the arc +# +# Results: +# weight The new weight + +proc ::struct::graph::__arc_setweight {name arc weight} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + set arcWeight($arc) $weight + return $weight +} + +# ::struct::graph::__arc_unsetweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_unsetweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + return +} + +# ::struct::graph::__arc_hasweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_hasweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + return [info exists arcWeight($arc)] +} + +# ::struct::graph::__arc_weights -- +# +# Return the arcs and weights for all arcs which have such. +# +# Arguments: +# name name of the graph. +# +# Results: +# aw dictionary mapping arcs to their weights. + +proc ::struct::graph::__arc_weights {name} { + variable ${name}::arcWeight + return [array get arcWeight] +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + CheckE $name arcs $args + + switch -exact -- $cond { + none {set arcs [ArcsNONE $name]} + in {set arcs [ArcsIN $name $condNodes]} + out {set arcs [ArcsOUT $name $condNodes]} + adj {set arcs [ArcsADJ $name $condNodes]} + inner {set arcs [ArcsINN $name $condNodes]} + embedding {set arcs [ArcsEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set arcs [ArcsKV $name $key $value $arcs] + } elseif {$haveKey} { + set arcs [ArcsK $name $key $arcs] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set arcs [uplevel 1 [list ::struct::list filter $arcs $fcmd]] + } + + return $arcs +} + +proc ::struct::graph::ArcsIN {name cn} { + # arcs -in. "Arcs going into the node set" + # + # ARC/in (NS) := { a | target(a) in NS } + + # The result is all arcs going to at least one node in the set + # 'cn' of nodes. + + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. Therefore there is no need + # to keep track of arcs to avoid duplicates. + + variable ${name}::inArcs + + set arcs {} + foreach node $cn { + foreach e $inArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsOUT {name cn} { + # arcs -out. "Arcs coming from the node set" + # + # ARC/out (NS) := { a | source(a) in NS } + + # The result is all arcs coming from at least one node in the list + # of arguments. + + variable ${name}::outArcs + + set arcs {} + foreach node $cn { + foreach e $outArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsADJ {name cn} { + # arcs -adj. "Arcs adjacent to the node set" + # + # ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) + + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + return [struct::set union \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + array set coll {} + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsINN {name cn} { + # arcs -adj. "Arcs inside the node set" + # + # ARC/inner (NS) := ARC/in (NS) * ARC/out (NS) + + # Result is all arcs running between nodes + # in the list. + + return [struct::set intersect \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + # Second iteration over outgoing arcs not + # required. Any arc found above would be found here as + # well, and arcs not recognized above can't be + # recognized by the out loop either. + } + } +} + +proc ::struct::graph::ArcsEMB {name cn} { + # arcs -adj. "Arcs bordering the node set" + # + # ARC/emb (NS) := ARC/inner (NS) - ARC/adj (NS) + # <=> (ARC/in + ARC/out) - (ARC/in * ARC/out) + # <=> (ARC/in - ARC/out) + (ARC/out - ARC/in) + # <=> symmetric difference (ARC/in, ARC/out) + + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + return [struct::set symdiff \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsNONE {name} { + variable ${name}::arcNodes + return [array names arcNodes] +} + +proc ::struct::graph::ArcsKV {name key value arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc $key] + if {$aval == $value} { + lappend filteredArcs $arc + } + } + } + return $filteredArcs +} + +proc ::struct::graph::ArcsK {name key arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + __arc_get $name $arc $key + lappend filteredArcs $arc + } + } + return $filteredArcs +} + +# ::struct::graph::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# serial Serialized graph to copy from. +# +# Results: +# Nothing. + +proc ::struct::graph::_deserialize {name serial} { + # As we destroy the original graph as part of + # the copying process we don't have to deal + # with issues like node names from the new graph + # interfering with the old ... + + # I. Get the serialization of the source graph + # and check it for validity. + + CheckSerialization $serial \ + gattr nattr aattr ina outa arcn arcw + + # Get all the relevant data into the scope + + variable ${name}::graphAttr + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::nextAttr + variable ${name}::arcWeight + + # Kill the existing information and insert the new + # data in their place. + + array unset inArcs * + array unset outArcs * + array set inArcs [array get ina] + array set outArcs [array get outa] + unset ina outa + + array unset arcNodes * + array set arcNodes [array get arcn] + unset arcn + + array unset arcWeight * + array set arcWeight [array get arcw] + unset arcw + + set nextAttr 0 + foreach a [array names nodeAttr] { + unset ${name}::$nodeAttr($a) + } + foreach a [array names arcAttr] { + unset ${name}::$arcAttr($a) + } + foreach n [array names nattr] { + GenAttributeStorage $name node $n + array set ${name}::$nodeAttr($n) $nattr($n) + } + foreach a [array names aattr] { + GenAttributeStorage $name arc $a + array set ${name}::$arcAttr($a) $aattr($a) + } + + array unset graphAttr * + array set graphAttr $gattr + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + parray inArcs + parray outArcs + parray arcNodes + parray nodeAttr + parray arcAttr + parray graphAttr + parray arcWeight + puts ___________________________________ + } + return +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + variable ${name}::nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name key} { + variable ${name}::graphAttr + if { ![info exists graphAttr($key)] } { + return -code error "invalid key \"$key\" for graph \"$name\"" + } + return $graphAttr($key) +} + +# ::struct::graph::_getall -- +# +# Get an attribute dictionary from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name {pattern *}} { + variable ${name}::graphAttr + return [array get graphAttr $pattern] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name {pattern *}} { + variable ${name}::graphAttr + return [array names graphAttr $pattern] +} + +# ::struct::graph::_keyexists -- +# +# Test for existence of a given key in a graph. +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name key} { + variable ${name}::graphAttr + return [info exists graphAttr($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + # Split the args into command and args components + set sub __node_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__node_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + return -code error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {return -code error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + return -code error "bad option \"$opt\": must be -in or -out" + } + } + + # Validate the node + + CheckMissingNode $name $node + + variable ${name}::inArcs + variable ${name}::outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do <set> arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {return -code error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__node_delete name node node..."} + } + foreach node $args {CheckMissingNode $name $node} + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::nodeAttr + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + + if {[info exists nodeAttr($node)]} { + unset ${name}::$nodeAttr($node) + unset nodeAttr($node) + } + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existence of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$nodeAttr($node) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array get data $pattern] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array names data $pattern] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existence of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key cannot exist. + return 0 + } + + upvar ${name}::$nodeAttr($node) data + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The name of the new node. + +proc ::struct::graph::__node_insert {name args} { + if {[llength $args] == 0} { + # No node name was given; generate a unique one + set args [list [__generateUniqueNodeName $name]] + } else { + foreach node $args {CheckDuplicateNode $name $node} + } + + variable ${name}::inArcs + variable ${name}::outArcs + + foreach node $args { + # Set up the new node + set inArcs($node) {} + set outArcs($node) {} + } + + return $args +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to <node,arc> + +proc ::struct::graph::__node_opposite {name node arc} { + CheckMissingNode $name $node + CheckMissingArc $name $arc + + variable ${name}::arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + return -code error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name node set node key ?value?\"" + } + CheckMissingNode $name $node + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name node $node + } + upvar ${name}::$nodeAttr($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__node_get $name $node $key] + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [append data($key) $value] +} + +# ::struct::graph::__node_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::graph::__node_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::nodeAttr + + set usage "wrong # args: should be \"[list $name] node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names nodeAttr] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists nodeAttr($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names nodeAttr $value] + } + -regexp { + set nodes {} + foreach n [array names nodeAttr] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error "bad type \"$mode\": must be -glob, -nodes, or -regexp" + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$nodeAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$nodeAttr($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset nodeAttr($node) + unset data + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + CheckE $name nodes $args + + switch -exact -- $cond { + none {set nodes [NodesNONE $name]} + in {set nodes [NodesIN $name $condNodes]} + out {set nodes [NodesOUT $name $condNodes]} + adj {set nodes [NodesADJ $name $condNodes]} + inner {set nodes [NodesINN $name $condNodes]} + embedding {set nodes [NodesEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set nodes [NodesKV $name $key $value $nodes] + } elseif {$haveKey} { + set nodes [NodesK $name $key $nodes] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set nodes [uplevel 1 [list ::struct::list filter $nodes $fcmd]] + } + + return $nodes +} + +proc ::struct::graph::NodesIN {name cn} { + # nodes -in. + # "Neighbours with arcs going into the node set" + # + # NODES/in (NS) := { source(a) | a in ARC/in (NS) } + + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + variable ${name}::inArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesOUT {name cn} { + # nodes -out. + # "Neighbours with arcs coming from the node set" + # + # NODES/out (NS) := { target(a) | a in ARC/out (NS) } + + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + variable ${name}::outArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesADJ {name cn} { + # nodes -adj. + # "Neighbours of the node set" + # + # NODES/adj (NS) := NODES/in (NS) + NODES/out (NS) + + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + return [struct::set union \ + [NodesIN $name $cn] \ + [NodesOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesINN {name cn} { + # nodes -adj. + # "Inner node of the node set" + # + # NODES/inner (NS) := NODES/adj (NS) * NS + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # + # I.e the adjacent nodes also in the set. + + return [struct::set intersect \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set intersect/union + # directly, intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesEMB {name cn} { + # nodes -embedding. + # "Embedding nodes for the node set" + # + # NODES/emb (NS) := NODES/adj (NS) - NS + + # Result is all nodes with at least one arc coming from or going + # to at least one node in the set, but not in the set itself + # + # I.e the adjacent nodes not in the set. + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # I.e the adjacent nodes still in the set. + + return [struct::set difference \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set diff/union directly, + # intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesNONE {name} { + variable ${name}::inArcs + return [array names inArcs] +} + +proc ::struct::graph::NodesKV {name key value nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + set nval [__node_get $name $node $key] + if {$nval == $value} { + lappend filteredNodes $node + } + } + } + return $filteredNodes +} + +proc ::struct::graph::NodesK {name key nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + __node_get $name $node $key + lappend filteredNodes $node + } + } + return $filteredNodes +} + +# ::struct::graph::__node_rename -- +# +# Rename a node in place. +# +# Arguments: +# name name of the graph. +# node Name of the node to rename +# newname The new name of the node. +# +# Results: +# The new name of the node. + +proc ::struct::graph::__node_rename {name node newname} { + CheckMissingNode $name $node + CheckDuplicateNode $name $newname + + set oldname $node + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, node independent. + # - arcAttr - not required, node independent. + # - counters - not required + + variable ${name}::nodeAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Node relocation + + set inArcs($newname) [set in $inArcs($oldname)] + unset inArcs($oldname) + set outArcs($newname) [set out $outArcs($oldname)] + unset outArcs($oldname) + + if {[info exists nodeAttr($oldname)]} { + set nodeAttr($newname) $nodeAttr($oldname) + unset nodeAttr($oldname) + } + + # Update all relevant arcs. + # 8.4: lset ... + + foreach a $in { + set arcNodes($a) [list [lindex $arcNodes($a) 0] $newname] + } + foreach a $out { + set arcNodes($a) [list $newname [lindex $arcNodes($a) 1]] + } + + return $newname +} + +# ::struct::graph::_serialize -- +# +# Serialize a graph object (partially) into a transportable value. +# If only a subset of nodes is serialized the result will be a sub- +# graph in the mathematical sense of the word: These nodes and all +# arcs which are only between these nodes. No arcs to modes outside +# of the listed set. +# +# Arguments: +# name Name of the graph. +# args list of nodes to place into the serialized graph +# +# Results: +# A list structure describing the part of the graph which was serialized. + +proc ::struct::graph::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # graph are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + variable ${name}::arcNodes + variable ${name}::arcWeight + variable ${name}::inArcs + + set all 0 + if {[llength $args] > 0} { + set nodes [luniq $args] + foreach n $nodes {CheckMissingNode $name $n} + if {[llength $nodes] == [array size inArcs]} { + set all 1 + } + } else { + set nodes [array names inArcs] + set all 1 + } + + if {$all} { + set arcs [array names arcNodes] + } else { + set arcs [eval [linsert $nodes 0 _arcs $name -inner]] + } + + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::graphAttr + + set na {} + set aa {} + array set np {} + + # node indices, attribute data ... + set i 0 + foreach n $nodes { + set np($n) [list $i] + incr i 3 + + if {[info exists nodeAttr($n)]} { + upvar ${name}::$nodeAttr($n) data + lappend np($n) [array get data] + } else { + lappend np($n) {} + } + } + + # arc dictionary + set arcdata {} + foreach a $arcs { + foreach {src dst} $arcNodes($a) break + # Arc information + + set arc [list $a] + lappend arc [lindex $np($dst) 0] + if {[info exists arcAttr($a)]} { + upvar ${name}::$arcAttr($a) data + lappend arc [array get data] + } else { + lappend arc {} + } + + # Add weight information, if there is any. + + if {[info exists arcWeight($a)]} { + lappend arc $arcWeight($a) + } + + # Add the information to the node + # indices ... + + lappend np($src) $arc + } + + # Combine the transient data into one result. + + set result [list] + foreach n $nodes { + lappend result $n + lappend result [lindex $np($n) 1] + lappend result [lrange $np($n) 2 end] + } + lappend result [array get graphAttr] + + return $result +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to modify or query +# args ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name set key ?value?\"" + } + if { [llength $args] > 0 } { + variable ${name}::graphAttr + return [set graphAttr($key) [lindex $args end]] + } else { + # Getting a value + return [_get $name $key] + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + CheckMissingNode $name $node1 + CheckMissingNode $name $node2 + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + variable ${name}::outArcs + variable ${name}::inArcs + variable ${name}::arcNodes + variable ${name}::nodeAttr + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) {lset arcNodes($e) end $node2} + foreach e $inArcs($node2) {lset arcNodes($e) end $node1} + foreach e $outArcs($node1) {lset arcNodes($e) 0 $node2} + foreach e $outArcs($node2) {lset arcNodes($e) 0 $node1} + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. But also + # simpler as we just have to swap/move the array + # reference + + if { + [set ia [info exists nodeAttr($node1)]] || + [set ib [info exists nodeAttr($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $nodeAttr($node1) + set nodeAttr($node1) $nodeAttr($node2) + set nodeAttr($node2) $tmp + } elseif {$ia} { + set nodeAttr($node2) $nodeAttr($node1) + unset nodeAttr($node1) + } elseif {$ib} { + set nodeAttr($node1) $nodeAttr($node2) + unset nodeAttr($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::_unset {name key} { + variable ${name}::graphAttr + if {[info exists graphAttr($key)]} { + unset graphAttr($key) + } + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type bfs|dfs? -command cmd" + + if {[llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + CheckMissingNode $name $node + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + switch -glob -- $flag { + "-type" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set type [string tolower [lindex $args $i]] + } + "-order" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set order [string tolower [lindex $args $i]] + } + "-command" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set cmd [lindex $args $i] + } + "-dir" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set dir [string tolower [lindex $args $i]] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + return -code error "bad search order \"$order\": must be both,\ + pre, or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + return -code error "bad search direction \"$dir\": must be\ + backward or forward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + # Bug 2420330. Note: The visited node may be + # multiple times on the stack (neighbour of more + # than one node). Remove all occurences. + while {[set index [lsearch -exact $st $node]] != -1} { + set st [lreplace $st $index $index] + } + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + return -code error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ::struct::graph::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the graph containing the node +# type Type of object for the attribute +# obj Name of the node or arc which got attributes. +# +# Results: +# none + +proc ::struct::graph::GenAttributeStorage {name type obj} { + variable ${name}::nextAttr + upvar ${name}::${type}Attr attribute + + set attr "a[incr nextAttr]" + set attribute($obj) $attr + return +} + +proc ::struct::graph::CheckMissingArc {name arc} { + if {![__arc_exists $name $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckMissingNode {name node {prefix {}}} { + if {![__node_exists $name $node]} { + return -code error "${prefix}node \"$node\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateArc {name arc} { + if {[__arc_exists $name $arc]} { + return -code error "arc \"$arc\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateNode {name node} { + if {[__node_exists $name $node]} { + return -code error "node \"$node\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckE {name what arguments} { + + # Discriminate between conditions and nodes + + upvar 1 haveCond haveCond ; set haveCond 0 + upvar 1 haveKey haveKey ; set haveKey 0 + upvar 1 key key ; set key {} + upvar 1 haveValue haveValue ; set haveValue 0 + upvar 1 value value ; set value {} + upvar 1 haveFilter haveFilter ; set haveFilter 0 + upvar 1 fcmd fcmd ; set fcmd {} + upvar 1 cond cond ; set cond "none" + upvar 1 condNodes condNodes ; set condNodes {} + + set wa_usage "wrong # args: should be \"$name $what ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + + for {set i 0} {$i < [llength $arguments]} {incr i} { + set arg [lindex $arguments $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $arguments $i] + set haveKey 1 + } + -value { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $arguments $i] + set haveValue 1 + } + -filter { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveFilter} { + return -code error {invalid restriction: illegal multiple use of "-filter"} + } + + incr i + set fcmd [lindex $arguments $i] + set haveFilter 1 + } + -* { + return -code error "bad restriction \"$arg\": must be -adj, -embedding,\ + -filter, -in, -inner, -key, -out, or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + return -code error $wa_usage + } + + # Remove duplicates. Note: lsort -unique is not present in Tcl + # 8.2, thus not usable here. + + array set nx {} + foreach c $condNodes {set nx($c) .} + set condNodes [array names nx] + unset nx + + # Make sure that the specified nodes exist! + foreach node $condNodes {CheckMissingNode $name $node} + } + + if {$haveValue && !$haveKey} { + return -code error {invalid restriction: use of "-value" without "-key"} + } + + return +} + +proc ::struct::graph::CheckSerialization {ser gavar navar aavar inavar outavar arcnvar arcwvar} { + upvar 1 \ + $gavar graphAttr \ + $navar nodeAttr \ + $aavar arcAttr \ + $inavar inArcs \ + $outavar outArcs \ + $arcnvar arcNodes \ + $arcwvar arcWeight + + array set nodeAttr {} + array set arcAttr {} + array set inArcs {} + array set outArcs {} + array set arcNodes {} + array set arcWeight {} + + # Overall length ok ? + if {[llength $ser] % 3 != 1} { + return -code error \ + "error in serialization: list length not 1 mod 3." + } + + # Attribute length ok ? Dictionary! + set graphAttr [lindex $ser end] + if {[llength $graphAttr] % 2} { + return -code error \ + "error in serialization: malformed graph attribute dictionary." + } + + # Basic decoder pass + + foreach {node attr narcs} [lrange $ser 0 end-1] { + if {![info exists inArcs($node)]} { + set inArcs($node) [list] + } + set outArcs($node) [list] + + # Attribute length ok ? Dictionary! + if {[llength $attr] % 2} { + return -code error \ + "error in serialization: malformed node attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $attr]} { + set nodeAttr($node) $attr + } + + foreach arcd $narcs { + if { + ([llength $arcd] != 3) && + ([llength $arcd] != 4) + } { + return -code error \ + "error in serialization: arc information length not 3 or 4." + } + + foreach {arc dst aattr} $arcd break + + if {[info exists arcNodes($arc)]} { + return -code error \ + "error in serialization: duplicate definition of arc \"$arc\"." + } + + # Attribute length ok ? Dictionary! + if {[llength $aattr] % 2} { + return -code error \ + "error in serialization: malformed arc attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $aattr]} { + set arcAttr($arc) $aattr + } + + # Remember weight data if it was specified. + if {[llength $arcd] == 4} { + set arcWeight($arc) [lindex $arcd 3] + } + + # Destination reference ok ? + if { + ![string is integer -strict $dst] || + ($dst % 3) || + ($dst < 0) || + ($dst >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad arc destination reference \"$dst\"." + } + + # Get destination and reconstruct the + # various relationships. + + set dstnode [lindex $ser $dst] + + set arcNodes($arc) [list $node $dstnode] + lappend inArcs($dstnode) $arc + lappend outArcs($node) $arc + } + } + + # Duplicate node names ? + + if {[array size outArcs] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Ok. The data is now ready for the caller. + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::graph::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::graph::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::graph::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +proc ::struct::graph::luniq {list} { + array set _ {} + set result [list] + foreach e $list { + if {[info exists _($e)]} {continue} + lappend result $e + set _($e) . + } + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'graph::graph' into the general structure namespace + # for pickup by the main management. + + namespace import -force graph::graph_tcl +} + diff --git a/tcllib/modules/struct/graphops.man b/tcllib/modules/struct/graphops.man new file mode 100644 index 0000000..f988109 --- /dev/null +++ b/tcllib/modules/struct/graphops.man @@ -0,0 +1,1318 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::graph::op n 0.11.3] +[keywords {adjacency list}] +[keywords {adjacency matrix}] +[keywords adjacent] +[keywords {approximation algorithm}] +[keywords arc] +[keywords {articulation point}] +[keywords {augmenting network}] +[keywords {augmenting path}] +[keywords bfs] +[keywords bipartite] +[keywords {blocking flow}] +[keywords bridge] +[keywords {complete graph}] +[keywords {connected component}] +[keywords {cut edge}] +[keywords {cut vertex}] +[keywords degree] +[keywords {degree constrained spanning tree}] +[keywords diameter] +[keywords dijkstra] +[keywords distance] +[keywords eccentricity] +[keywords edge] +[keywords {flow network}] +[keywords graph] +[keywords heuristic] +[keywords {independent set}] +[keywords isthmus] +[keywords {level graph}] +[keywords {local searching}] +[keywords loop] +[keywords matching] +[keywords {max cut}] +[keywords {maximum flow}] +[keywords {minimal spanning tree}] +[keywords {minimum cost flow}] +[keywords {minimum degree spanning tree}] +[keywords {minimum diameter spanning tree}] +[keywords neighbour] +[keywords node] +[keywords radius] +[keywords {residual graph}] +[keywords {shortest path}] +[keywords {squared graph}] +[keywords {strongly connected component}] +[keywords subgraph] +[keywords {travelling salesman}] +[keywords vertex] +[keywords {vertex cover}] +[copyright {2008 Alejandro Paz <vidriloco@gmail.com>}] +[copyright {2008 (docs) Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[copyright {2009 Michal Antoniewski <antoniewski.m@gmail.com>}] +[moddesc {Tcl Data Structures}] +[titledesc {Operation for (un)directed graph objects}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::graph::op [opt 0.11.3]] +[comment {[require struct::graph [opt 2.3]] }] +[comment {[require struct::list [opt 1.5]] }] +[comment {[require struct::set [opt 2.2.3]] }] +[description] +[para] + +The package described by this document, [package struct::graph::op], +is a companion to the package [package struct::graph]. It provides a +series of common operations and algorithms applicable to (un)directed +graphs. + +[para] + +Despite being a companion the package is not directly dependent on +[package struct::graph], only on the API defined by that +package. I.e. the operations of this package can be applied to any and +all graph objects which provide the same API as the objects created +through [package struct::graph]. + +[section {Operations}] + +[list_begin definitions] + +[call [cmd struct::graph::op::toAdjacencyMatrix] [arg g]] + +This command takes the graph [arg g] and returns a nested list +containing the adjacency matrix of [arg g]. + +[para] + +The elements of the outer list are the rows of the matrix, the inner +elements are the column values in each row. The matrix has "[var n]+1" +rows and columns, with the first row and column (index 0) containing +the name of the node the row/column is for. All other elements are +boolean values, [const True] if there is an arc between the 2 nodes +of the respective row and column, and [const False] otherwise. + +[para] + +Note that the matrix is symmetric. It does not represent the +directionality of arcs, only their presence between nodes. It is also +unable to represent parallel arcs in [arg g]. + +[call [cmd struct::graph::op::toAdjacencyList] [arg G] [opt [arg options]...]] + +Procedure creates for input graph [arg G], it's representation as [term "Adjacency List"]. +It handles both directed and undirected graphs (default is undirected). +It returns dictionary that for each node (key) returns list of nodes adjacent +to it. When considering weighted version, for each adjacent node there is also +weight of the edge included. + +[para] +[list_begin definitions] +[def Arguments:] + +[list_begin arguments] +[arg_def {Graph object} G input] +A graph to convert into an [term "Adjacency List"]. + +[list_end][comment {-- arguments --}] + +[def Options:] +[list_begin options] +[opt_def -directed] + +By default [arg G] is operated as if it were an [term {Undirected graph}]. +Using this option tells the command to handle [arg G] as the directed graph it is. + +[opt_def -weights] + +By default any weight information the graph [arg G] may have is ignored. +Using this option tells the command to put weight information into the result. +In that case it is expected that all arcs have a proper weight, and an error +is thrown if that is not the case. + +[list_end][comment {-- options --}] +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::kruskal] [arg g]] + +This command takes the graph [arg g] and returns a list containing the +names of the arcs in [arg g] which span up a minimum weight spanning tree +(MST), or, in the case of an un-connected graph, a minimum weight spanning +forest (except for the 1-vertex components). Kruskal's algorithm is used +to compute the tree or forest. + +This algorithm has a time complexity of [term {O(E*log E)}] or [term {O(E* log V)}], +where [term V] is the number of vertices and [term E] is the number of edges +in graph [arg g]. + +[para] + +The command will throw an error if one or more arcs in [arg g] have no +weight associated with them. + +[para] + +A note regarding the result, the command refrains from explicitly +listing the nodes of the MST as this information is implicitly +provided in the arcs already. + +[call [cmd struct::graph::op::prim] [arg g]] + +This command takes the graph [arg g] and returns a list containing the +names of the arcs in [arg g] which span up a minimum weight spanning tree +(MST), or, in the case of an un-connected graph, a minimum weight spanning +forest (except for the 1-vertex components). Prim's algorithm is used to +compute the tree or forest. + +This algorithm has a time complexity between [term {O(E+V*log V)}] and [term {O(V*V)}], +depending on the implementation (Fibonacci heap + Adjacency list versus +Adjacency Matrix). As usual [term V] is the number of vertices and +[term E] the number of edges in graph [arg g]. + +[para] + +The command will throw an error if one or more arcs in [arg g] have no +weight associated with them. + +[para] + +A note regarding the result, the command refrains from explicitly +listing the nodes of the MST as this information is implicitly +provided in the arcs already. + +[call [cmd struct::graph::op::isBipartite?] [arg g] [opt [arg bipartvar]]] + +This command takes the graph [arg g] and returns a boolean value +indicating whether it is bipartite ([const true]) or not +([const false]). If the variable [arg bipartvar] is specified the two +partitions of the graph are there as a list, if, and only if the graph +is bipartit. If it is not the variable, if specified, is not touched. + +[call [cmd struct::graph::op::tarjan] [arg g]] + +This command computes the set of [emph {strongly connected}] +components (SCCs) of the graph [arg g]. The result of the command is a +list of sets, each of which contains the nodes for one of the SCCs of +[arg g]. The union of all SCCs covers the whole graph, and no two SCCs +intersect with each other. + +[para] + +The graph [arg g] is [term acyclic] if all SCCs in the result contain +only a single node. The graph [arg g] is [term {strongly connected}] +if the result contains only a single SCC containing all nodes of +[arg g]. + +[call [cmd struct::graph::op::connectedComponents] [arg g]] + +This command computes the set of [emph connected] components (CCs) of +the graph [arg g]. The result of the command is a list of sets, each +of which contains the nodes for one of the CCs of [arg g]. The union +of all CCs covers the whole graph, and no two CCs intersect with each +other. + +[para] + +The graph [arg g] is [term connected] if the result contains only a +single SCC containing all nodes of [arg g]. + +[call [cmd struct::graph::op::connectedComponentOf] [arg g] [arg n]] + +This command computes the [emph connected] component (CC) of the graph +[arg g] containing the node [arg n]. The result of the command is a +sets which contains the nodes for the CC of [arg n] in [arg g]. + +[para] + +The command will throw an error if [arg n] is not a node of the graph +[arg g]. + +[call [cmd struct::graph::op::isConnected?] [arg g]] + +This is a convenience command determining whether the graph [arg g] is +[term connected] or not. The result is a boolean value, [const true] +if the graph is connected, and [const false] otherwise. + +[call [cmd struct::graph::op::isCutVertex?] [arg g] [arg n]] + +This command determines whether the node [arg n] in the graph [arg g] +is a [term {cut vertex}] (aka [term {articulation point}]). The result +is a boolean value, [const true] if the node is a cut vertex, and +[const false] otherwise. + +[para] + +The command will throw an error if [arg n] is not a node of the graph +[arg g]. + +[call [cmd struct::graph::op::isBridge?] [arg g] [arg a]] + +This command determines whether the arc [arg a] in the graph [arg g] +is a [term bridge] (aka [term {cut edge}], or [term isthmus]). The +result is a boolean value, [const true] if the arc is a bridge, and +[const false] otherwise. + +[para] + +The command will throw an error if [arg a] is not an arc of the graph +[arg g]. + +[call [cmd struct::graph::op::isEulerian?] [arg g] [opt [arg tourvar]]] + +This command determines whether the graph [arg g] is [term eulerian] +or not. The result is a boolean value, [const true] if the graph is +eulerian, and [const false] otherwise. + +[para] + +If the graph is eulerian and [arg tourvar] is specified then an euler +tour is computed as well and stored in the named variable. The tour is +represented by the list of arcs traversed, in the order of traversal. + +[call [cmd struct::graph::op::isSemiEulerian?] [arg g] [opt [arg pathvar]]] + +This command determines whether the graph [arg g] is +[term semi-eulerian] or not. The result is a boolean value, [const true] +if the graph is semi-eulerian, and [const false] otherwise. + +[para] + +If the graph is semi-eulerian and [arg pathvar] is specified then an +euler path is computed as well and stored in the named variable. The +path is represented by the list of arcs traversed, in the order of +traversal. + +[call [cmd struct::graph::op::dijkstra] [arg g] [arg start] [opt [arg options]...]] + +This command determines distances in the weighted [arg g] from the +node [arg start] to all other nodes in the graph. The options specify +how to traverse graphs, and the format of the result. + +[para] + +Two options are recognized + +[list_begin options] +[opt_def -arcmode mode] + +The accepted mode values are [const directed] and [const undirected]. +For directed traversal all arcs are traversed from source to +target. For undirected traversal all arcs are traversed in the +opposite direction as well. Undirected traversal is the default. + +[opt_def -outputformat format] + +The accepted format values are [const distances] and [const tree]. In +both cases the result is a dictionary keyed by the names of all nodes +in the graph. For [const distances] the value is the distance of the +node to [arg start], whereas for [const tree] the value is the path +from the node to [arg start], excluding the node itself, but including +[arg start]. Tree format is the default. + +[list_end] + +[call [cmd struct::graph::op::distance] [arg g] [arg origin] [arg destination] [opt [arg options]...]] + +This command determines the (un)directed distance between the two +nodes [arg origin] and [arg destination] in the graph [arg g]. It +accepts the option [option -arcmode] of [cmd struct::graph::op::dijkstra]. + +[call [cmd struct::graph::op::eccentricity] [arg g] [arg n] [opt [arg options]...]] + +This command determines the (un)directed [term eccentricity] of the +node [arg n] in the graph [arg g]. It accepts the option +[option -arcmode] of [cmd struct::graph::op::dijkstra]. + +[para] + +The (un)directed [term eccentricity] of a node is the maximal +(un)directed distance between the node and any other node in the +graph. + +[call [cmd struct::graph::op::radius] [arg g] [opt [arg options]...]] + +This command determines the (un)directed [term radius] of the graph +[arg g]. It accepts the option [option -arcmode] of [cmd struct::graph::op::dijkstra]. + +[para] + +The (un)directed [term radius] of a graph is the minimal (un)directed +[term eccentricity] of all nodes in the graph. + +[call [cmd struct::graph::op::diameter] [arg g] [opt [arg options]...]] + +This command determines the (un)directed [term diameter] of the graph +[arg g]. It accepts the option [option -arcmode] of [cmd struct::graph::op::dijkstra]. + +[para] + +The (un)directed [term diameter] of a graph is the maximal (un)directed +[term eccentricity] of all nodes in the graph. + +[call [cmd struct::graph::op::BellmanFord] [arg G] [arg startnode]] + +Searching for [sectref {Shortest Path Problem} "shortests paths"] between chosen node and all other nodes in graph [arg G]. Based +on relaxation method. In comparison to [cmd struct::graph::op::dijkstra] it doesn't need assumption that all weights +on edges in input graph [arg G] have to be positive. + +[para] + +That generality sets the complexity of algorithm to - [term O(V*E)], where [term V] is the number of vertices +and [term E] is number of edges in graph [arg G]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph object} G input] +Directed, connected and edge weighted graph [arg G], without any negative cycles ( presence of cycles with the negative sum +of weight means that there is no shortest path, since the total weight becomes lower each time the cycle is +traversed ). Negative weights on edges are allowed. + +[arg_def {Node} startnode input] +The node for which we find all shortest paths to each other node in graph [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Dictionary containing for each node (key) distances to each other node in graph [arg G]. +[list_end][comment {-- definitions --}] + +[para] + +[emph Note:] If algorithm finds a negative cycle, it will return error message. + +[call [cmd struct::graph::op::Johnsons] [arg G] [opt [arg options]...]] + +Searching for [sectref {Shortest Path Problem} "shortest paths"] between all pairs of vertices in graph. For sparse graphs +asymptotically quicker than [cmd struct::graph::op::FloydWarshall] algorithm. Johnson's algorithm +uses [cmd struct::graph::op::BellmanFord] and [cmd struct::graph::op::dijkstra] as subprocedures. + +[para] + +Time complexity: [term "O(n**2*log(n) +n*m)"], where [term n] is the number of nodes and [term m] is +the number of edges in graph [arg G]. + +[para] + +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph object} G input] + +Directed graph [arg G], weighted on edges and not containing +any cycles with negative sum of weights ( the presence of such cycles means +there is no shortest path, since the total weight becomes lower each time the +cycle is traversed ). Negative weights on edges are allowed. + +[list_end][comment {-- arguments --}] + +[def Options:] +[list_begin options] +[opt_def -filter] + +Returns only existing distances, cuts all [term Inf] values for +non-existing connections between pairs of nodes. + +[list_end][comment {-- options --}] + +[def Result:] + +Dictionary containing distances between all pairs of vertices. + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::FloydWarshall] [arg G]] + +Searching for [sectref {Shortest Path Problem} "shortest paths"] between all pairs of edges in weighted graphs.[para] +Time complexity: [term O(V^3)] - where [term V] is number of vertices.[para] +Memory complexity: [term O(V^2)]. + +[para] + +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph object} G input] + +Directed and weighted graph [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Dictionary containing shortest distances to each node from each node. +[list_end][comment {-- definitions --}] + +[emph Note:] Algorithm finds solutions dynamically. It compares all possible paths through the graph +between each pair of vertices. Graph shouldn't possess any cycle with negative +sum of weights (the presence of such cycles means there is no shortest path, +since the total weight becomes lower each time the cycle is traversed). +[para] +On the other hand algorithm can be used to find those cycles - if any shortest distance +found by algorithm for any nodes [term v] and [term u] (when [term v] is the same node as [term u]) is negative, +that node surely belong to at least one negative cycle. + +[call [cmd struct::graph::op::MetricTravellingSalesman] [arg G]] + +Algorithm for solving a metric variation of [sectref {Travelling Salesman Problem} "Travelling salesman problem"]. +[term "TSP problem"] is [term NP-Complete], so there is no efficient algorithm to solve it. Greedy methods +are getting extremely slow, with the increase in the set of nodes. + +[para] + +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph object} G input] +Undirected, weighted graph [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Approximated solution of minimum [term "Hamilton Cycle"] - closed path visiting all nodes, +each exactly one time. + +[list_end][comment {-- definitions --}] + +[emph Note:] [sectref {Approximation algorithm} "It's 2-approximation algorithm."] + +[call [cmd struct::graph::op::Christofides] [arg G]] + +Another algorithm for solving [sectref {Travelling Salesman Problem} "metric [term "TSP problem"]"]. +Christofides implementation uses [term "Max Matching"] for reaching better approximation factor. + +[para] + +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] + +Undirected, weighted graph [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Approximated solution of minimum [term "Hamilton Cycle"] - closed path visiting all nodes, +each exactly one time. + +[list_end][comment {-- definitions --}] + +[para] + +[emph Note:] [sectref {Approximation algorithm} "It's is a 3/2 approximation algorithm. "] + +[call [cmd struct::graph::op::GreedyMaxMatching] [arg G]] + +[term "Greedy Max Matching"] procedure, which finds [sectref {Matching Problem} "maximal matching"] (not maximum) +for given graph [arg G]. It adds edges to solution, beginning from edges with the +lowest cost. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] + +Undirected graph [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Set of edges - the max matching for graph [arg G]. + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::MaxCut] [arg G] [arg U] [arg V]] + +Algorithm solving a [sectref {Cut Problems} "Maximum Cut Problem"]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] + +The graph to cut. + +[arg_def {List} U output] + +Variable storing first set of nodes (cut) given by solution. + +[arg_def {List} V output] + +Variable storing second set of nodes (cut) given by solution. + +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns number of edges between found two sets of nodes. + +[list_end][comment {-- definitions --}] + +[emph Note:] [term MaxCut] is a [sectref {Approximation algorithm} "2-approximation algorithm."] + +[call [cmd struct::graph::op::UnweightedKCenter] [arg G] [arg k]] + +Approximation algorithm that solves a [sectref {K-Center Problem} "k-center problem"]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Undirected complete graph [arg G], which satisfies triangle inequality.[para] +[arg_def {Integer} k input] +Positive integer that sets the number of nodes that will be included in [term "k-center"]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Set of nodes - [arg k] center for graph [arg G]. + +[list_end][comment {-- definitions --}] + +[emph Note:] [term UnweightedKCenter] is a [sectref {Approximation algorithm} "2-approximation algorithm."] + +[call [cmd struct::graph::op::WeightedKCenter] [arg G] [arg nodeWeights] [arg W]] + +Approximation algorithm that solves a weighted version of [sectref {K-Center Problem} "k-center problem"]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Undirected complete graph [arg G], which satisfies triangle inequality. +[arg_def {Integer} W input] +Positive integer that sets the maximum possible weight of [term "k-center"] found by algorithm. +[arg_def {List} nodeWeights input] +List of nodes and its weights in graph [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Set of nodes, which is solution found by algorithm. +[list_end][comment {-- definitions --}] + +[emph Note:][term WeightedKCenter] is a [sectref {Approximation algorithm} "3-approximation algorithm."] + +[call [cmd struct::graph::op::GreedyMaxIndependentSet] [arg G]] + +A [term "maximal independent set"] is an [term "independent set"] such that adding any other node +to the set forces the set to contain an edge. + +[para] + +Algorithm for input graph [arg G] returns set of nodes (list), which are contained in Max Independent +Set found by algorithm. + +[call [cmd struct::graph::op::GreedyWeightedMaxIndependentSet] [arg G] [arg nodeWeights]] + +Weighted variation of [term "Maximal Independent Set"]. It takes as an input argument +not only graph [arg G] but also set of weights for all vertices in graph [arg G]. + +[para] +[emph Note:] +Read also [term "Maximal Independent Set"] description for more info. + +[call [cmd struct::graph::op::VerticesCover] [arg G]] + +[term "Vertices cover"] is a set of vertices such that each edge of the graph is incident to +at least one vertex of the set. This 2-approximation algorithm searches for minimum +[term "vertices cover"], which is a classical optimization problem in computer science and +is a typical example of an [term "NP-hard"] optimization problem that has an approximation +algorithm. + +For input graph [arg G] algorithm returns the set of edges (list), which is Vertex Cover found by algorithm. + +[call [cmd struct::graph::op::EdmondsKarp] [arg G] [arg s] [arg t]] + +Improved Ford-Fulkerson's algorithm, computing the [sectref {Flow Problems} "maximum flow"] in given flow network [arg G]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Weighted and directed graph. Each edge should have set integer attribute considered as +maximum throughputs that can be carried by that link (edge). +[arg_def {Node} s input] +The node that is a source for graph [arg G]. +[arg_def {Node} t input] +The node that is a sink for graph [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Procedure returns the dictionary containing throughputs for all edges. For +each key ( the edge between nodes [term u] and [term v] in the form of [term "list u v"] ) there is +a value that is a throughput for that key. Edges where throughput values +are equal to 0 are not returned ( it is like there was no link in the flow network +between nodes connected by such edge). + +[list_end][comment {-- definitions --}] + +[para] + +The general idea of algorithm is finding the shortest augumenting paths in graph [arg G], as long +as they exist, and for each path updating the edge's weights along that path, +with maximum possible throughput. The final (maximum) flow is found +when there is no other augumenting path from source to sink. + +[para] + +[emph Note:] Algorithm complexity : [term O(V*E)], where [term V] is the number of nodes and [term E] is the number +of edges in graph [term G]. + +[call [cmd struct::graph::op::BusackerGowen] [arg G] [arg desiredFlow] [arg s] [arg t]] + +Algorithm finds solution for a [sectref {Flow Problems} "minimum cost flow problem"]. So, the goal is to find a flow, +whose max value can be [arg desiredFlow], from source node [arg s] to sink node [arg t] in given flow network [arg G]. +That network except throughputs at edges has also defined a non-negative cost on each edge - cost of using that edge when +directing flow with that edge ( it can illustrate e.g. fuel usage, time or any other measure dependent on usages ). + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Flow network (directed graph), each edge in graph should have two integer attributes: [term cost] and [term throughput]. +[arg_def {Integer} desiredFlow input] +Max value of the flow for that network. +[arg_def {Node} s input] +The source node for graph [arg G]. +[arg_def {Node} t input] +The sink node for graph [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Dictionary containing values of used throughputs for each edge ( key ). +found by algorithm. + +[list_end][comment {-- definitions --}] + +[emph Note:] Algorithm complexity : [term O(V**2*desiredFlow)], where [term V] is the number of nodes in graph [arg G]. + +[call [cmd struct::graph::op::ShortestsPathsByBFS] [arg G] [arg s] [arg outputFormat]] + +Shortest pathfinding algorithm using BFS method. In comparison to [cmd struct::graph::op::dijkstra] it can +work with negative weights on edges. Of course negative cycles are not allowed. Algorithm is better than dijkstra +for sparse graphs, but also there exist some pathological cases (those cases generally don't appear in practise) that +make time complexity increase exponentially with the growth of the number of nodes. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Input graph. +[arg_def {Node} s input] +Source node for which all distances to each other node in graph [arg G] are computed. +[list_end][comment {-- arguments --}] + +[def "Options and result:"] +[list_begin options] +[opt_def distances] + +When selected [arg outputFormat] is [const distances] - procedure returns dictionary containing +distances between source node [arg s] and each other node in graph [arg G]. + +[opt_def paths] + +When selected [arg outputFormat] is [const paths] - procedure returns dictionary containing +for each node [term v], a list of nodes, which is a path between source node [arg s] and node [term v]. + +[list_end][comment {-- options --}] + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::BFS] [arg G] [arg s] [opt [arg outputFormat]...]] + +Breadth-First Search - algorithm creates the BFS Tree. +Memory and time complexity: [term "O(V + E)"], where [term V] is the number of nodes and [term E] +is number of edges. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Input graph. +[arg_def {Node} s input] +Source node for BFS procedure. + +[list_end][comment {-- arguments --}] + +[def "Options and result:"] +[list_begin options] +[opt_def graph] + +When selected [option outputFormat] is [option graph] - procedure returns a graph structure ([cmd struct::graph]), +which is equivalent to BFS tree found by algorithm. + +[opt_def tree] + +When selected [option outputFormat] is [option tree] - procedure returns a tree structure ([cmd struct::tree]), +which is equivalent to BFS tree found by algorithm. + +[list_end][comment {-- options --}] + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::MinimumDiameterSpanningTree] [arg G]] + +The goal is to find for input graph [arg G], the [term "spanning tree"] that +has the minimum [term "diameter"] value. + +[para] + +General idea of algorithm is to run [term BFS] over all vertices in graph +[arg G]. If the diameter [term d] of the tree is odd, then we are sure that tree +given by [term BFS] is minimum (considering diameter value). When, diameter [term d] +is even, then optimal tree can have minimum [term diameter] equal to [term d] or +[term d-1]. + +[para] + +In that case, what algorithm does is rebuilding the tree given by [term BFS], by +adding a vertice between root node and root's child node (nodes), such that +subtree created with child node as root node is the greatest one (has the +greatests height). In the next step for such rebuilded tree, we run again [term BFS] +with new node as root node. If the height of the tree didn't changed, we have found +a better solution. + +[para] + +For input graph [arg G] algorithm returns the graph structure ([cmd struct::graph]) that is +a spanning tree with minimum diameter found by algorithm. + +[call [cmd struct::graph::op::MinimumDegreeSpanningTree] [arg G]] + +Algorithm finds for input graph [arg G], a spanning tree [term T] with the minimum possible +degree. That problem is [term NP-hard], so algorithm is an approximation algorithm. + +[para] + +Let [term V] be the set of nodes for graph [arg G] and let [term W] be any subset of [term V]. Lets +assume also that [term OPT] is optimal solution and [term ALG] is solution found by algorithm for input +graph [arg G]. [para] +It can be proven that solution found with the algorithm must fulfil inequality: [para] [term "((|W| + k - 1) / |W|) <= ALG <= 2*OPT + log2(n) + 1"]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Undirected simple graph. + +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns graph structure, which is equivalent to spanning tree [term T] found by algorithm. + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::MaximumFlowByDinic] [arg G] [arg s] [arg t] [arg blockingFlowAlg]] + +Algorithm finds [sectref {Flow Problems} "maximum flow"] for the flow network represented by graph [arg G]. It is based on +the blocking-flow finding methods, which give us different complexities what makes a better fit for +different graphs. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Directed graph [arg G] representing the flow network. Each edge should have attribute +[term throughput] set with integer value. + +[arg_def {Node} s input] +The source node for the flow network [arg G]. + +[arg_def {Node} t input] +The sink node for the flow network [arg G]. + +[list_end][comment {-- arguments --}] + +[def Options:] +[list_begin options] +[opt_def dinic] +Procedure will find maximum flow for flow network [arg G] using Dinic's algorithm ([cmd struct::graph::op::BlockingFlowByDinic]) +for blocking flow computation. +[opt_def mkm] +Procedure will find maximum flow for flow network [arg G] using Malhotra, Kumar and Maheshwari's algorithm ([cmd struct::graph::op::BlockingFlowByMKM]) +for blocking flow computation. +[list_end][comment {-- options --}] + +[def Result:] +Algorithm returns dictionary containing it's flow value for each edge (key) in network [arg G]. + +[list_end][comment {-- definitions --}] + +[para] + +[emph Note:] [cmd struct::graph::op::BlockingFlowByDinic] gives [term O(m*n^2)] complexity and +[cmd struct::graph::op::BlockingFlowByMKM] gives [term O(n^3)] complexity, where [term n] is the number of nodes +and [term m] is the number of edges in flow network [arg G]. + +[call [cmd struct::graph::op::BlockingFlowByDinic] [arg G] [arg s] [arg t]] + +Algorithm for given network [arg G] with source [arg s] and sink [arg t], finds a [sectref {Flow Problems} "blocking +flow"], which can be used to obtain a [term "maximum flow"] for that network [arg G]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Directed graph [arg G] representing the flow network. Each edge should have attribute +[term throughput] set with integer value. +[arg_def {Node} s input] +The source node for the flow network [arg G]. +[arg_def {Node} t input] +The sink node for the flow network [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns dictionary containing it's blocking flow value for each edge (key) in network [arg G]. + +[list_end][comment {-- definitions --}] + +[emph Note:] Algorithm's complexity is [term O(n*m)], where [term n] is the number of nodes +and [term m] is the number of edges in flow network [arg G]. + +[call [cmd struct::graph::op::BlockingFlowByMKM] [arg G] [arg s] [arg t]] + +Algorithm for given network [arg G] with source [arg s] and sink [arg t], finds a [sectref {Flow Problems} "blocking +flow"], which can be used to obtain a [term "maximum flow"] for that [term network] [arg G]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Directed graph [arg G] representing the flow network. Each edge should have attribute +[term throughput] set with integer value. +[arg_def {Node} s input] +The source node for the flow network [arg G]. +[arg_def {Node} t input] +The sink node for the flow network [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns dictionary containing it's blocking flow value for each edge (key) in network [arg G]. + +[list_end][comment {-- definitions --}] + +[emph Note:] Algorithm's complexity is [term O(n^2)], where [term n] is the number of nodes in flow network [arg G]. + +[call [cmd struct::graph::op::createResidualGraph] [arg G] [arg f]] + +Procedure creates a [term "residual graph"] (or [sectref {Flow Problems} "residual network"] ) for network [arg G] and given +flow [arg f]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Flow network (directed graph where each edge has set attribute: [term throughput] ). + +[arg_def {dictionary} f input] +Current flows in flow network [arg G]. + +[list_end][comment {-- arguments --}] + +[def Result:] +Procedure returns graph structure that is a [term "residual graph"] created from input flow +network [arg G]. +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::createAugmentingNetwork] [arg G] [arg f] [arg path]] + +Procedure creates an [sectref {Flow Problems} "augmenting network"] for a given residual network [arg G] +, flow [arg f] and augmenting path [arg path]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Residual network (directed graph), where for every edge there are set two attributes: throughput and cost. +[arg_def {Dictionary} f input] +Dictionary which contains for every edge (key), current value of the flow on that edge. +[arg_def {List} path input] +Augmenting path, set of edges (list) for which we create the network modification. + +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns graph structure containing the modified augmenting network. + +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::createLevelGraph] [arg Gf] [arg s]] + +For given residual graph [arg Gf] procedure finds the [sectref {Flow Problems} "level graph"]. + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} Gf input] +Residual network, where each edge has it's attribute [term throughput] set with certain value. +[arg_def {Node} s input] +The source node for the residual network [arg Gf]. +[list_end][comment {-- arguments --}] + +[def Result:] +Procedure returns a [term "level graph"] created from input [term "residual network"]. +[list_end][comment {-- definitions --}] + +[call [cmd struct::graph::op::TSPLocalSearching] [arg G] [arg C]] + +Algorithm is a [term "heuristic of local searching"] for [term "Travelling Salesman Problem"]. For some +solution of [term "TSP problem"], it checks if it's possible to find a better solution. As [term "TSP"] +is well known NP-Complete problem, so algorithm is a approximation algorithm (with 2 approximation factor). + +[para] +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Undirected and complete graph with attributes "weight" set on each single edge. +[arg_def {List} C input] +A list of edges being [term "Hamiltonian cycle"], which is solution of [term "TSP Problem"] for graph [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns the best solution for [term "TSP problem"], it was able to find. +[list_end][comment {-- definitions --}] + +[emph Note:] The solution depends on the choosing of the beginning cycle [arg C]. It's not true that better cycle +assures that better solution will be found, but practise shows that we should give starting cycle with as small +sum of weights as possible. + +[call [cmd struct::graph::op::TSPLocalSearching3Approx] [arg G] [arg C]] + +Algorithm is a [term "heuristic of local searching"] for [term "Travelling Salesman Problem"]. For some +solution of [term "TSP problem"], it checks if it's possible to find a better solution. As [term "TSP"] +is well known NP-Complete problem, so algorithm is a approximation algorithm (with 3 approximation factor). + +[para] + +[list_begin definitions] + +[def Arguments:] +[list_begin arguments] +[arg_def {Graph Object} G input] +Undirected and complete graph with attributes "weight" set on each single edge. +[arg_def {List} C input] +A list of edges being [term "Hamiltonian cycle"], which is solution of [term "TSP Problem"] for graph [arg G]. +[list_end][comment {-- arguments --}] + +[def Result:] +Algorithm returns the best solution for [term "TSP problem"], it was able to find. + +[list_end][comment {-- definitions --}] + +[emph Note:] In practise 3-approximation algorithm turns out to be far more effective than 2-approximation, but it gives +worser approximation factor. Further heuristics of local searching (e.g. 4-approximation) doesn't give enough boost to +square the increase of approximation factor, so 2 and 3 approximations are mainly used. + +[call [cmd struct::graph::op::createSquaredGraph] [arg G]] + +X-Squared graph is a graph with the same set of nodes as input graph [arg G], but a different set of edges. X-Squared graph +has edge [term (u,v)], if and only if, the distance between [term u] and [term v] nodes is not greater than X and [term "u != v"]. +[para] +Procedure for input graph [arg G], returns its two-squared graph. + +[para] + +[emph Note:] Distances used in choosing new set of edges are considering the number of edges, not the sum of weights at edges. + +[call [cmd struct::graph::op::createCompleteGraph] [arg G] [arg originalEdges]] + +For input graph [arg G] procedure adds missing arcs to make it a [term "complete graph"]. It also holds in +variable [arg originalEdges] the set of arcs that graph [arg G] possessed before that operation. + +[list_end] + +[section "Background theory and terms"] + +[subsection "Shortest Path Problem"] + +[list_begin definitions] + +[def "Definition ([term "single-pair shortest path problem"]):"] +Formally, given a weighted graph (let [term V] be the set of vertices, and [term E] a set of edges), +and one vertice [term v] of [term V], find a path [term P] from [term v] to a [term "v'"] of V so that +the sum of weights on edges along the path is minimal among all paths connecting v to v'. + +[def "Generalizations:"] + +[list_begin itemized] +[item][term "The single-source shortest path problem"], in which we have to find shortest paths from a source vertex v to all other vertices in the graph. +[item][term "The single-destination shortest path problem"], in which we have to find shortest paths from all vertices in the graph to a single destination vertex v. This can be reduced to the single-source shortest path problem by reversing the edges in the graph. +[item][term "The all-pairs shortest path problem"], in which we have to find shortest paths between every pair of vertices v, v' in the graph. +[list_end][comment {-- itemized --}] + +[emph "Note:"] +The result of [term "Shortest Path problem"] can be [term "Shortest Path tree"], which is a subgraph of a given (possibly weighted) graph constructed so that the +distance between a selected root node and all other nodes is minimal. It is a tree because if there are two paths between the root node and some +vertex v (i.e. a cycle), we can delete the last edge of the longer path without increasing the distance from the root node to any node in the subgraph. + +[list_end][comment {-- definitions --}] + +[subsection "Travelling Salesman Problem"] + +[list_begin definitions] + +[def "Definition:"] +For given edge-weighted (weights on edges should be positive) graph the goal is to find the cycle that visits each node in graph +exactly once ([term "Hamiltonian cycle"]). + +[def "Generalizations:"] + +[list_begin itemized] +[item][term "Metric TSP"] - A very natural restriction of the [term TSP] is to require that the distances between cities form a [term metric], i.e., +they satisfy [term "the triangle inequality"]. That is, for any 3 cities [term A], [term B] and [term C], the distance between [term A] and [term C] +must be at most the distance from [term A] to [term B] plus the distance from [term B] to [term C]. Most natural instances of [term TSP] +satisfy this constraint. + +[item][term "Euclidean TSP"] - Euclidean TSP, or [term "planar TSP"], is the [term TSP] with the distance being the ordinary [term "Euclidean distance"]. +[term "Euclidean TSP"] is a particular case of [term TSP] with [term "triangle inequality"], since distances in plane obey triangle inequality. However, +it seems to be easier than general [term TSP] with [term "triangle inequality"]. For example, [term "the minimum spanning tree"] of the graph associated +with an instance of [term "Euclidean TSP"] is a [term "Euclidean minimum spanning tree"], and so can be computed in expected [term "O(n log n)"] time for +[term n] points (considerably less than the number of edges). This enables the simple [term "2-approximation algorithm"] for TSP with triangle +inequality above to operate more quickly. + +[item][term "Asymmetric TSP"] - In most cases, the distance between two nodes in the [term TSP] network is the same in both directions. +The case where the distance from [term A] to [term B] is not equal to the distance from [term B] to [term A] is called [term "asymmetric TSP"]. +A practical application of an [term "asymmetric TSP"] is route optimisation using street-level routing (asymmetric due to one-way streets, +slip-roads and motorways). + +[list_end][comment {-- itemized --}] +[list_end][comment {-- definitions --}] + +[subsection "Matching Problem"] + +[list_begin definitions] + +[def "Definition:"] +Given a graph [term "G = (V,E)"], a matching or [term "edge-independent set"] [term M] in [term G] is a set of pairwise non-adjacent edges, +that is, no two edges share a common vertex. A vertex is [term matched] if it is incident to an edge in the [term "matching M"]. +Otherwise the vertex is [term unmatched]. + +[def "Generalizations:"] + +[list_begin itemized] +[item][term "Maximal matching"] - a matching [term M] of a graph G with the property that if any edge not in [term M] is added to [term M], +it is no longer a [term matching], that is, [term M] is maximal if it is not a proper subset of any other [term matching] in graph G. +In other words, a [term "matching M"] of a graph G is maximal if every edge in G has a non-empty intersection with at least one edge in [term M]. + +[item][term "Maximum matching"] - a matching that contains the largest possible number of edges. There may be many [term "maximum matchings"]. +The [term "matching number"] of a graph G is the size of a [term "maximum matching"]. Note that every [term "maximum matching"] is [term maximal], +but not every [term "maximal matching"] is a [term "maximum matching"]. + +[item][term "Perfect matching"] - a matching which matches all vertices of the graph. That is, every vertex of the graph is incident to exactly one +edge of the matching. Every [term "perfect matching"] is [term maximum] and hence [term maximal]. In some literature, the term [term "complete matching"] +is used. A [term "perfect matching"] is also a [term "minimum-size edge cover"]. Moreover, the size of a [term "maximum matching"] is no larger than the +size of a [term "minimum edge cover"]. + +[item][term "Near-perfect matching"] - a matching in which exactly one vertex is unmatched. This can only occur when the graph has an odd number of vertices, +and such a [term matching] must be [term maximum]. If, for every vertex in a graph, there is a near-perfect matching that omits only that vertex, the graph +is also called [term factor-critical]. + +[list_end][comment {-- itemized --}] + +[def "Related terms:"] + +[list_begin itemized] +[item][term "Alternating path"] - given a matching [term M], an [term "alternating path"] is a path in which the edges belong alternatively +to the matching and not to the matching. + +[item][term "Augmenting path"] - given a matching [term M], an [term "augmenting path"] is an [term "alternating path"] that starts from +and ends on free (unmatched) vertices. + +[list_end][comment {-- itemized --}] + +[list_end][comment {-- definitons --}] + +[subsection "Cut Problems"] + +[list_begin definitions] + +[def "Definition:"] +A [term cut] is a partition of the vertices of a graph into two [term "disjoint subsets"]. The [term cut-set] of the [term cut] is the +set of edges whose end points are in different subsets of the partition. Edges are said to be crossing the cut if they are in its [term cut-set]. +[para] +Formally: +[list_begin itemized] +[item] a [term cut] [term "C = (S,T)"] is a partition of [term V] of a graph [term "G = (V, E)"]. + +[item] an [term "s-t cut"] [term "C = (S,T)"] of a [term "flow network"] [term "N = (V, E)"] is a cut of [term N] such that [term s] is included in [term S] +and [term t] is included in [term T], where [term s] and [term t] are the [term source] and the [term sink] of [term N] respectively. + +[item] The [term cut-set] of a [term "cut C = (S,T)"] is such set of edges from graph [term "G = (V, E)"] that each edge [term "(u, v)"] satisfies +condition that [term u] is included in [term S] and [term v] is included in [term T]. + +[list_end][comment {-- itemized --}] +[para] +In an [term "unweighted undirected"] graph, the size or weight of a cut is the number of edges crossing the cut. In a [term "weighted graph"], +the same term is defined by the sum of the weights of the edges crossing the cut. +[para] +In a [term "flow network"], an [term "s-t cut"] is a cut that requires the [term source] and the [term sink] to be in different subsets, +and its [term cut-set] only consists of edges going from the [term source's] side to the [term sink's] side. The capacity of an [term "s-t cut"] +is defined by the sum of capacity of each edge in the [term cut-set]. +[para] +The [term cut] of a graph can sometimes refer to its [term cut-set] instead of the partition. + +[def "Generalizations:"] +[list_begin itemized] +[item][term "Minimum cut"] - A cut is minimum if the size of the cut is not larger than the size of any other cut. +[item][term "Maximum cut"] - A cut is maximum if the size of the cut is not smaller than the size of any other cut. +[item][term "Sparsest cut"] - The [term "Sparsest cut problem"] is to bipartition the vertices so as to minimize the ratio of the number +of edges across the cut divided by the number of vertices in the smaller half of the partition. +[list_end][comment {-- itemized --}] + +[list_end][comment {-- definitons --}] + +[subsection "K-Center Problem"] + +[list_begin definitions] + +[def "Definitions:"] +[list_begin definitions] +[def "[term "Unweighted K-Center"]"] +For any set [term S] ( which is subset of [term V] ) and node [term v], let the [term connect(v,S)] be the +cost of cheapest edge connecting [term v] with any node in [term S]. The goal is to find +such [term S], that [term "|S| = k"] and [term "max_v{connect(v,S)}"] is possibly small. +[para] +In other words, we can use it i.e. for finding best locations in the city ( nodes +of input graph ) for placing k buildings, such that those buildings will be as close +as possible to all other locations in town. +[para] +[def "[term "Weighted K-Center"]"] +The variation of [term "unweighted k-center problem"]. Besides the fact graph is edge-weighted, +there are also weights on vertices of input graph [arg G]. We've got also restriction +[arg W]. The goal is to choose such set of nodes [term S] ( which is a subset of [term V] ), that it's +total weight is not greater than [arg W] and also function: [term "max_v { min_u { cost(u,v) }}"] +has the smallest possible worth ( [term v] is a node in [term V] and [term u] is a node in [term S] ). + +[list_end][comment {-- definitions --}] +[list_end][comment {-- definitions --}] + +[subsection "Flow Problems"] + +[list_begin definitions] + +[def "Definitions:"] +[list_begin itemized] +[item][term "the maximum flow problem"] - the goal is to find a feasible flow through a single-source, single-sink flow network that is maximum. +The [term "maximum flow problem"] can be seen as a special case of more complex network flow problems, such as the [term "circulation problem"]. +The maximum value of an [term "s-t flow"] is equal to the minimum capacity of an [term "s-t cut"] in the network, as stated in the +[term "max-flow min-cut theorem"]. +[para] +More formally for flow network [term "G = (V,E)"], where for each edge [term "(u, v)"] we have its throuhgput [term "c(u,v)"] defined. As [term flow] +[term F] we define set of non-negative integer attributes [term f(u,v)] assigned to edges, satisfying such conditions: +[list_begin enumerated] +[enum]for each edge [term "(u, v)"] in [term G] such condition should be satisfied: 0 <= f(u,v) <= c(u,v) +[enum]Network [term G] has source node [term s] such that the flow [term F] is equal to the sum of outcoming flow decreased by the sum of incoming flow from that source node [term s]. +[enum]Network [term G] has sink node [term t] such that the the [term -F] value is equal to the sum of the incoming flow decreased by the sum of outcoming flow from that sink node [term t]. +[enum]For each node that is not a [term source] or [term sink] the sum of incoming flow and sum of outcoming flow should be equal. +[list_end][comment {-- enumerated --}] + +[item][term "the minimum cost flow problem"] - the goal is finding the cheapest possible way of sending a certain amount of flow through a [term "flow network"]. + +[item][term "blocking flow"] - a [term "blocking flow"] for a [term "residual network"] [term Gf] we name such flow [term b] in [term Gf] that: +[list_begin enumerated] +[enum]Each path from [term sink] to [term source] is the shortest path in [term Gf]. +[enum]Each shortest path in [term Gf] contains an edge with fully used throughput in [term Gf+b]. +[list_end][comment {-- enumerated --}] + +[item][term "residual network"] - for a flow network [term G] and flow [term f] [term "residual network"] is built with those edges, which can +send larger flow. It contains only those edges, which can send flow larger than 0. + +[item][term "level network"] - it has the same set of nodes as [term "residual graph"], but has only those edges [term "(u,v)"] from [arg Gf] +for which such equality is satisfied: [term "distance(s,u)+1 = distance(s,v)"]. + +[item][term "augmenting network"] - it is a modification of [term "residual network"] considering the new +flow values. Structure stays unchanged but values of throughputs and costs at edges +are different. + +[list_end][comment {-- itemized --}] +[list_end][comment {-- definitions --}] + +[subsection "Approximation algorithm"] + +[list_begin definitions] + +[def "k-approximation algorithm:"] +Algorithm is a k-approximation, when for [term ALG] (solution returned by algorithm) and +[term OPT] (optimal solution), such inequality is true: + +[list_begin itemized] +[item] for minimalization problems: [term "ALG/OPT <= k" ] +[item] for maximalization problems: [term "OPT/ALG <= k" ] +[list_end][comment {-- itemized --}] + +[list_end][comment {-- definitions --}] + +[section References] + +[list_begin enum] +[enum] [uri http://en.wikipedia.org/wiki/Adjacency_matrix {Adjacency matrix}] +[enum] [uri http://en.wikipedia.org/wiki/Adjacency_list {Adjacency list}] +[enum] [uri http://en.wikipedia.org/wiki/Kruskal%27s_algorithm {Kruskal's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Prim%27s_algorithm {Prim's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Bipartite_graph {Bipartite graph}] +[enum] [uri http://en.wikipedia.org/wiki/Strongly_connected_components {Strongly connected components}] +[enum] [uri http://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm {Tarjan's strongly connected components algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Cut_vertex {Cut vertex}] +[enum] [uri http://en.wikipedia.org/wiki/Bridge_(graph_theory) Bridge] +[enum] [uri http://en.wikipedia.org/wiki/Bellman-Ford_algorithm {Bellman-Ford's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Johnson_algorithm {Johnson's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Floyd-Warshall_algorithm {Floyd-Warshall's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Travelling_salesman_problem {Travelling Salesman Problem}] +[enum] [uri http://en.wikipedia.org/wiki/Christofides_algorithm {Christofides Algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Maxcut {Max Cut}] +[enum] [uri http://en.wikipedia.org/wiki/Matching {Matching}] +[enum] [uri http://en.wikipedia.org/wiki/Maximal_independent_set {Max Independent Set}] +[enum] [uri http://en.wikipedia.org/wiki/Vertex_cover_problem {Vertex Cover}] +[enum] [uri http://en.wikipedia.org/wiki/Ford-Fulkerson_algorithm {Ford-Fulkerson's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Maximum_flow_problem {Maximum Flow problem}] +[enum] [uri http://en.wikipedia.org/wiki/Minimum_cost_flow_problem {Busacker-Gowen's algorithm}] +[enum] [uri http://en.wikipedia.org/wiki/Dinic's_algorithm {Dinic's algorithm}] +[enum] [uri http://www.csc.kth.se/~viggo/wwwcompendium/node128.html {K-Center problem}] +[enum] [uri http://en.wikipedia.org/wiki/Breadth-first_search {BFS}] +[enum] [uri http://en.wikipedia.org/wiki/Degree-constrained_spanning_tree {Minimum Degree Spanning Tree}] +[enum] [uri http://en.wikipedia.org/wiki/Approximation_algorithm {Approximation algorithm}] +[list_end] + +[vset CATEGORY {struct :: graph}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/graphops.tcl b/tcllib/modules/struct/graphops.tcl new file mode 100644 index 0000000..4c3fcad --- /dev/null +++ b/tcllib/modules/struct/graphops.tcl @@ -0,0 +1,3787 @@ +# graphops.tcl -- +# +# Operations on and algorithms for graph data structures. +# +# Copyright (c) 2008 Alejandro Paz <vidriloco@gmail.com>, algorithm implementation +# Copyright (c) 2008 Andreas Kupries, integration with Tcllib's struct::graph +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graphops.tcl,v 1.19 2009/09/24 19:30:10 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 + +package require struct::disjointset ; # Used by kruskal +package require struct::prioqueue ; # Used by kruskal, prim +package require struct::queue ; # Used by isBipartite?, connectedComponent(Of) +package require struct::stack ; # Used by tarjan +package require struct::graph ; # isBridge, isCutVertex +package require struct::tree ; # Used by BFS + +# ### ### ### ######### ######### ######### +## + +namespace eval ::struct::graph::op {} + +# ### ### ### ######### ######### ######### +## + +# This command constructs an adjacency matrix representation of the +# graph argument. + +# Reference: http://en.wikipedia.org/wiki/Adjacency_matrix +# +# Note: The reference defines the matrix in such a way that some of +# the limitations of the code here are not present. I.e. the +# definition at wikipedia deals properly with arc directionality +# and parallelism. +# +# TODO: Rework the code so that the result is in line with the reference. +# Add features to handle weights as well. + +proc ::struct::graph::op::toAdjacencyMatrix {g} { + set nodeList [lsort -dict [$g nodes]] + # Note the lsort. This is used to impose some order on the matrix, + # for comparability of results. Otherwise different versions of + # Tcl and struct::graph (critcl) may generate different, yet + # equivalent matrices, dependent on things like the order a hash + # search is done, or nodes have been added to the graph, or ... + + # Fill an array for index tracking later. Note how we start from + # index 1. This allows us avoid multiple expr+1 later on when + # iterating over the nodes and converting the names to matrix + # indices. See (*). + + set i 1 + foreach n $nodeList { + set nodeDict($n) $i + incr i + } + + set matrix {} + lappend matrix [linsert $nodeList 0 {}] + + # Setting up a template row with all of it's elements set to zero. + + set baseRow 0 + foreach n $nodeList { + lappend baseRow 0 + } + + foreach node $nodeList { + + # The first element in every row is the name of its + # corresponding node. Using lreplace to overwrite the initial + # data in the template we get a copy apart from the template, + # which we can then modify further. + + set currentRow [lreplace $baseRow 0 0 $node] + + # Iterate over the neighbours, also known as 'adjacent' + # rows. The exact set of neighbours depends on the mode. + + foreach neighbour [$g nodes -adj $node] { + # Set value for neighbour on this node list + set at $nodeDict($neighbour) + + # (*) Here we avoid +1 due to starting from index 1 in the + # initialization of nodeDict. + set currentRow [lreplace $currentRow $at $at 1] + } + lappend matrix $currentRow + } + + # The resulting matrix is a list of lists, size (n+1)^2 where n = + # number of nodes. First row and column (index 0) are node + # names. The other entries are boolean flags. True when an arc is + # present, False otherwise. The matrix represents an + # un-directional form of the graph with parallel arcs collapsed. + + return $matrix +} + +#Adjacency List +#------------------------------------------------------------------------------------- +#Procedure creates for graph G, it's representation as Adjacency List. +# +#In comparison to Adjacency Matrix it doesn't force using array with quite big +#size - V^2, where V is a number of vertices ( instead, memory we need is about O(E) ). +#It's especially important when concerning rare graphs ( graphs with amount of vertices +#far bigger than amount of edges ). In practise, it turns out that generally, +#Adjacency List is more effective. Moreover, going through the set of edges take +#less time ( O(E) instead of O(E^2) ) and adding new edges is rapid. +#On the other hand, checking if particular edge exists in graph G takes longer +#( checking if edge {v1,v2} belongs to E(G) in proportion to min{deg(v1,v2)} ). +#Deleting an edge is also longer - in proportion to max{ deg(v1), deg(v2) }. +# +#Input: +# graph G ( directed or undirected ). Default is undirected. +# +#Output: +# Adjacency List for graph G, represented by dictionary containing lists of adjacent nodes +#for each node in G (key). +# +#Options: +# -weights - adds to returning dictionary arc weights for each connection between nodes, so +#each node returned by list as adjacent has additional parameter - weight of arc between him and +#current node. +# -directed - sets graph G to be interpreted as directed graph. +# +#Reference: +#http://en.wikipedia.org/wiki/Adjacency_list +# + +proc ::struct::graph::op::toAdjacencyList {G args} { + + set arcTraversal "undirected" + set weightsOn 0 + + #options for procedure + foreach option $args { + switch -exact -- $option { + -directed { + set arcTraversal "directed" + } + -weights { + #checking if all edges have their weights set + VerifyWeightsAreOk $G + set weightsOn 1 + } + default { + return -code error "Bad option \"$option\". Expected -directed or -weights" + } + } + } + + set V [lsort -dict [$G nodes]] + + #mainloop + switch -exact -- $arcTraversal { + undirected { + #setting up the Adjacency List with nodes + foreach v [lsort -dict [$G nodes]] { + dict set AdjacencyList $v {} + } + #appending the edges adjacent to nodes + foreach e [$G arcs] { + + set v [$G arc source $e] + set u [$G arc target $e] + + if { !$weightsOn } { + dict lappend AdjacencyList $v $u + dict lappend AdjacencyList $u $v + } else { + dict lappend AdjacencyList $v [list $u [$G arc getweight $e]] + dict lappend AdjacencyList $u [list $v [$G arc getweight $e]] + } + } + #deleting duplicated edges + foreach x [dict keys $AdjacencyList] { + dict set AdjacencyList $x [lsort -unique [dict get $AdjacencyList $x]] + } + } + directed { + foreach v $V { + set E [$G arcs -out $v] + set adjNodes {} + foreach e $E { + if { !$weightsOn } { + lappend adjNodes [$G arc target $e] + } else { + lappend adjNodes [list [$G arc target $e] [$G arc getweight $e]] + } + } + dict set AdjacencyList $v $adjNodes + } + } + default { + return -code error "Error while executing procedure" + } + } + + return $AdjacencyList +} + +#Bellman's Ford Algorithm +#------------------------------------------------------------------------------------- +#Searching for shortest paths between chosen node and +#all other nodes in graph G. Based on relaxation method. In comparison to Dijkstra +#it doesn't assume that all weights on edges are positive. However, this generality +#costs us time complexity - O(V*E), where V is number of vertices and E is number +#of edges. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +# +#Output: +#dictionary d[u] - distances from start node to each other node in graph G. +# +#Reference: http://en.wikipedia.org/wiki/Bellman-Ford_algorithm +# + +proc ::struct::graph::op::BellmanFord { G startnode } { + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #checking if the startnode exists in given graph G + if {![$G node exists $startnode]} { + return -code error "node \"$startnode\" does not exist in graph \"$G\"" + } + + #sets of nodes and edges for graph G + set V [$G nodes] + set E [$G arcs] + + #initialization + foreach i $V { + dict set distances $i Inf + } + + dict set distances $startnode 0 + + #main loop (relaxation) + for { set i 1 } { $i <= ([dict size $distances]-1) } { incr i } { + + foreach j $E { + set u [$G arc source $j] ;# start node of edge j + set v [$G arc target $j] ;# end node of edge j + + if { [ dict get $distances $v ] > [ dict get $distances $u ] + [ $G arc getweight $j ]} { + dict set distances $v [ expr {[dict get $distances $u] + [$G arc getweight $j]} ] + } + } + } + + #checking if there exists cycle with negative sum of weights + foreach i $E { + set u [$G arc source $i] ;# start node of edge i + set v [$G arc target $i] ;# end node of edge i + + if { [dict get $distances $v] > [ dict get $distances $u ] + [$G arc getweight $i] } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $distances + +} + + +#Johnson's Algorithm +#------------------------------------------------------------------------------------- +#Searching paths between all pairs of vertices in graph. For rare graphs +#asymptotically quicker than Floyd-Warshall's algorithm. Johnson's algorithm +#uses Bellman-Ford's and Dijkstra procedures. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +#Possible options: +# -filter ( returns only existing distances, cuts all Inf values for +# non-existing connections between pairs of nodes ) +# +#Output: +# Dictionary containing distances between all pairs of vertices +# +#Reference: http://en.wikipedia.org/wiki/Johnson_algorithm +# + +proc ::struct::graph::op::Johnsons { G args } { + + #options for procedure + set displaymode 0 + foreach option $args { + switch -exact -- $option { + -filter { + set displaymode 1 + } + default { + return -code error "Bad option \"$option\". Expected -filter" + } + } + } + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #Transformation of graph G - adding one more node connected with + #each existing node with an edge, which weight is 0 + set V [$G nodes] + set s [$G node insert] + + foreach i $V { + if { $i ne $s } { + $G arc insert $s $i + } + } + + $G arc setunweighted + + #set potential values with Bellman-Ford's + set h [BellmanFord $G $s] + + #transformed graph no needed longer - deleting added node and edges + $G node delete $s + + #setting new weights for edges in graph G + foreach i [$G arcs] { + set u [$G arc source $i] + set v [$G arc target $i] + + lappend weights [$G arc getweight $i] + $G arc setweight $i [ expr { [$G arc getweight $i] + [dict get $h $u] - [dict get $h $v] } ] + } + + #finding distances between all pair of nodes with Dijkstra started from each node + foreach i [$G nodes] { + set dijkstra [dijkstra $G $i -arcmode directed -outputformat distances] + + foreach j [$G nodes] { + if { $i ne $j } { + if { $displaymode eq 1 } { + if { [dict get $dijkstra $j] ne "Inf" } { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } else { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } + } + } + + #setting back edge weights for graph G + set k 0 + foreach i [$G arcs] { + $G arc setweight $i [ lindex $weights $k ] + incr k + } + + return $values +} + + +#Floyd-Warshall's Algorithm +#------------------------------------------------------------------------------------- +#Searching shortest paths between all pairs of edges in weighted graphs. +#Time complexity: O(V^3) - where V is number of vertices. +#Memory complexity: O(V^2) +#Input: directed weighted graph G +#Output: dictionary containing shortest distances to each node from each node +# +#Algorithm finds solutions dynamically. It compares all possible paths through the graph +#between each pair of vertices. Graph shouldn't possess any cycle with negative +#sum of weights ( the presence of such cycles means there is no shortest path, +#since the total weight becomes lower each time the cycle is traversed ). +#On the other hand algorithm can be used to find those cycles - if any shortest distance +#found by algorithm for any nodes v and u (when v is the same node as u) is negative, +#that node surely belong to at least one negative cycle. +# +#Reference: http://en.wikipedia.org/wiki/Floyd-Warshall_algorithm +# + +proc ::struct::graph::op::FloydWarshall { G } { + + VerifyWeightsAreOk $G + + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + dict set values [list $v1 $v2] Inf + } + dict set values [list $v1 $v1] 0 + } + + foreach e [$G arcs] { + set v1 [$G arc source $e] + set v2 [$G arc target $e] + dict set values [list $v1 $v2] [$G arc getweight $e] + } + + foreach u [$G nodes] { + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + + set x [dict get $values [list $v1 $u]] + set y [dict get $values [list $u $v2]] + set d [ expr {$x + $y}] + + if { [dict get $values [list $v1 $v2]] > $d } { + dict set values [list $v1 $v2] $d + } + } + } + } + #finding negative cycles + foreach v [$G nodes] { + if { [dict get $values [list $v $v]] < 0 } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $values +} + +#Metric Travelling Salesman Problem (TSP) - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Input: undirected, weighted graph G +#Output: approximated solution of minimum Hamilton Cycle - closed path visiting all nodes, +#each exactly one time. +# +#Reference: http://en.wikipedia.org/wiki/Travelling_salesman_problem +# + +proc ::struct::graph::op::MetricTravellingSalesman { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + # Extend graph to make it complete. + # NOTE: The graph is modified in place. + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #TGraph - spanning tree of graph G + #filling TGraph with edges and nodes + set TGraph [createTGraph $G $T 0] + + #finding Hamilton cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + + $TGraph destroy + + # Note: Fleury, which is the algorithm used to find our the cycle + # (inside of isEulerian?) is inherently directionless, i.e. it + # doesn't care about arc direction. This does not matter if our + # input is a symmetric graph, i.e. u->v and v->u have the same + # weight for all nodes u, v in G, u != v. But for an asymmetric + # graph as our input we really have to check the two possible + # directions of the returned tour for the one with the smaller + # weight. See test case MetricTravellingSalesman-1.1 for an + # exmaple. + + set w {} + foreach a [$G arcs] { + set u [$G arc source $a] + set v [$G arc target $a] + set uv [list $u $v] + # uv = <$G arc nodes $arc> + dict set w $uv [$G arc getweight $a] + } + foreach k [dict keys $w] { + lassign $k u v + set vu [list $v $u] + if {[dict exists $w $vu]} continue + dict set w $vu [dict get $w $k] + } + + set reversed [lreverse $result] + + if {[TourWeight $w $result] > [TourWeight $w $reversed]} { + return $reversed + } + return $result +} + +proc ::struct::graph::op::TourWeight {w tour} { + set total 0 + foreach \ + u [lrange $tour 0 end-1] \ + v [lrange $tour 1 end] { + set uv [list $u $v] + set total [expr { + $total + + [dict get $w $uv] + }] + } + return $total +} + +#Christofides Algorithm - for Metric Travelling Salesman Problem (TSP) +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Christofides is a 3/2 approximation algorithm. For a graph given at input, it returns +#found Hamilton cycle (list of nodes). +# +#Reference: http://en.wikipedia.org/wiki/Christofides_algorithm +# + +proc ::struct::graph::op::Christofides { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #setting graph algorithm is working on - spanning tree of graph G + set TGraph [createTGraph $G $T 1] + + set oddTGraph [struct::graph] + + foreach v [$TGraph nodes] { + if { [$TGraph node degree $v] % 2 == 1 } { + $oddTGraph node insert $v + } + } + + #create complete graph + foreach v [$oddTGraph nodes] { + foreach u [$oddTGraph nodes] { + if { ($u ne $v) && ![$oddTGraph arc exists [list $u $v]] } { + $oddTGraph arc insert $v $u [list $v $u] + $oddTGraph arc setweight [list $v $u] [distance $G $v $u] + } + + } + } + + #### + # MAX MATCHING HERE!!! + #### + set M [GreedyMaxMatching $oddTGraph] + + foreach e [$oddTGraph arcs] { + if { ![struct::set contains $M $e] } { + $oddTGraph arc delete $e + } + } + + #operation: M + T + foreach e [$oddTGraph arcs] { + set u [$oddTGraph arc source $e] + set v [$oddTGraph arc target $e] + set uv [list $u $v] + + # Check if the arc in max-matching is parallel or not, to make + # sure that we always insert an anti-parallel arc. + + if {[$TGraph arc exists $uv]} { + set vu [list $v $u] + $TGraph arc insert $v $u $vu + $TGraph arc setweight $vu [$oddTGraph arc getweight $e] + } else { + $TGraph arc insert $u $v $uv + $TGraph arc setweight $uv [$oddTGraph arc getweight $e] + } + } + + #finding Hamilton Cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + $oddTGraph destroy + $TGraph destroy + return $result +} + +#Greedy Max Matching procedure, which finds maximal ( not maximum ) matching +#for given graph G. It adds edges to solution, beginning from edges with the +#lowest cost. + +proc ::struct::graph::op::GreedyMaxMatching {G} { + + set maxMatch {} + + foreach e [sortEdges $G] { + set v [$G arc source $e] + set u [$G arc target $e] + set neighbours [$G arcs -adj $v $u] + set noAdjacentArcs 1 + + lremove neighbours $e + + foreach a $neighbours { + if { $a in $maxMatch } { + set noAdjacentArcs 0 + break + } + } + if { $noAdjacentArcs } { + lappend maxMatch $e + } + } + + return $maxMatch +} + +#Subprocedure which for given graph G, returns the set of edges +#sorted with their costs. +proc ::struct::graph::op::sortEdges {G} { + set weights [$G arc weights] + + # NOTE: Look at possible rewrite, simplification. + + set sortedEdges {} + + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + lappend sortedEdges $x ;#[list $val $x] + } + } + } + + return $sortedEdges +} + +#Subprocedure, which for given graph G, returns the dictionary +#containing edges sorted by weights (sortMode -> weights) or +#nodes sorted by degree (sortMode -> degrees). + +proc ::struct::graph::op::sortGraph {G sortMode} { + + switch -exact -- $sortMode { + weights { + set weights [$G arc weights] + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + dict set sortedVals $x $val + } + } + } + } + degrees { + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + foreach x [lsort -integer -decreasing [dict values $degrees]] { + foreach y [dict keys $degrees] { + if { [dict get $degrees $y] == $x } { + set degrees [dict remove $degrees $y] + dict set sortedVals $y $x + } + } + } + } + default { + return -code error "Unknown sort mode \"$sortMode\", expected weights, or degrees" + } + } + + return $sortedVals +} + +#Finds Hamilton cycle in given graph G +#Procedure used by Metric TSP Algorithms: +#Christofides and Metric TSP 2-approximation algorithm + +proc ::struct::graph::op::findHamiltonCycle {G originalEdges originalGraph} { + + isEulerian? $G tourvar tourstart + + # Note: The start node is not necessarily the source node of the + # first arc in the tour. The Fleury in isEulerian? may have walked + # the arcs against! their direction. See also the note in our + # caller (MetricTravellingSalesman). + + # Instead of reconstructing the start node by intersecting the + # node-set for first and last arc, we are taking the easy and get + # it directly from isEulerian?, as that command knows which node + # it had chosen for this. + + lappend result $tourstart + lappend tourvar [lindex $tourvar 0] + + set v $tourstart + foreach i $tourvar { + set u [$G node opposite $v $i] + + if { $u ni $result } { + set va [lindex $result end] + set vb $u + + if { ([list $va $vb] in $originalEdges) || ([list $vb $va] in $originalEdges) } { + lappend result $u + } else { + + set path [dict get [dijkstra $G $va] $vb] + + #reversing the path + set path [lreverse $path] + #cutting the start element + set path [lrange $path 1 end] + + #adding the path and the target element + lappend result {*}$path + lappend result $vb + } + } + set v $u + } + + set path [dict get [dijkstra $originalGraph [lindex $result 0]] [lindex $result end]] + set path [lreverse $path] + + set path [lrange $path 1 end] + + if { [llength $path] } { + lappend result {*}$path + } + + lappend result $tourstart + return $result +} + +#Subprocedure for TSP problems. +# +#Creating graph from sets of given nodes and edges. +#In option doubledArcs we decide, if we want edges to be +#duplicated or not: +#0 - duplicated (Metric TSP 2-approximation algorithm) +#1 - single (Christofides Algorithm) +# +#Note that it assumes that graph's edges are properly weighted. That +#condition is checked before in procedures that use createTGraph, but for +#other uses it should be taken into consideration. +# + +proc ::struct::graph::op::createTGraph {G Edges doubledArcs} { + #checking if given set of edges is proper (all edges are in graph G) + foreach e $Edges { + if { ![$G arc exists $e] } { + return -code error "Edge \"$e\" doesn't exist in graph \"$G\". Set the proper set of edges." + } + } + + set TGraph [struct::graph] + + #fill TGraph with nodes + foreach v [$G nodes] { + $TGraph node insert + } + + #fill TGraph with arcs + foreach e $Edges { + set v [$G arc source $e] + set u [$G arc target $e] + if { ![$TGraph arc exists [list $u $v]] } { + $TGraph arc insert $u $v [list $u $v] + $TGraph arc setweight [list $u $v] [$G arc getweight $e] + } + if { !$doubledArcs } { + if { ![$TGraph arc exists [list $v $u]] } { + $TGraph arc insert $v $u [list $v $u] + $TGraph arc setweight [list $v $u] [$G arc getweight $e] + } + } + } + + return $TGraph +} + +#Subprocedure for some algorithms, e.g. TSP algorithms. +# +#It returns graph filled with arcs missing to say that graph is complete. +#Also it sets variable originalEdges with edges, which existed in given +#graph G at beginning, before extending the set of edges. +# + +proc ::struct::graph::op::createCompleteGraph {G originalEdges} { + + upvar $originalEdges st + set st {} + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend st [list $v $u] + } + + foreach v [$G nodes] { + foreach u [$G nodes] { + if { ($u != $v) && ([list $v $u] ni $st) && ([list $u $v] ni $st) && ![$G arc exists [list $u $v]] } { + $G arc insert $v $u [list $v $u] + $G arc setweight [list $v $u] Inf + } + } + } + return $G +} + + +#Maximum Cut - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Maximum cut problem is a problem finding a cut not smaller than any other cut. In +#other words, we divide set of nodes for graph G into such 2 sets of nodes U and V, +#that the amount of edges connecting U and V is as high as possible. +# +#Algorithm is a 2-approximation, so for ALG ( solution returned by Algorithm) and +#OPT ( optimal solution), such inequality is true: OPT <= 2 * ALG. +# +#Input: +#Graph G +#U - variable storing first set of nodes (cut) given by solution +#V - variable storing second set of nodes (cut) given by solution +# +#Output: +#Algorithm returns number of edges between found two sets of nodes. +# +#Reference: http://en.wikipedia.org/wiki/Maxcut +# + +proc ::struct::graph::op::MaxCut {G U V} { + + upvar $U _U + upvar $V _V + + set _U {} + set _V {} + set counter 0 + + foreach {u v} [lsort -dict [$G nodes]] { + lappend _U $u + if {$v eq ""} continue + lappend _V $v + } + + set val 1 + set ALG [countEdges $G $_U $_V] + while {$val>0} { + set val [cut $G _U _V $ALG] + if { $val > $ALG } { + set ALG $val + } + } + return $ALG +} + +#procedure replaces nodes between sets and checks if that change is profitable +proc ::struct::graph::op::cut {G Uvar Vvar param} { + + upvar $Uvar U + upvar $Vvar V + set _V {} + set _U {} + set value 0 + + set maxValue $param + set _U $U + set _V $V + + foreach v [$G nodes] { + + if { $v ni $_U } { + lappend _U $v + lremove _V $v + set value [countEdges $G $_U $_V] + } else { + lappend _V $v + lremove _U $v + set value [countEdges $G $_U $_V] + } + + if { $value > $maxValue } { + set U $_U + set V $_V + set maxValue $value + } else { + set _V $V + set _U $U + } + } + + set value $maxValue + + if { $value > $param } { + return $value + } else { + return 0 + } +} + +#Removing element from the list - auxiliary procedure +proc ::struct::graph::op::lremove {listVariable value} { + upvar 1 $listVariable var + set idx [lsearch -exact $var $value] + set var [lreplace $var $idx $idx] +} + +#procedure counts edges that link two sets of nodes +proc ::struct::graph::op::countEdges {G U V} { + + set value 0 + + foreach u $U { + foreach e [$G arcs -out $u] { + set v [$G arc target $e] + if {$v ni $V} continue + incr value + } + } + foreach v $V { + foreach e [$G arcs -out $v] { + set u [$G arc target $e] + if {$u ni $U} continue + incr value + } + } + + return $value +} + +#K-Center Problem - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Input: +#Undirected complete graph G, which satisfies triangle inequality. +#k - positive integer +# +#Definition: +#For any set S ( which is subset of V ) and node v, let the connect(v,S) be the +#cost of cheapest edge connecting v with any node in S. The goal is to find +#such S, that |S| = k and max_v{connect(v,S)} is possibly small. +# +#In other words, we can use it i.e. for finding best locations in the city ( nodes +#of input graph ) for placing k buildings, such that those buildings will be as close +#as possible to all other locations in town. +# +#Output: +#set of nodes - k center for graph G +# + +proc ::struct::graph::op::UnweightedKCenter {G k} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $k <= 0 } { + return -code error "The \"k\" value must be an positive integer." + } + + set j [ expr {$k+1} ] + + #variable for holding the graph G(i) in each iteration + set Gi [struct::graph] + #two squared graph G + set GiSQ [struct::graph] + #sorted set of edges for graph G + set arcs [sortEdges $G] + + #initializing both graph variables + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #index i for each iteration + + #we seek for final solution, as long as the max independent + #set Mi (found in particular iterations), such that |Mi| <= k, is found. + for {set index 0} {$j > $k} {incr index} { + #source node of an edge we add in current iteration + set u [$G arc source [lindex $arcs $index]] + #target node of an edge we add in current iteration + set v [$G arc target [lindex $arcs $index]] + + #adding edge Ei to graph G(i) + $Gi arc insert $u $v [list $u $v] + #extending G(i-1)**2 to G(i)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set for G(i)**2 + set Mi [GreedyMaxIndependentSet $GiSQ] + + #number of nodes in maximal independent set that was found + set j [llength $Mi] + } + + $Gi destroy + $GiSQ destroy + return $Mi +} + +#Weighted K-Center - 3 approximation algorithm +#------------------------------------------------------------------------------------- +# +#The variation of unweighted k-center problem. Besides the fact graph is edge-weighted, +#there are also weights on vertices of input graph G. We've got also restriction +#W. The goal is to choose such set of nodes S ( which is a subset of V ), that it's +#total weight is not greater than W and also function: max_v { min_u { cost(u,v) }} +#has the smallest possible worth ( v is a node in V and u is a node in S ). +# +#Note: +#For more information about K-Center problem check Unweighted K-Center algorithm +#description. + +proc ::struct::graph::op::WeightedKCenter {G nodeWeights W} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $W <= 0 } { + return -code error "The \"W\" value must be an positive integer." + } + #initilization + set j [ expr {$W+1} ] + + #graphs G(i) and G(i)**2 + set Gi [struct::graph] + set GiSQ [struct::graph] + #the set of arcs for graph G sorted with their weights (increasing) + set arcs [sortEdges $G] + + #initialization of graphs G(i) and G(i)**2 + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #the main loop - iteration over all G(i)'s and G(i)**2's, + #extended with each iteration till the solution is found + + foreach arc $arcs { + #initilization of the set of nodes, which are cheapest neighbours + #for particular nodes in maximal independent set + set Si {} + + set u [$G arc source $arc] + set v [$G arc target $arc] + + #extending graph G(i) + $Gi arc insert $u $v [list $u $v] + + #extending graph G(i)**2 from G(i-1)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set (Mi) for graph G(i)**2 found in the + #previous step. Mi is found using greedy algorithm that also considers + #weights on vertices. + set Mi [GreedyWeightedMaxIndependentSet $GiSQ $nodeWeights] + + #for each node u in Maximal Independent set found in previous step, + #we search for its cheapest ( considering costs at vertices ) neighbour. + #Note that node u is considered as it is a neighbour for itself. + foreach u $Mi { + + set minWeightOfSi Inf + + #the neighbours of u + set neighbours [$Gi nodes -adj $u] + set smallestNeighbour 0 + #u is a neighbour for itself + lappend neighbours $u + + #finding neighbour with minimal cost + foreach w [lsort -index 1 $nodeWeights] { + lassign $w node weight + if {[struct::set contains $neighbours $node]} { + set minWeightOfSi $weight + set smallestNeighbour $node + break + } + } + + lappend Si [list $smallestNeighbour $minWeightOfSi] + } + + set totalSiWeight 0 + set possibleSolution {} + + foreach s $Si { + #counting the total weight of the set of nodes - Si + set totalSiWeight [ expr { $totalSiWeight + [lindex $s 1] } ] + + #it's final solution, if weight found in previous step is + #not greater than W + lappend possibleSolution [lindex $s 0] + } + + #checking if final solution is found + if { $totalSiWeight <= $W } { + $Gi destroy + $GiSQ destroy + return $possibleSolution + } + } + + $Gi destroy + $GiSQ destroy + + #no solution found - error returned + return -code error "No k-center found for restriction W = $W" + +} + +#Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#A maximal independent set is an independent set such that adding any other node +#to the set forces the set to contain an edge. +# +#Note: +#Don't confuse it with maximum independent set, which is a largest independent set +#for a given graph G. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyMaxIndependentSet {G} { + + set result {} + set nodes [$G nodes] + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#Weighted Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#Weighted variation of Maximal Independent Set. It takes as an input argument +#not only graph G but also set of weights for all vertices in graph G. +# +#Note: +#Read also Maximal Independent Set description for more info. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyWeightedMaxIndependentSet {G nodeWeights} { + + set result {} + set nodes {} + foreach v [lsort -index 1 $nodeWeights] { + lappend nodes [lindex $v 0] + } + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + set neighbours [$G nodes -adj $v] + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#subprocedure creating from graph G two squared graph +#G^2 - graph in which edge between nodes u and v exists, +#if and only if, when distance (in edges, not weights) +#between those nodes is not greater than 2 and u != v. + +proc ::struct::graph::op::createSquaredGraph {G} { + + set H [struct::graph] + foreach v [$G nodes] { + $H node insert $v + } + + foreach v [$G nodes] { + foreach u [$G nodes -adj $v] { + if { ($v != $u) && ![$H arc exists [list $v $u]] && ![$H arc exists [list $u $v]] } { + $H arc insert $u $v [list $u $v] + } + foreach z [$G nodes -adj $u] { + if { ($v != $z) && ![$H arc exists [list $v $z]] && ![$H arc exists [list $z $v]] } { + $H arc insert $v $z [list $v $z] + } + } + } + } + + return $H +} + +#subprocedure for Metric K-Center problem +# +#Input: +#previousGsq - graph G(i-1)**2 +#currentGi - graph G(i) +#u and v - source and target of an edge added in this iteration +# +#Output: +#Graph G(i)**2 used by next steps of K-Center algorithm + +proc ::struct::graph::op::extendTwoSquaredGraph {previousGsq currentGi u v} { + + #adding new edge + if { ![$previousGsq arc exists [list $v $u]] && ![$previousGsq arc exists [list $u $v]]} { + $previousGsq arc insert $u $v [list $u $v] + } + + #adding new edges to solution graph: + #here edges, where source is a $u node and targets are neighbours of node $u except for $v + foreach x [$currentGi nodes -adj $u] { + if { ( $x != $v) && ![$previousGsq arc exists [list $v $x]] && ![$previousGsq arc exists [list $x $v]] } { + $previousGsq arc insert $v $x [list $v $x] + } + } + #here edges, where source is a $v node and targets are neighbours of node $v except for $u + foreach x [$currentGi nodes -adj $v] { + if { ( $x != $u ) && ![$previousGsq arc exists [list $u $x]] && ![$previousGsq arc exists [list $x $u]] } { + $previousGsq arc insert $u $x [list $u $x] + } + } + + return $previousGsq +} + +#Vertices Cover - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Vertices cover is a set o vertices such that each edge of the graph is incident to +#at least one vertex of the set. This 2-approximation algorithm searches for minimum +#vertices cover, which is a classical optimization problem in computer science and +#is a typical example of an NP-hard optimization problem that has an approximation +#algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Vertex_cover_problem +# + +proc ::struct::graph::op::VerticesCover {G} { + #variable containing final solution + set vc {} + #variable containing sorted (with degree) set of arcs for graph G + set arcs {} + + #setting the dictionary with degrees for each node + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + + #creating a list containing the sum of degrees for source and + #target nodes for each edge in graph G + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend values [list [expr {[dict get $degrees $v]+[dict get $degrees $u]}] $e] + } + #sorting the list of source and target degrees + set values [lsort -integer -decreasing -index 0 $values] + + #setting the set of edges in a right sequence + foreach e $values { + lappend arcs [lindex $e 1] + } + + #for each node in graph G, we add it to the final solution and + #erase all arcs adjacent to it, so they cannot be + #added to solution in next iterations + foreach e $arcs { + + if { [struct::set contains $arcs $e] } { + set v [$G arc source $e] + set u [$G arc target $e] + lappend vc $v $u + + foreach n [$G arcs -adj $v $u] { + struct::set exclude arcs $n + } + } + } + + return $vc +} + + +#Ford's Fulkerson algorithm - computing maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The general idea of algorithm is finding augumenting paths in graph G, as long +#as they exist, and for each path updating the edge's weights along that path, +#with maximum possible throughput. The final (maximum) flow is found +#when there is no other augumenting path from source to sink. +# +#Input: +#graph G - weighted and directed graph. Weights at edges are considered as +#maximum throughputs that can be carried by that link (edge). +#s - the node that is a source for graph G +#t - the node that is a sink for graph G +# +#Output: +#Procedure returns the dictionary contaning throughputs for all edges. For +#each key ( the edge between nodes u and v in the for of list u v ) there is +#a value that is a throughput for that key. Edges where throughput values +#are equal to 0 are not returned ( it is like there was no link in the flow network +#between nodes connected by such edge). +# +#Reference: http://en.wikipedia.org/wiki/Ford-Fulkerson_algorithm + +proc ::struct::graph::op::FordFulkerson {G s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { ![$G arc keyexists $e throughput] } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" for input graph." + } + } + + #initilization + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + #setting the residual graph for the first iteration + set residualG [createResidualGraph $G $f] + + #deleting the arcs that are 0-weighted + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + + #the main loop - works till the path between source and the sink can be found + while {1} { + set paths [ShortestsPathsByBFS $residualG $s paths] + + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + #setting the path from source to sink + + #adding sink to path + lappend path $t + + #finding the throughput of path p - the smallest value of c(f) among + #edges that are contained in the path + set maxThroughput Inf + + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set pathEdgeFlow [$residualG arc set [list $u $v] throughput] + if { $maxThroughput > $pathEdgeFlow } { + set maxThroughput $pathEdgeFlow + } + } + + #increase of throughput using the path p, with value equal to maxThroughput + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + #if maximum throughput that was found for the path p (maxThroughput) is bigger than current throughput + #at the edge not contained in the path p (for current pair of nodes u and v), then we add to the edge + #which is contained into path p the maxThroughput value decreased by the value of throughput at + #the second edge (not contained in path). That second edge's throughtput value is set to 0. + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + if { $maxThroughput >= $f_vu } { + dict set f [list $u $v] [ expr { $f_uv + $maxThroughput - $f_vu } ] + dict set f [list $v $u] 0 + } else { + + #if maxThroughput is not greater than current throughput at the edge not contained in path p (here - v->u), + #we add a difference between those values to edge contained in the path p (here u->v) and substract that + #difference from edge not contained in the path p. + set difference [ expr { $f_vu - $maxThroughput } ] + dict set f [list $u $v] [ expr { $f_uv + $difference } ] + dict set f [list $v $u] $maxThroughput + } + } + + #when the current throughput for the graph is updated, we generate new residual graph + #for new values of throughput + $residualG destroy + set residualG [createResidualGraph $G $f] + + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + } + + $residualG destroy + + #removing 0-weighted edges from solution + foreach e [dict keys $f] { + if { [dict get $f $e] == 0 } { + set f [dict remove $f $e] + } + } + + return $f +} + +#subprocedure for FordFulkerson's algorithm, which creates +#for input graph G and given throughput f residual graph +#for further operations to find maximum flow in flow network + +proc ::struct::graph::op::createResidualGraph {G f} { + + #initialization + set residualG [struct::graph] + + foreach v [$G nodes] { + $residualG node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set GF [list $u $v] [$G arc set $e throughput] + } + + foreach e [dict keys $GF] { + + lassign $e u v + + set c_uv [dict get $GF $e] + set flow_uv [dict get $f $e] + set flow_vu [dict get $f [list $v $u]] + + if { ![$residualG arc exists $e] } { + $residualG arc insert $u $v $e + } + + if { ![$residualG arc exists [list $v $u]] } { + $residualG arc insert $v $u [list $v $u] + } + + #new value of c_f(u,v) for residual Graph is a max flow value for this edge + #minus current flow on that edge + if { ![$residualG arc keyexists $e throughput] } { + if { [dict exists $GF [list $v $u]] } { + $residualG arc set [list $u $v] throughput [ expr { $c_uv - $flow_uv + $flow_vu } ] + } else { + $residualG arc set $e throughput [ expr { $c_uv - $flow_uv } ] + } + } + + if { [dict exists $GF [list $v $u]] } { + #when double arcs in graph G (u->v , v->u) + #so, x/y i w/z y-x+w + set c_vu [dict get $GF [list $v $u]] + if { ![$residualG arc keyexists [list $v $u] throughput] } { + $residualG arc set [list $v $u] throughput [ expr { $c_vu - $flow_vu + $flow_uv} ] + } + } else { + $residualG arc set [list $v $u] throughput $flow_uv + } + } + + #setting all weights at edges to 1 for proper usage of shortest paths finding procedures + $residualG arc setunweighted 1 + + return $residualG +} + +#Subprocedure for Busacker Gowen algorithm +# +#Input: +#graph G - flow network. Graph G has two attributes for each edge: +#cost and throughput. Each arc must have it's attribute value assigned. +#dictionary f - some flow for network G. Keys represent edges and values +#are flows at those edges +#path - set of nodes for which we transform the network +# +#Subprocedure checks 6 vital conditions and for them updates the network +#(let values with * be updates values for network). So, let edge (u,v) be +#the non-zero flow for network G, c(u,v) throughput of edge (u,v) and +#d(u,v) non-negative cost of edge (u,v): +#1. c*(v,u) = f(u,v) --- adding apparent arc +#2. d*(v,u) = -d(u,v) +#3. c*(u,v) = c(u,v) - f(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#4. d*(u,v) = d(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#5. c*(u,v) = 0 --- if f(v,u) = 0 and c(u,v) = f(u,v) +#6. d*(u,v) = Inf --- if f(v,u) = 0 and c(u,v) = f(u,v) + +proc ::struct::graph::op::createAugmentingNetwork {G f path} { + + set Gf [struct::graph] + + #setting the Gf graph + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #we set new values for each edge contained in the path from input + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + set c_uv [$G arc get [list $u $v] throughput] + set d_uv [$G arc get [list $u $v] cost] + + #adding apparent arcs + if { ![$Gf arc exists [list $v $u]] } { + $Gf arc insert $v $u [list $v $u] + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + } else { + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + $Gf arc set [list $u $v] cost Inf + $Gf arc set [list $u $v] throughput 0 + } + + if { ($f_vu == 0 ) && ( $c_uv > $f_uv ) } { + #3. + $Gf arc set [list $u $v] throughput [ expr { $c_uv - $f_uv } ] + #4. + $Gf arc set [list $u $v] cost $d_uv + } + + if { ($f_vu == 0 ) && ( $c_uv == $f_uv) } { + #5. + $Gf arc set [list $u $v] throughput 0 + #6. + $Gf arc set [list $u $v] cost Inf + } + } + + return $Gf +} + +#Busacker Gowen's algorithm - computing minimum cost maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The goal is to find a flow, whose max value can be d, from source node to +#sink node in given flow network. That network except throughputs at edges has +#also defined a non-negative cost on each edge - cost of using that edge when +#directing flow with that edge ( it can illustrate e.g. fuel usage, time or +#any other measure dependent on usages ). +# +#Input: +#graph G - flow network, weights at edges are costs of using particular edge +#desiredFlow - max value of the flow for that network +#dictionary c - throughputs for all edges +#node s - the source node for graph G +#node t - the sink node for graph G +# +#Output: +#f - dictionary containing values of used throughputs for each edge ( key ) +#found by algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Minimum_cost_flow_problem +# + +proc ::struct::graph::op::BusackerGowen {G desiredFlow s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + if { $desiredFlow <= 0 } { + return -code error "The \"desiredFlow\" value must be an positive integer." + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { !([$G arc keyexists $e throughput] && [$G arc keyexists $e cost]) } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" and \"cost\" for input graph." + } + } + + set Gf [struct::graph] + + #initialization of Augmenting Network + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #initialization of f + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + set currentFlow 0 + + #main loop - it ends when we reach desired flow value or there is no path in Gf + #leading from source node s to sink t + + while { $currentFlow < $desiredFlow } { + + #preparing correct values for pathfinding + foreach edge [$Gf arcs] { + $Gf arc setweight $edge [$Gf arc get $edge cost] + } + + #setting the path 'p' from 's' to 't' + set paths [ShortestsPathsByBFS $Gf $s paths] + + #if there are no more paths, the search has ended + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + lappend path $t + + #counting max throughput that is availiable to send + #using path 'p' + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set uv_throughput [$Gf arc set [list $u $v] throughput] + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #if max throughput that was found will cause exceeding the desired + #flow, send as much as it's possible + if { ( $currentFlow + $maxThroughput ) <= $desiredFlow } { + set fAdd $maxThroughput + set currentFlow [ expr { $currentFlow + $fAdd } ] + } else { + set fAdd [ expr { $desiredFlow - $currentFlow } ] + set currentFlow $desiredFlow + } + + #update the throuputs on edges + foreach v [lrange $path 0 end-1] u [lrange $path 1 end] { + if { [dict get $f [list $u $v]] >= $fAdd } { + dict set f [list $u $v] [ expr { [dict get $f [list $u $v]] - $fAdd } ] + } + + if { ( [dict get $f [list $u $v]] < $fAdd ) && ( [dict get $f [list $u $v]] > 0 ) } { + dict set f [list $v $u] [ expr { $fAdd - [dict get $f [list $u $v]] } ] + dict set f [list $u $v] 0 + } + + if { [dict get $f [list $u $v]] == 0 } { + dict set f [list $v $u] [ expr { [dict get $f [list $v $u]] + $fAdd } ] + } + } + + #create new Augemnting Network + + set Gfnew [createAugmentingNetwork $Gf $f $path] + $Gf destroy + set Gf $Gfnew + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + $Gf destroy + return $f +} + +# +proc ::struct::graph::op::ShortestsPathsByBFS {G s outputFormat} { + + switch -exact -- $outputFormat { + distances { + set outputMode distances + } + paths { + set outputMode paths + } + default { + return -code error "Unknown output format \"$outputFormat\", expected distances, or paths." + } + } + + set queue [list $s] + set result {} + + #initialization of marked nodes, distances and predecessors + foreach v [$G nodes] { + dict set marked $v 0 + dict set distances $v Inf + dict set pred $v -1 + } + + #the s node is initially marked and has 0 distance to itself + dict set marked $s 1 + dict set distances $s 0 + + #the main loop + while { [llength $queue] != 0 } { + + #removing top element from the queue + set v [lindex $queue 0] + lremove queue $v + + #for each arc that begins in v + foreach arc [$G arcs -out $v] { + + set u [$G arc target $arc] + set newlabel [ expr { [dict get $distances $v] + [$G arc getweight $arc] } ] + + if { $newlabel < [dict get $distances $u] } { + + dict set distances $u $newlabel + dict set pred $u $v + + #case when current node wasn't placed in a queue yet - + #we set u at the end of the queue + if { [dict get $marked $u] == 0 } { + lappend queue $u + dict set marked $u 1 + } else { + + #case when current node u was in queue before but it is not in it now - + #we set u at the beginning of the queue + if { [lsearch $queue $u] < 0 } { + set queue [linsert $queue 0 $u] + } + } + } + } + } + + #if the outputformat is paths, we travel back to find shorests paths + #to return sets of nodes for each node, which are their paths between + #s and particular node + dict set paths nopaths 1 + if { $outputMode eq "paths" } { + foreach node [$G nodes] { + + set path {} + set lastNode $node + + while { $lastNode != -1 } { + set currentNode [dict get $pred $lastNode] + if { $currentNode != -1 } { + lappend path $currentNode + } + set lastNode $currentNode + } + + set path [lreverse $path] + + if { [llength $path] != 0 } { + dict set paths $node $path + dict unset paths nopaths + } + } + + if { ![dict exists $paths nopaths] } { + return $paths + } else { + return {} + } + + #returning dictionary containing distance from start node to each other node (key) + } else { + return $distances + } + +} + +# +proc ::struct::graph::op::BFS {G s outputFormat} { + + set queue [list $s] + + switch -exact -- $outputFormat { + graph { + set outputMode graph + } + tree { + set outputMode tree + } + default { + return -code error "Unknown output format \"$outputFormat\", expected graph, or tree." + } + } + + if { $outputMode eq "graph" } { + #graph initializing + set BFSGraph [struct::graph] + foreach v [$G nodes] { + $BFSGraph node insert $v + } + } else { + #tree initializing + set BFSTree [struct::tree] + $BFSTree set root name $s + $BFSTree rename root $s + } + + #initilization of marked nodes + foreach v [$G nodes] { + dict set marked $v 0 + } + + #start node is marked from the beginning + dict set marked $s 1 + + #the main loop + while { [llength $queue] != 0 } { + #removing top element from the queue + + set v [lindex $queue 0] + lremove queue $v + + foreach x [$G nodes -adj $v] { + if { ![dict get $marked $x] } { + dict set marked $x 1 + lappend queue $x + + if { $outputMode eq "graph" } { + $BFSGraph arc insert $v $x [list $v $x] + } else { + $BFSTree insert $v end $x + } + } + } + } + + if { $outputMode eq "graph" } { + return $BFSGraph + } else { + return $BFSTree + } +} + +#Minimum Diameter Spanning Tree - MDST +#------------------------------------------------------------------------------------- +# +#The goal is to find for input graph G, the spanning tree that +#has the minimum diameter worth. +# +#General idea of algorithm is to run BFS over all vertices in graph +#G. If the diameter "d" of the tree is odd, then we are sure that tree +#given by BFS is minimum (considering diameter value). When, diameter "d" +#is even, then optimal tree can have minimum diameter equal to "d" or +#"d-1". +# +#In that case, what algorithm does is rebuilding the tree given by BFS, by +#adding a vertice between root node and root's child node (nodes), such that +#subtree created with child node as root node is the greatest one (has the +#greatests height). In the next step for such rebuilded tree, we run again BFS +#with new node as root node. If the height of the tree didn't changed, we have found +#a better solution. + +proc ::struct::graph::op::MinimumDiameterSpanningTree {G} { + + set min_diameter Inf + set best_Tree [struct::graph] + + foreach v [$G nodes] { + + #BFS Tree + set T [BFS $G $v tree] + #BFS Graph + set TGraph [BFS $G $v graph] + + #Setting all arcs to 1 for diameter procedure + $TGraph arc setunweighted 1 + + #setting values for current Tree + set diam [diameter $TGraph] + set subtreeHeight [ expr { $diam / 2 - 1} ] + + ############################################## + #case when diameter found for tree found by BFS is even: + #it's possible to decrease the diameter by one. + if { ( $diam % 2 ) == 0 } { + + #for each child u that current root node v has, we search + #for the greatest subtree(subtrees) with the root in child u. + # + foreach u [$TGraph nodes -adj $v] { + set u_depth 1 ;#[$T depth $u] + set d_depth 0 + + set descendants [$T descendants $u] + + foreach d $descendants { + if { $d_depth < [$T depth $d] } { + set d_depth [$T depth $d] + } + } + + #depth of the current subtree + set depth [ expr { $d_depth - $u_depth } ] + + #proceed if found subtree is the greatest one + if { $depth >= $subtreeHeight } { + + #temporary Graph for holding potential better values + set tempGraph [struct::graph] + + foreach node [$TGraph nodes] { + $tempGraph node insert $node + } + + #zmienic nazwy zmiennych zeby sie nie mylily + foreach arc [$TGraph arcs] { + set _u [$TGraph arc source $arc] + set _v [$TGraph arc target $arc] + $tempGraph arc insert $_u $_v [list $_u $_v] + } + + if { [$tempGraph arc exists [list $u $v]] } { + $tempGraph arc delete [list $u $v] + } else { + $tempGraph arc delete [list $v $u] + } + + #for nodes u and v, we add a node between them + #to again start BFS with root in new node to check + #if it's possible to decrease the diameter in solution + set node [$tempGraph node insert] + $tempGraph arc insert $node $v [list $node $v] + $tempGraph arc insert $node $u [list $node $u] + + set newtempGraph [BFS $tempGraph $node graph] + $tempGraph destroy + set tempGraph $newtempGraph + + $tempGraph node delete $node + $tempGraph arc insert $u $v [list $u $v] + $tempGraph arc setunweighted 1 + + set tempDiam [diameter $tempGraph] + + #if better tree is found (that any that were already found) + #replace it + if { $min_diameter > $tempDiam } { + set $min_diameter [diameter $tempGraph ] + $best_Tree destroy + set best_Tree $tempGraph + } else { + $tempGraph destroy + } + } + + } + } + ################################################################ + + set currentTreeDiameter $diam + + if { $min_diameter > $currentTreeDiameter } { + set min_diameter $currentTreeDiameter + $best_Tree destroy + set best_Tree $TGraph + } else { + $TGraph destroy + } + + $T destroy + } + + return $best_Tree +} + +#Minimum Degree Spanning Tree +#------------------------------------------------------------------------------------- +# +#In graph theory, minimum degree spanning tree (or degree-constrained spanning tree) +#is a spanning tree where the maximum vertex degree is as small as possible (or is +#limited to a certain constant k). The minimum degree spanning tree problem is to +#determine whether a particular graph has such a spanning tree for a particular k. +# +#Algorithm for input undirected graph G finds its spanning tree with the smallest +#possible degree. Algorithm is a 2-approximation, so it doesn't assure that optimal +#solution will be found. +# +#Reference: http://en.wikipedia.org/wiki/Degree-constrained_spanning_tree + +proc ::struct::graph::op::MinimumDegreeSpanningTree {G} { + + #initialization of spanning tree for G + set MST [struct::graph] + + foreach v [$G nodes] { + $MST node insert $v + } + + #forcing all arcs to be 1-weighted + foreach e [$G arcs] { + $G arc setweight $e 1 + } + + foreach e [kruskal $G] { + set u [$G arc source $e] + set v [$G arc target $e] + + $MST arc insert $u $v [list $u $v] + } + + #main loop + foreach e [$G arcs] { + + set u [$G arc source $e] + set v [$G arc target $e] + + #if nodes u and v are neighbours, proceed to next iteration + if { ![$MST arc exists [list $u $v]] && ![$MST arc exists [list $v $u]] } { + + $MST arc setunweighted 1 + + #setting the path between nodes u and v in Spanning Tree MST + set path [dict get [dijkstra $MST $u] $v] + lappend path $v + + #search for the node in the path, such that its degree is greater than degree of any of nodes + #u or v increased by one + foreach node $path { + if { [$MST node degree $node] > ([Max [$MST node degree $u] [$MST node degree $v]] + 1) } { + + #if such node is found add the arc between nodes u and v + $MST arc insert $u $v [list $u $v] + + #then to hold MST being a spanning tree, delete any arc that is in the path + #that is adjacent to found node + foreach n [$MST nodes -adj $node] { + if { $n in $path } { + if { [$MST arc exists [list $node $n]] } { + $MST arc delete [list $node $n] + } else { + $MST arc delete [list $n $node] + } + break + } + } + + # Node found, stop processing the path + break + } + } + } + } + + return $MST +} + +#Dinic algorithm for finding maximum flow in flow network +#------------------------------------------------------------------------------------- +# +#Reference: http://en.wikipedia.org/wiki/Dinic's_algorithm +# +proc ::struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} { + + if { !($blockingFlowAlg eq "dinic" || $blockingFlowAlg eq "mkm") } { + return -code error "Uncorrect name of blocking flow algorithm. Choose \"mkm\" for Malhotra, Kumar and Maheshwari algorithm and \"dinic\" for Dinic algorithm." + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + while {1} { + set residualG [createResidualGraph $G $f] + if { $blockingFlowAlg == "mkm" } { + set blockingFlow [BlockingFlowByMKM $residualG $s $t] + } else { + set blockingFlow [BlockingFlowByDinic $residualG $s $t] + } + $residualG destroy + + if { $blockingFlow == {} } break + + foreach key [dict keys $blockingFlow] { + dict set f $key [ expr { [dict get $f $key] + [dict get $blockingFlow $key] } ] + } + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + return $f +} + +#Dinic algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. find the path between s and t nodes in level graph +# 4. for each edge in path update current throughputs at those edges and... +# 5. ...deleting nodes from which there are no residual edges +#6. return the dictionary containing the blocking flow + +proc ::struct::graph::op::BlockingFlowByDinic {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. + set LevelGraph [createLevelGraph $G $s] + + #2. the main loop + while { [llength [$LevelGraph arcs]] > 0 } { + + if { ![$LevelGraph node exists $s] || ![$LevelGraph node exists $t] } break + + #3. + set paths [ShortestsPathsByBFS $LevelGraph $s paths] + + if { $paths == {} } break + if { ![dict exists $paths $t] } break + + set path [dict get $paths $t] + lappend path $t + + #setting the max throughput to go with the path found one step before + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #4. updating throughputs and blocking flow + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + #decreasing the throughputs contained in the path by max flow value + $LevelGraph arc set [list $u $v] throughput [ expr { $uv_throughput - $maxThroughput } ] + + #updating blocking flows + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $maxThroughput } ] + #dict set b [list $v $u] [ expr { -1 * [dict get $b [list $u $v]] } ] + + #5. deleting the arcs, whose throughput is completely used + if { [$LevelGraph arc get [list $u $v] throughput] == 0 } { + $LevelGraph arc delete [list $u $v] + } + + #deleting the node, if it hasn't any outgoing arcs + if { ($u != $s) && ( ![llength [$LevelGraph nodes -out $u]] || ![llength [$LevelGraph nodes -in $u]] ) } { + $LevelGraph node delete $u + } + } + + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + + #6. + return $b +} + +#Malhotra, Kumar and Maheshwari Algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#For given node v, Let c(v) be the min{ a, b }, where a is the sum of all incoming +#throughputs and b is the sum of all outcoming throughputs from the node v. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. finding the node with the minimum c(v) +# 4. sending c(v) units of throughput by incoming arcs of v +# 5. sending c(v) units of throughput by outcoming arcs of v +# 6. 4 and 5 steps can cause excess or deficiency of throughputs at nodes, so we +# send exceeds forward choosing arcs greedily and... +# 7. ...the same with deficiencies but we send those backward. +# 8. delete the v node from level graph +# 9. upgrade the c values for all nodes +# +#10. if no other edges left in level graph, return b - found blocking flow +# + +proc ::struct::graph::op::BlockingFlowByMKM {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. setting the level graph + set LevelGraph [createLevelGraph $G $s] + + #setting the in/out throughputs for each node + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #2. the main loop + while { [llength [$LevelGraph nodes]] > 2 } { + + #if there is no path between s and t nodes, end the procedure and + #return current blocking flow + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + if { [dict get $distances $t] == "Inf" } { + $LevelGraph destroy + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + return $b + } + + #3. finding the node with minimum value of c(v) + set min_cv Inf + + dict for {node cv} $c { + if { $min_cv > $cv } { + set min_cv $cv + set minCv_node $node + } + } + + #4. sending c(v) by all incoming arcs of node with minimum c(v) + set _min_cv $min_cv + foreach arc [$LevelGraph arcs -in $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $min_cv } ] + break + } else { + set difference [ expr { $min_cv - $t_arc } ] + set min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #5. sending c(v) by all outcoming arcs of node with minimum c(v) + foreach arc [$LevelGraph arcs -out $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $_min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $_min_cv } ] + break + } else { + set difference [ expr { $_min_cv - $t_arc } ] + set _min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #find exceeds and if any, send them forward or backwards + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + + #6. + for {set i [ expr {[dict get $distances $minCv_node] + 1}] } { $i < [llength [$G nodes]] } { incr i } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess > 0 } { + set b [sendForward $LevelGraph $w $b $excess] + } + } + } + } + + #7. + for { set i [ expr { [dict get $distances $minCv_node] - 1} ] } { $i > 0 } { incr i -1 } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess < 0 } { + set b [sendBack $LevelGraph $w $b [ expr { (-1) * $excess } ]] + } + } + } + } + + #8. delete current node from the network + $LevelGraph node delete $minCv_node + + #9. correctingg the in/out throughputs for each node after + #deleting one of the nodes in network + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #if node has no availiable outcoming or incoming throughput + #delete that node from the graph + dict for {key val} $c { + if { $val == 0 } { + $LevelGraph node delete $key + dict unset c $key + } + } + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + #10. + return $b +} + +#Subprocedure for algorithms that find blocking-flows. +#It's creating a level graph from the residual network. +proc ::struct::graph::op::createLevelGraph {Gf s} { + + set LevelGraph [struct::graph] + + $Gf arc setunweighted 1 + + #deleting arcs with 0 throughputs for proper pathfinding + foreach arc [$Gf arcs] { + if { [$Gf arc get $arc throughput] == 0 } { + $Gf arc delete $arc + } + } + + set distances [ShortestsPathsByBFS $Gf $s distances] + + foreach v [$Gf nodes] { + $LevelGraph node insert $v + $LevelGraph node set $v distance [dict get $distances $v] + } + + foreach e [$Gf arcs] { + set u [$Gf arc source $e] + set v [$Gf arc target $e] + + if { ([$LevelGraph node get $u distance] + 1) == [$LevelGraph node get $v distance]} { + $LevelGraph arc insert $u $v [list $u $v] + $LevelGraph arc set [list $u $v] throughput [$Gf arc get $e throughput] + } + } + + $LevelGraph arc setunweighted 1 + return $LevelGraph +} + +#Subprocedure for blocking flow finding by MKM algorithm +# +#It computes for graph G and each of his nodes the throughput value - +#for node v: from the sum of availiable throughputs from incoming arcs and +#the sum of availiable throughputs from outcoming arcs chooses lesser and sets +#as the throughput of the node. +# +#Throughputs of nodes are returned in the dictionary. +# +proc ::struct::graph::op::countThroughputsAtNodes {G s t} { + + set c {} + foreach v [$G nodes] { + + if { ($v eq $t) || ($v eq $s) } continue + + set outcoming [$G arcs -out $v] + set incoming [$G arcs -in $v] + + set outsum 0 + set insum 0 + + foreach o $outcoming i $incoming { + + if { [llength $o] > 0 } { + set outsum [ expr { $outsum + [$G arc get $o throughput] } ] + } + + if { [llength $i] > 0 } { + set insum [ expr { $insum + [$G arc get $i throughput] } ] + } + + set value [Min $outsum $insum] + } + + dict set c $v $value + } + + return $c +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, outcoming flow is bigger than incoming, then that deficiency +#has to be send back by that subprocedure. +proc ::struct::graph::op::sendBack {G node b value} { + + foreach arc [$G arcs -in $node] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, incoming flow is bigger than outcoming, then that exceed +#has to be send forward by that sub procedure. +proc ::struct::graph::op::sendForward {G node b value} { + + foreach arc [$G arcs -out $node] { + + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#It checks for graph G if node given at input has a exceed +#or deficiency of throughput. +# +#For exceed the positive value of exceed is returned, for deficiency +#procedure returns negative value. If the incoming throughput +#is the same as outcoming, procedure returns 0. +# +proc ::struct::graph::op::findExcess {G node b} { + + set incoming 0 + set outcoming 0 + + foreach key [dict keys $b] { + + lassign $key u v + if { $u eq $node } { + set outcoming [ expr { $outcoming + [dict get $b $key] } ] + } + if { $v eq $node } { + set incoming [ expr { $incoming + [dict get $b $key] } ] + } + } + + return [ expr { $incoming - $outcoming } ] +} + +#Travelling Salesman Problem - Heuristic of local searching +#2 - approximation Algorithm +#------------------------------------------------------------------------------------- +# + +proc ::struct::graph::op::TSPLocalSearching {G C} { + + foreach arc $C { + if { ![$G arc exists $arc] } { + return -code error "Given cycle has arcs not included in graph G." + } + } + + #initialization + set CGraph [struct::graph] + set GCopy [struct::graph] + set w 0 + + foreach node [$G nodes] { + $CGraph node insert $node + $GCopy node insert $node + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $GCopy arc insert $u $v [list $u $v] + $GCopy arc set [list $u $v] weight [$G arc get $arc weight] + } + + foreach arc $C { + + set u [$G arc source $arc] + set v [$G arc target $arc] + set arcWeight [$G arc get $arc weight] + + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set [list $u $v] weight $arcWeight + + set w [ expr { $w + $arcWeight } ] + } + + set reductionDone 1 + + while { $reductionDone } { + + set queue {} + set reductionDone 0 + + #double foreach loop goes through all pairs of arcs + foreach i [$CGraph arcs] { + + #source and target nodes of first arc + set iu [$CGraph arc source $i] + set iv [$CGraph arc target $i] + + #second arc + foreach j [$CGraph arcs] { + + #if pair of arcs already was considered, continue with next pair of arcs + if { [list $j $i] ni $queue } { + + #add current arc to queue to mark that it was used + lappend queue [list $i $j] + + set ju [$CGraph arc source $j] + set jv [$CGraph arc target $j] + + #we consider only arcs that are not adjacent + if { !($iu eq $ju) && !($iu eq $jv) && !($iv eq $ju) && !($iv eq $jv) } { + + #set the current cycle + set CPrim [copyGraph $CGraph] + + #transform the current cycle: + #1. + $CPrim arc delete $i + $CPrim arc delete $j + + + set param 0 + + #adding new edges instead of erased ones + if { !([$CPrim arc exists [list $iu $ju]] || [$CPrim arc exists [list $iv $jv]] || [$CPrim arc exists [list $ju $iu]] || [$CPrim arc exists [list $jv $iv]] ) } { + + $CPrim arc insert $iu $ju [list $iu $ju] + $CPrim arc insert $iv $jv [list $iv $jv] + + if { [$GCopy arc exists [list $iu $ju]] } { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $iu $ju] weight] + } else { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $ju $iu] weight] + } + + if { [$GCopy arc exists [list $iv $jv]] } { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $iv $jv] weight] + } else { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $jv $iv] weight] + } + } else { + set param 1 + } + + $CPrim arc setunweighted 1 + + #check if it's still a cycle or if any arcs were added instead those erased + if { !([struct::graph::op::distance $CPrim $iu $ju] > 0 ) || $param } { + + #deleting new edges if they were added before in current iteration + if { !$param } { + $CPrim arc delete [list $iu $ju] + } + + if { !$param } { + $CPrim arc delete [list $iv $jv] + } + + #adding new ones that will assure the graph is still a cycle + $CPrim arc insert $iu $jv [list $iu $jv] + $CPrim arc insert $iv $ju [list $iv $ju] + + if { [$GCopy arc exists [list $iu $jv]] } { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $iu $jv] weight] + } else { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $jv $iu] weight] + } + + if { [$GCopy arc exists [list $iv $ju]] } { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $iv $ju] weight] + } else { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $ju $iv] weight] + } + } + + #count current value of cycle + set cycleWeight [countCycleWeight $CPrim] + + #if we found cycle with lesser sum of weights, we set is as a result and + #marked that reduction was successful + if { $w > $cycleWeight } { + set w $cycleWeight + set reductionDone 1 + set C [$CPrim arcs] + } + + $CPrim destroy + } + } + } + } + + #setting the new current cycle if the reduction was successful + if { $reductionDone } { + foreach arc [$CGraph arcs] { + $CGraph arc delete $arc + } + for {set i 0} { $i < [llength $C] } { incr i } { + lset C $i [lsort [lindex $C $i]] + } + + foreach arc [$GCopy arcs] { + if { [lsort $arc] in $C } { + set u [$GCopy arc source $arc] + set v [$GCopy arc target $arc] + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set $arc weight [$GCopy arc get $arc weight] + } + } + } + } + + $GCopy destroy + $CGraph destroy + + return $C +} + +proc ::struct::graph::op::copyGraph {G} { + + set newGraph [struct::graph] + + foreach node [$G nodes] { + $newGraph node insert $node + } + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $newGraph arc insert $u $v $arc + $newGraph arc set $arc weight [$G arc get $arc weight] + } + + return $newGraph +} + +proc ::struct::graph::op::countCycleWeight {G} { + + set result 0 + + foreach arc [$G arcs] { + set result [ expr { $result + [$G arc get $arc weight] } ] + } + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Joseph Kruskal. The +# result is a set (as list) containing the names of the arcs in the +# MST. The set of nodes of the MST is implied by set of arcs, and thus +# not given explicitly. The algorithm does not consider arc +# directions. Note that unconnected nodes are left out of the result. + +# Reference: http://en.wikipedia.org/wiki/Kruskal%27s_algorithm + +proc ::struct::graph::op::kruskal {g} { + # Check graph argument for proper configuration. + + VerifyWeightsAreOk $g + + # Transient helper data structures. A priority queue for the arcs + # under consideration, using their weights as priority, and a + # disjoint-set to keep track of the forest of partial minimum + # spanning trees we are working with. + + set consider [::struct::prioqueue -dictionary consider] + set forest [::struct::disjointset forest] + + # Start with all nodes in the graph each in their partition. + + foreach n [$g nodes] { + $forest add-partition $n + } + + # Then fill the queue with all arcs, using their weight to + # prioritize. The weight is the cost of the arc. The lesser the + # better. + + foreach {arc weight} [$g arc weights] { + $consider put $arc $weight + } + + # And now we can construct the tree. This is done greedily. In + # each round we add the arc with the smallest weight to the + # minimum spanning tree, except if doing so would violate the tree + # condition. + + set result {} + + while {[$consider size]} { + set minarc [$consider get] + set origin [$g arc source $minarc] + set destin [$g arc target $minarc] + + # Ignore the arc if both ends are in the same partition. Using + # it would add a cycle to the result, i.e. it would not be a + # tree anymore. + + if {[$forest equal $origin $destin]} continue + + # Take the arc for the result, and merge the trees both ends + # are in into a single tree. + + lappend result $minarc + $forest merge $origin $destin + } + + # We are done. Get rid of the transient helper structures and + # return our result. + + $forest destroy + $consider destroy + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Prim. The result is a +# set (as list) containing the names of the arcs in the MST. The set +# of nodes of the MST is implied by set of arcs, and thus not given +# explicitly. The algorithm does not consider arc directions. + +# Reference: http://en.wikipedia.org/wiki/Prim%27s_algorithm + +proc ::struct::graph::op::prim {g} { + VerifyWeightsAreOk $g + + # Fill an array with all nodes, to track which nodes have been + # visited at least once. When the inner loop runs out of nodes and + # we still have some left over we restart using one of the + # leftover as new starting point. In this manner we get the MST of + # the whole graph minus unconnected nodes, instead of only the MST + # for the component the initial starting node is in. + + array set unvisited {} + foreach n [$g nodes] { set unvisited($n) . } + + # Transient helper data structure. A priority queue for the nodes + # and arcs under consideration for inclusion into the MST. Each + # element of the queue is a list containing node name, a flag bit, + # and arc name, in this order. The associated priority is the + # weight of the arc. The flag bit is set for the initial queue + # entry only, containing a fake (empty) arc, to trigger special + # handling. + + set consider [::struct::prioqueue -dictionary consider] + + # More data structures, the result arrays. + array set weightmap {} ; # maps nodes to min arc weight seen so + # far. This is the threshold other arcs + # on this node will have to beat to be + # added to the MST. + array set arcmap {} ; # maps arcs to nothing, these are the + # arcs in the MST. + + while {[array size unvisited]} { + # Choose a 'random' node as the starting point for the inner + # loop, prim's algorithm, and put it on the queue for + # consideration. Then we iterate until we have considered all + # nodes in the its component. + + set startnode [lindex [array names unvisited] 0] + $consider put [list $startnode 1 {}] 0 + + while {[$consider size] > 0} { + # Pull the next minimum weight to look for. This is the + # priority of the next item we can get from the queue. And the + # associated node/decision/arc data. + + set arcweight [$consider peekpriority 1] + + foreach {v arcundefined arc} [$consider get] break + #8.5: lassign [$consider get] v arcundefined arc + + # Two cases to consider: The node v is already part of the + # MST, or not. If yes we check if the new arcweight is better + # than what we have stored already, and update accordingly. + + if {[info exists weightmap($v)]} { + set currentweight $weightmap($v) + if {$arcweight < $currentweight} { + # The new weight is better, update to use it as + # the new threshold. Note that this fill not touch + # any other arcs found for this node, as these are + # still minimal. + + set weightmap($v) $arcweight + set arcmap($arc) . + } + } else { + # Node not yet present. Save weight and arc. The + # latter if and only the arc is actually defined. For + # the first, initial queue entry, it is not. Then we + # add all the arcs adjacent to the current node to the + # queue to consider them in the next rounds. + + set weightmap($v) $arcweight + if {!$arcundefined} { + set arcmap($arc) . + } + foreach adjacentarc [$g arcs -adj $v] { + set weight [$g arc getweight $adjacentarc] + set neighbour [$g node opposite $v $adjacentarc] + $consider put [list $neighbour 0 $adjacentarc] $weight + } + } + + # Mark the node as visited, belonging to the current + # component. Future iterations will ignore it. + unset -nocomplain unvisited($v) + } + } + + # We are done. Get rid of the transient helper structure and + # return our result. + + $consider destroy + + return [array names arcmap] +} + +# ### ### ### ######### ######### ######### +## + +# This command checks whether the graph argument is bi-partite or not, +# and returns the result as a boolean value, true for a bi-partite +# graph, and false otherwise. A variable can be provided to store the +# bi-partition into. +# +# Reference: http://en.wikipedia.org/wiki/Bipartite_graph + +proc ::struct::graph::op::isBipartite? {g {bipartitionvar {}}} { + + # Handle the special cases of empty graphs, or one without arcs + # quickly. Both are bi-partite. + + if {$bipartitionvar ne ""} { + upvar 1 $bipartitionvar bipartitions + } + if {![llength [$g nodes]]} { + set bipartitions {{} {}} + return 1 + } elseif {![llength [$g arcs]]} { + if {$bipartitionvar ne ""} { + set bipartitions [list [$g nodes] {}] + } + return 1 + } + + # Transient helper data structure, a queue of the nodes waiting + # for processing. + + set pending [struct::queue pending] + set nodes [$g nodes] + + # Another structure, a map from node names to their 'color', + # indicating which of the two partitions a node belngs to. All + # nodes start out as undefined (0). Traversing the arcs we + # set and flip them as needed (1,2). + + array set color {} + foreach node $nodes { + set color($node) 0 + } + + # Iterating over all nodes we use their connections to traverse + # the components and assign colors. We abort when encountering + # paradox, as that means that the graph is not bi-partite. + + foreach node $nodes { + # Ignore nodes already in the second partition. + if {$color($node)} continue + + # Flip the color, then travel the component and check for + # conflicts with the neighbours. + + set color($node) 1 + + $pending put $node + while {[$pending size]} { + set current [$pending get] + foreach neighbour [$g nodes -adj $current] { + if {!$color($neighbour)} { + # Exchange the color between current and previous + # nodes, and remember the neighbour for further + # processing. + set color($neighbour) [expr {3 - $color($current)}] + $pending put $neighbour + } elseif {$color($neighbour) == $color($current)} { + # Color conflict between adjacent nodes, should be + # different. This graph is not bi-partite. Kill + # the data structure and abort. + + $pending destroy + return 0 + } + } + } + } + + # The graph is bi-partite. Kill the transient data structure, and + # move the partitions into the provided variable, if there is any. + + $pending destroy + + if {$bipartitionvar ne ""} { + # Build bipartition, then set the data into the variable + # passed as argument to this command. + + set X {} + set Y {} + + foreach {node partition} [array get color] { + if {$partition == 1} { + lappend X $node + } else { + lappend Y $node + } + } + set bipartitions [list $X $Y] + } + + return 1 +} + +# ### ### ### ######### ######### ######### +## + +# This command computes a maximal matching, if it exists, for the +# graph argument G and its bi-partition as specified through the node +# sets X and Y. As is implied, this method requires that the graph is +# bi-partite. Use the command 'isBipartite?' to check for this +# property, and to obtain the bi-partition. +if 0 { + proc ::struct::graph::op::maxMatching {g X Y} { + return -code error "not implemented yet" + }} + +# ### ### ### ######### ######### ######### +## + +# This command computes the strongly connected components (SCCs) of +# the graph argument G. The result is a list of node-sets, each set +# containing the nodes of one SCC of G. In any SCC there is a directed +# path between any two nodes U, V from U to V. If all SCCs contain +# only a single node the graph is acyclic. + +proc ::struct::graph::op::tarjan {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no SCCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own SCC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Transient data structures. Stack of nodes to consider, the + # result, and various state arrays. TarjanSub upvar's all them + # into its scope. + + set pending [::struct::stack pending] + set result {} + + array set index {} + array set lowlink {} + array set instack {} + + # Invoke the main search system while we have unvisited + # nodes. TarjanSub will remove all visited nodes from 'all', + # ensuring termination. + + while {[llength $all]} { + TarjanSub [lindex $all 0] 0 + } + + # Release the transient structures and return result. + $pending destroy + return $result +} + +proc ::struct::graph::op::TarjanSub {start counter} { + # Import the tracer state from our caller. + upvar 1 g g index index lowlink lowlink instack instack result result pending pending all all + + struct::set subtract all $start + + set component {} + set index($start) $counter + set lowlink($start) $counter + incr counter + + $pending push $start + set instack($start) 1 + + foreach outarc [$g arcs -out $start] { + set neighbour [$g arc target $outarc] + + if {![info exists index($neighbour)]} { + # depth-first-search of reachable nodes from the neighbour + # node. Original from the chosen startnode. + TarjanSub $neighbour $counter + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + + } elseif {[info exists instack($neighbour)]} { + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + } + } + + # Check if the 'start' node on this recursion level is the root + # node of a SCC, and collect the component if yes. + + if {$lowlink($start) == $index($start)} { + while {1} { + set v [$pending pop] + unset instack($v) + lappend component $v + if {$v eq $start} break + } + lappend result $component + } + + return +} + +# ### ### ### ######### ######### ######### +## + +# This command computes the connected components (CCs) of the graph +# argument G. The result is a list of node-sets, each set containing +# the nodes of one CC of G. In any CC there is UN-directed path +# between any two nodes U, V. + +proc ::struct::graph::op::connectedComponents {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no CCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own CC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Invoke the main search system while we have unvisited + # nodes. + + set result {} + while {[llength $all]} { + set component [ComponentOf $g [lindex $all 0]] + lappend result $component + # all = all - component + struct::set subtract all $component + } + return $result +} + +# A derivative command which computes the connected component (CC) of +# the graph argument G containing the node N. The result is a node-set +# containing the nodes of the CC of N in G. + +proc ::struct::graph::op::connectedComponentOf {g n} { + # Quick bailout for simple special cases + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } elseif {![llength [$g arcs -adj $n]]} { + # The chosen node has no neighbours, so is its own CC. + return [list $n] + } + + # Invoke the main search system for the chosen node. + + return [ComponentOf $g $n] +} + +# Internal helper for finding connected components. + +proc ::struct::graph::op::ComponentOf {g start} { + set pending [::struct::queue pending] + $pending put $start + + array set visited {} + set visited($start) . + + while {[$pending size]} { + set current [$pending get 1] + foreach neighbour [$g nodes -adj $current] { + if {[info exists visited($neighbour)]} continue + $pending put $neighbour + set visited($neighbour) 1 + } + } + $pending destroy + return [array names visited] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified arc A in the graph G is a +# bridge, i.e. if its removal will split the connected component its +# end nodes belong to, into two. The result is a boolean value. Uses +# the 'ComponentOf' helper command. + +proc ::struct::graph::op::isBridge? {g arc} { + if {![$g arc exists $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create a new unnamed helper node X. Move the arc + # destination to X. Recompute the component and ignore + # X. Then move the arc target back to its original node + # and remove X again. + + set src [$g arc source $arc] + set compBefore [ComponentOf $g $src] + if {[llength $compBefore] == 1} { + # Special case, the arc is a loop on an otherwise unconnected + # node. The component will not split, this is not a bridge. + return 0 + } + + set copy [struct::graph BridgeCopy = $g] + $copy arc delete $arc + set compAfter [ComponentOf $copy $src] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the specified node N in the graph G is a +# cut vertex, i.e. if its removal will split the connected component +# it belongs to into two. The result is a boolean value. Uses the +# 'ComponentOf' helper command. + +proc ::struct::graph::op::isCutVertex? {g n} { + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create two new unnamed helper nodes X and Y. Move the + # icoming and outgoing arcs to these helpers. Recompute + # the component and ignore the helpers. Then move the arcs + # back to their original nodes and remove the helpers + # again. + + set compBefore [ComponentOf $g $n] + + if {[llength $compBefore] == 1} { + # Special case. The node is unconnected. Its removal will + # cause no changes. Therefore not a cutvertex. + return 0 + } + + # We remove the node from the original component, so that we can + # select a new start node without fear of hitting on the + # cut-vertex candidate. Also makes the comparison later easier + # (straight ==). + struct::set subtract compBefore $n + + set copy [struct::graph CutVertexCopy = $g] + $copy node delete $n + set compAfter [ComponentOf $copy [lindex $compBefore 0]] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the graph G is connected. + +proc ::struct::graph::op::isConnected? {g} { + return [expr { [llength [connectedComponents $g]] == 1 }] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified graph G has an eulerian +# cycle (aka euler tour, <=> g is eulerian) or not. If yes, it can +# return the cycle through the named variable, as a list of arcs +# traversed. +# +# Note that for a graph to be eulerian all nodes have to have an even +# degree, and the graph has to be connected. And if more than two +# nodes have an odd degree the graph is not even semi-eulerian (cannot +# even have an euler path). + +proc ::struct::graph::op::isEulerian? {g {eulervar {}} {tourstart {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler cycle is present. + return 0 + } + + # Check the condition regarding even degree nodes, then + # connected-ness. + + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + # Odd degree node found, not eulerian. + return 0 + } + + if {![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with all nodes of even + # degree. As per Carl Hierholzer the graph has to have an euler + # tour. If the user doesn't request it we do not waste the time to + # actually compute one. + + if {$tourstart ne ""} { + upvar 1 $tourstart start + } + + # We start the tour at an arbitrary node. + set start [lindex $nodes 0] + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar tour + Fleury $g $start tour + return 1 +} + +# This command determines if the specified graph G has an eulerian +# path (<=> g is semi-eulerian) or not. If yes, it can return the +# path through the named variable, as a list of arcs traversed. +# +# (*) Aka euler tour. +# +# Note that for a graph to be semi-eulerian at most two nodes are +# allowed to have an odd degree, all others have to be of even degree, +# and the graph has to be connected. + +proc ::struct::graph::op::isSemiEulerian? {g {eulervar {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler path is present. + return 0 + } + + # Check the condition regarding oddd/even degree nodes, then + # connected-ness. + + set odd 0 + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + incr odd + set lastodd $n + } + if {($odd > 2) || ![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with the node degrees + # supporting existence of an euler path. If the user doesn't + # request it we do not waste the time to actually compute one. + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar path + + # We start at either an odd-degree node, or any node, if there are + # no odd-degree ones. In the last case we are actually + # constructing an euler tour, i.e. a closed path. + + if {$odd} { + set start $lastodd + } else { + set start [lindex $nodes 0] + } + + Fleury $g $start path + return 1 +} + +proc ::struct::graph::op::Fleury {g start eulervar} { + upvar 1 $eulervar path + + # We start at the chosen node. + + set copy [struct::graph FleuryCopy = $g] + set path {} + + # Edges are chosen per Fleury's algorithm. That is easy, + # especially as we already have a command to determine whether an + # arc is a bridge or not. + + set arcs [$copy arcs] + while {![struct::set empty $arcs]} { + set adjacent [$copy arcs -adj $start] + + if {[llength $adjacent] == 1} { + # No choice in what arc to traverse. + set arc [lindex $adjacent 0] + } else { + # Choose first non-bridge arcs. The euler conditions force + # that at least two such are present. + + set has 0 + foreach arc $adjacent { + if {[isBridge? $copy $arc]} { + continue + } + set has 1 + break + } + if {!$has} { + $copy destroy + return -code error {Internal error} + } + } + + set start [$copy node opposite $start $arc] + $copy arc delete $arc + struct::set exclude arcs $arc + lappend path $arc + } + + $copy destroy + return +} + +# ### ### ### ######### ######### ######### +## + +# This command uses dijkstra's algorithm to find all shortest paths in +# the graph G starting at node N. The operation can be configured to +# traverse arcs directed and undirected, and the format of the result. + +proc ::struct::graph::op::dijkstra {g node args} { + # Default traversal is undirected. + # Default output format is tree. + + set arcTraversal undirected + set resultFormat tree + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + -outputformat { + switch -exact -- $param { + tree - + distances { + set resultFormat $param + } + default { + return -code error "Bad value for -outputformat, expected one of \"distances\" or \"tree\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected one of \"-arcmode\" or \"-outputformat\"" + } + } + } + + # We expect that all arcs of g are given a weight. + VerifyWeightsAreOk $g + + # And the start node has to belong to the graph too, of course. + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + # TODO: Quick bailout for special cases (no arcs). + + # Transient and other data structures for the core algorithm. + set pending [::struct::prioqueue -dictionary DijkstraQueue] + array set distance {} ; # array: node -> distance to 'n' + array set previous {} ; # array: node -> parent in shortest path to 'n'. + array set visited {} ; # array: node -> bool, true when node processed + + # Initialize the data structures. + foreach n [$g nodes] { + set distance($n) Inf + set previous($n) undefined + set visited($n) 0 + } + + # Compute the distances ... + $pending put $node 0 + set distance($node) 0 + set previous($node) none + + while {[$pending size]} { + set current [$pending get] + set visited($current) 1 + + # Traversal to neighbours according to the chosen mode. + if {$arcTraversal eq "undirected"} { + set arcNeighbours [$g arcs -adj $current] + } else { + set arcNeighbours [$g arcs -out $current] + } + + # Compute distances, record newly discovered nodes, minimize + # distances for nodes reachable through multiple paths. + foreach arcNeighbour $arcNeighbours { + set cost [$g arc getweight $arcNeighbour] + set neighbour [$g node opposite $current $arcNeighbour] + set delta [expr {$distance($current) + $cost}] + + if { + ($distance($neighbour) eq "Inf") || + ($delta < $distance($neighbour)) + } { + # First path, or better path to the node folund, + # update our records. + + set distance($neighbour) $delta + set previous($neighbour) $current + if {!$visited($neighbour)} { + $pending put $neighbour $delta + } + } + } + } + + $pending destroy + + # Now generate the result based on the chosen format. + if {$resultFormat eq "distances"} { + return [array get distance] + } else { + array set listofprevious {} + foreach n [$g nodes] { + set current $n + while {1} { + if {$current eq "undefined"} break + if {$current eq $node} { + lappend listofprevious($n) $current + break + } + if {$current ne $n} { + lappend listofprevious($n) $current + } + set current $previous($current) + } + } + return [array get listofprevious] + } +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed distance between two nodes in the graph G. + +proc ::struct::graph::op::distance {g origin destination args} { + if {![$g node exists $origin]} { + return -code error "node \"$origin\" does not exist in graph \"$g\"" + } + if {![$g node exists $destination]} { + return -code error "node \"$destination\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Quick bailout for special case: the distance from a node to + # itself is zero + + if {$origin eq $destination} { + return 0 + } + + # Compute all distances, then pick and return the one we are + # interested in. + array set distance [dijkstra $g $origin -outputformat distances -arcmode $arcTraversal] + return $distance($destination) +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed eccentricity of the node N in the graph G. The +# eccentricity is the maximal distance to any other node in the graph. + +proc ::struct::graph::op::eccentricity {g node args} { + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Compute all distances, then pick out the max + + set ecc 0 + foreach {n distance} [dijkstra $g $node -outputformat distances -arcmode $arcTraversal] { + if {$distance eq "Inf"} { return Inf } + if {$distance > $ecc} { set ecc $distance } + } + + return $ecc +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed radius of the graph G. The radius is the minimal +# eccentricity over all nodes in the graph. + +proc ::struct::graph::op::radius {g args} { + return [lindex [RD $g $args] 0] +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed diameter of the graph G. The diameter is the +# maximal eccentricity over all nodes in the graph. + +proc ::struct::graph::op::diameter {g args} { + return [lindex [RD $g $args] 1] +} + +proc ::struct::graph::op::RD {g options} { + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $options { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + set radius Inf + set diameter 0 + foreach n [$g nodes] { + set e [eccentricity $g $n -arcmode $arcTraversal] + #puts "$n ==> ($e)" + if {($e eq "Inf") || ($e > $diameter)} { + set diameter $e + } + if {($radius eq "Inf") || ($e < $radius)} { + set radius $e + } + } + + return [list $radius $diameter] +} + +# +## place holder for operations to come +# + +# ### ### ### ######### ######### ######### +## Internal helpers + +proc ::struct::graph::op::Min {first second} { + if {$first > $second} { + return $second + } else { + return $first + } +} + +proc ::struct::graph::op::Max {first second} { + if {$first < $second} { + return $second + } else { + return $first + } +} + +# This method verifies that every arc on the graph has a weight +# assigned to it. This is required for some algorithms. +proc ::struct::graph::op::VerifyWeightsAreOk {g} { + if {![llength [$g arc getunweighted]]} return + return -code error "Operation invalid for graph with unweighted arcs." +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct::graph::op { + #namespace export ... +} + +package provide struct::graph::op 0.11.3 diff --git a/tcllib/modules/struct/graphops.test b/tcllib/modules/struct/graphops.test new file mode 100644 index 0000000..ee2d1f3 --- /dev/null +++ b/tcllib/modules/struct/graphops.test @@ -0,0 +1,67 @@ +# -*- tcl -*- +# graphops.test: tests for the operations on graph structures. +# +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# All rights reserved. +# +# RCS: @(#) $Id: graphops.test,v 1.4 2009/09/24 19:30:11 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 + +support { + useLocal list.tcl struct::list + + useAccel [useTcllibC] struct/tree.tcl struct::tree + TestAccelInit struct::tree + + useAccel [useTcllibC] struct/queue.tcl struct::queue + TestAccelInit struct::queue + + useAccel [useTcllibC] struct/stack.tcl struct::stack + TestAccelInit struct::stack + + useAccel [useTcllibC] struct/sets.tcl struct::set + TestAccelInit struct::set + + useAccel [useTcllibC] struct/graph.tcl struct::graph + TestAccelInit struct::graph + + useLocalFile graph/tests/XOpsSupport +} +testing { + useLocal graphops.tcl struct::graph::op +} + +# ------------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in graphops.testsuite) is expecting from the environment. This code +# runs the testsuite 32 (2^5) times, covering all possible +# combinations of tcl/c implementations. + +TestAccelDo struct::tree treeimpl { + TestAccelDo struct::stack stkimpl { + TestAccelDo struct::queue queimpl { + TestAccelDo struct::set setimpl { + TestAccelDo struct::graph impl { + source [localPath graph/tests/XOpsControl] + } + } + } + } +} + +#---------------------------------------------------------------------- +TestAccelExit struct::graph +TestAccelExit struct::set +TestAccelExit struct::queue +TestAccelExit struct::stack +TestAccelExit struct::tree +testsuiteCleanup diff --git a/tcllib/modules/struct/list.tcl b/tcllib/modules/struct/list.tcl new file mode 100644 index 0000000..a8fc094 --- /dev/null +++ b/tcllib/modules/struct/list.tcl @@ -0,0 +1,1828 @@ +#---------------------------------------------------------------------- +# +# list.tcl -- +# +# Definitions for extended processing of Tcl lists. +# +# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: list.tcl,v 1.27 2011/09/17 14:35:36 mic42 Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.4 +package require cmdline + +namespace eval ::struct { namespace eval list {} } + +namespace eval ::struct::list { + namespace export list + + if {0} { + # Possibly in the future. + namespace export Lassign + namespace export LdbJoin + namespace export LdbJoinOuter + namespace export Ldelete + namespace export Lequal + namespace export Lfilter + namespace export Lfilterfor + namespace export Lfirstperm + namespace export Lflatten + namespace export Lfold + namespace export Lforeachperm + namespace export Liota + namespace export LlcsInvert + namespace export LlcsInvert2 + namespace export LlcsInvertMerge + namespace export LlcsInvertMerge2 + namespace export LlongestCommonSubsequence + namespace export LlongestCommonSubsequence2 + namespace export Lmap + namespace export Lmapfor + namespace export Lnextperm + namespace export Lpermutations + namespace export Lrepeat + namespace export Lrepeatn + namespace export Lreverse + namespace export Lshift + namespace export Lswap + namespace export Lshuffle + } +} + +########################## +# Public functions + +# ::struct::list::list -- +# +# Command that access all list commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::list::list {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + set sub L$cmd + if { [llength [info commands ::struct::list::$sub]] == 0 } { + set optlist [info commands ::struct::list::L*] + set xlist {} + foreach p $optlist { + lappend xlist [string range $p 1 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::list::$sub]] +} + +########################## +# Private functions follow + +proc ::struct::list::K { x y } { set x } + +########################## +# Implementations of the functionality. +# + +# ::struct::list::LlongestCommonSubsequence -- +# +# Computes the longest common subsequence of two lists. +# +# Parameters: +# sequence1, sequence2 -- Two lists to compare. +# maxOccurs -- If provided, causes the procedure to ignore +# lines that appear more than $maxOccurs times +# in the second sequence. See below for a discussion. +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is the longest possible. +# +# Side effects: +# None. +# +# Notes: +# +# While this procedure is quite rapid for many tasks of file +# comparison, its performance degrades severely if the second list +# contains many equal elements (as, for instance, when using this +# procedure to compare two files, a quarter of whose lines are blank. +# This drawback is intrinsic to the algorithm used (see the References +# for details). One approach to dealing with this problem that is +# sometimes effective in practice is arbitrarily to exclude elements +# that appear more than a certain number of times. This number is +# provided as the 'maxOccurs' parameter. If frequent lines are +# excluded in this manner, they will not appear in the common subsequence +# that is computed; the result will be the longest common subsequence +# of infrequent elements. +# +# The procedure struct::list::LongestCommonSubsequence2 +# functions as a wrapper around this procedure; it computes the longest +# common subsequence of infrequent elements, and then subdivides the +# subsequences that lie between the matches to approximate the true +# longest common subsequence. +# +# References: +# J. W. Hunt and M. D. McIlroy, "An algorithm for differential +# file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone +# Laboratories (1976). Available on the Web at the second +# author's personal site: http://www.cs.dartmouth.edu/~doug/ + +proc ::struct::list::LlongestCommonSubsequence { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Construct a set of equivalence classes of lines in file 2 + + set index 0 + foreach string $sequence2 { + lappend eqv($string) $index + incr index + } + + # K holds descriptions of the common subsequences. + # Initially, there is one common subsequence of length 0, + # with a fence saying that it includes line -1 of both files. + # The maximum subsequence length is 0; position 0 of + # K holds a fence carrying the line following the end + # of both files. + + lappend K [::list -1 -1 {}] + lappend K [::list [llength $sequence1] [llength $sequence2] {}] + set k 0 + + # Walk through the first file, letting i be the index of the line and + # string be the line itself. + + set i 0 + foreach string $sequence1 { + # Consider each possible corresponding index j in the second file. + + if { [info exists eqv($string)] + && [llength $eqv($string)] <= $maxOccurs } { + + # c is the candidate match most recently found, and r is the + # length of the corresponding subsequence. + + set r 0 + set c [lindex $K 0] + + foreach j $eqv($string) { + # Perform a binary search to find a candidate common + # subsequence to which may be appended this match. + + set max $k + set min $r + set s [expr { $k + 1 }] + while { $max >= $min } { + set mid [expr { ( $max + $min ) / 2 }] + set bmid [lindex [lindex $K $mid] 1] + if { $j == $bmid } { + break + } elseif { $j < $bmid } { + set max [expr {$mid - 1}] + } else { + set s $mid + set min [expr { $mid + 1 }] + } + } + + # Go to the next match point if there is no suitable + # candidate. + + if { $j == [lindex [lindex $K $mid] 1] || $s > $k} { + continue + } + + # s is the sequence length of the longest sequence + # to which this match point may be appended. Make + # a new candidate match and store the old one in K + # Set r to the length of the new candidate match. + + set newc [::list $i $j [lindex $K $s]] + if { $r >= 0 } { + lset K $r $c + } + set c $newc + set r [expr { $s + 1 }] + + # If we've extended the length of the longest match, + # we're done; move the fence. + + if { $s >= $k } { + lappend K [lindex $K end] + incr k + break + } + } + + # Put the last candidate into the array + + lset K $r $c + } + + incr i + } + + # Package the common subsequence in a convenient form + + set seta {} + set setb {} + set q [lindex $K $k] + + for { set i 0 } { $i < $k } {incr i } { + lappend seta {} + lappend setb {} + } + while { [lindex $q 0] >= 0 } { + incr k -1 + lset seta $k [lindex $q 0] + lset setb $k [lindex $q 1] + set q [lindex $q 2] + } + + return [::list $seta $setb] +} + +# ::struct::list::LlongestCommonSubsequence2 -- +# +# Derives an approximation to the longest common subsequence +# of two lists. +# +# Parameters: +# sequence1, sequence2 - Lists to be compared +# maxOccurs - Parameter for imprecise matching - see below. +# +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is an approximation to the longest possible. +# +# Side effects: +# None. +# +# Notes: +# This procedure acts as a wrapper around the companion procedure +# struct::list::LongestCommonSubsequence and accepts the same +# parameters. It first computes the longest common subsequence of +# elements that occur no more than $maxOccurs times in the +# second list. Using that subsequence to align the two lists, +# it then tries to augment the subsequence by computing the true +# longest common subsequences of the sublists between matched pairs. + +proc ::struct::list::LlongestCommonSubsequence2 { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Derive the longest common subsequence of elements that occur at + # most $maxOccurs times + + foreach { l1 l2 } \ + [LlongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] { + break + } + + # Walk through the match points in the sequence just derived. + + set result1 {} + set result2 {} + set n1 0 + set n2 0 + foreach i1 $l1 i2 $l2 { + if { $i1 != $n1 && $i2 != $n2 } { + # The match points indicate that there are unmatched + # elements lying between them in both input sequences. + # Extract the unmatched elements and perform precise + # longest-common-subsequence analysis on them. + + set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]] + set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + # Add the current match point to the result + + lappend result1 $i1 + lappend result2 $i2 + set n1 [expr { $i1 + 1 }] + set n2 [expr { $i2 + 1 }] + } + + # If there are unmatched elements after the last match in both files, + # perform precise longest-common-subsequence matching on them and + # add the result to our return. + + if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } { + set subl1 [lrange $sequence1 $n1 end] + set subl2 [lrange $sequence2 $n2 end] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + return [::list $result1 $result2] +} + +# ::struct::list::LlcsInvert -- +# +# Takes the data describing a longest common subsequence of two +# lists and inverts the information in the sense that the result +# of this command will describe the differences between the two +# sequences instead of the identical parts. +# +# Parameters: +# lcsData longest common subsequence of two lists as +# returned by longestCommonSubsequence(2). +# Results: +# Returns a single list whose elements describe the differences +# between the original two sequences. Each element describes +# one difference through three pieces, the type of the change, +# a pair of indices in the first sequence and a pair of indices +# into the second sequence, in this order. +# +# Side effects: +# None. + +proc ::struct::list::LlcsInvert {lcsData len1 len2} { + return [LlcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvert2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (q), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +proc ::struct::list::LlcsInvertMerge {lcsData len1 len2} { + return [LlcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvertMerge2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. For merging we simply + # take the information from the input. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), add 'unchanged' chunk. + set type -- + foreach {type left right} [lindex $result end] break + if {[string match unchanged $type]} { + # There is an existing result to extend + lset left end $a + lset right end $b + lset result end [::list unchanged $left $right] + } else { + # There is an unchanged result at the start of the list; + # it may be extended. + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + } else { + if {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (a), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + # Finally, the two matching lines are a new unchanged region + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +# ::struct::list::Lreverse -- +# +# Reverses the contents of the list and returns the reversed +# list as the result of the command. +# +# Parameters: +# sequence List to be reversed. +# +# Results: +# The sequence in reverse. +# +# Side effects: +# None. + +proc ::struct::list::Lreverse {sequence} { + set l [::llength $sequence] + + # Shortcut for lists where reversing yields the list itself + if {$l < 2} {return $sequence} + + # Perform true reversal + set res [::list] + while {$l} { + ::lappend res [::lindex $sequence [incr l -1]] + } + return $res +} + + +# ::struct::list::Lassign -- +# +# Assign list elements to variables. +# +# Parameters: +# sequence List to assign +# args Names of the variables to assign to. +# +# Results: +# The unassigned part of the sequence. Can be empty. +# +# Side effects: +# None. + +# Do a compatibility version of [assign] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + # 8.4 + proc ::struct::list::Lassign {sequence v args} { + set args [linsert $args 0 $v] + set a [::llength $args] + + # Nothing to assign. + #if {$a == 0} {return $sequence} + + # Perform assignments + set i 0 + foreach v $args { + upvar 1 $v var + set var [::lindex $sequence $i] + incr i + } + + # Return remainder, if there is any. + return [::lrange $sequence $a end] +} + +} else { + # For 8.5+ simply redirect the method to the core command. + + interp alias {} ::struct::list::Lassign {} lassign +} + + +# ::struct::list::Lshift -- +# +# Shift a list in a variable one element down, and return first element +# +# Parameters: +# listvar Name of variable containing the list to shift. +# +# Results: +# The first element of the list. +# +# Side effects: +# After the call the list variable will contain +# the second to last elements of the list. + +proc ::struct::list::Lshift {listvar} { + upvar 1 $listvar list + set list [Lassign [K $list [set list {}]] v] + return $v +} + + +# ::struct::list::Lflatten -- +# +# Remove nesting from the input +# +# Parameters: +# sequence List to flatten +# +# Results: +# The input list with one or all levels of nesting removed. +# +# Side effects: +# None. + +proc ::struct::list::Lflatten {args} { + if {[::llength $args] < 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set full 0 + while {[string match -* [set opt [::lindex $args 0]]]} { + switch -glob -- $opt { + -full {set full 1} + -- {break} + default { + return -code error "Unknown option \"$opt\", should be either -full, or --" + } + } + set args [::lrange $args 1 end] + } + + if {[::llength $args] != 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set sequence [::lindex $args 0] + set cont 1 + while {$cont} { + set cont 0 + set result [::list] + foreach item $sequence { + # catch/llength detects if the item is following the list + # syntax. + + if {[catch {llength $item} len]} { + # Element is not a list in itself, no flatten, add it + # as is. + lappend result $item + } else { + # Element is parseable as list, add all sub-elements + # to the result. + foreach e $item { + lappend result $e + } + } + } + if {$full && [string compare $sequence $result]} {set cont 1} + set sequence $result + } + return $result +} + + +# ::struct::list::Lmap -- +# +# Apply command to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# List containing the result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lmap {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 [linsert $cmdprefix end $item]] + } + return $res +} + +# ::struct::list::Lmapfor -- +# +# Apply a script to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# script The script to run on the elements. +# +# Results: +# List containing the result of running script on the elements of the +# sequence. +# +# Side effects: +# None of its own, but the script can perform arbitry actions. + +proc ::struct::list::Lmapfor {var sequence script} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + upvar 1 $var item + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 $script] + } + return $res +} + +# ::struct::list::Lfilter -- +# +# Apply command to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test command. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilter {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + return [uplevel 1 [::list ::struct::list::Lfold $sequence {} [::list ::struct::list::FTest $cmdprefix]]] +} + +proc ::struct::list::FTest {cmdprefix result item} { + set pass [uplevel 1 [::linsert $cmdprefix end $item]] + if {$pass} {::lappend result $item} + return $result +} + +# ::struct::list::Lfilterfor -- +# +# Apply expr condition to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# expr Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test expression. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilterfor {var sequence expr} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + upvar 1 $var item + set result {} + foreach item $sequence { + if {[uplevel 1 [::list ::expr $expr]]} { + lappend result $item + } + } + return $result +} + +# ::struct::list::Lsplit -- +# +# Apply command to each element of a list and return elements passing +# and failing the test. Basic idea by Salvatore Sanfilippo +# (http://wiki.tcl.tk/lsplit). The implementation here is mine (AK), +# and the interface is slightly different (Command prefix with the +# list element given to it as argument vs. variable + script). +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# args = empty | (varPass varFail) +# +# Results: +# If the variables are specified then a list containing the +# numbers of passing and failing elements, in this +# order. Otherwise a list having two elements, the lists of +# passing and failing elements, in this order. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lsplit {sequence cmdprefix args} { + set largs [::llength $args] + if {$largs == 0} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return {{} {}}} + return [Lfold $sequence {} [::list ::struct::list::PFTest $cmdprefix]] + } elseif {$largs == 2} { + # Shortcut when nothing is to be done. + foreach {pv fv} $args break + upvar 1 $pv pass $fv fail + if {[::llength $sequence] == 0} { + set pass {} + set fail {} + return {0 0} + } + foreach {pass fail} [uplevel 1 [::list ::struct::list::Lfold $sequence {} [::list ::struct::list::PFTest $cmdprefix]]] break + return [::list [llength $pass] [llength $fail]] + } else { + return -code error \ + "wrong#args: should be \"::struct::list::Lsplit sequence cmdprefix ?passVar failVar?" + } +} + +proc ::struct::list::PFTest {cmdprefix result item} { + set passing [uplevel 1 [::linsert $cmdprefix end $item]] + set pass {} ; set fail {} + foreach {pass fail} $result break + if {$passing} { + ::lappend pass $item + } else { + ::lappend fail $item + } + return [::list $pass $fail] +} + +# ::struct::list::Lfold -- +# +# Fold list into one value. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# Result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lfold {sequence initialvalue cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $initialvalue} + + set res $initialvalue + foreach item $sequence { + set res [uplevel 1 [linsert $cmdprefix end $res $item]] + } + return $res +} + +# ::struct::list::Liota -- +# +# Return a list containing the integer numbers 0 ... n-1 +# +# Parameters: +# n First number not in the generated list. +# +# Results: +# A list containing integer numbers. +# +# Side effects: +# None + +proc ::struct::list::Liota {n} { + set retval [::list] + for {set i 0} {$i < $n} {incr i} { + ::lappend retval $i + } + return $retval +} + +# ::struct::list::Ldelete -- +# +# Delete an element from a list by name. +# Similar to 'struct::set exclude', however +# this here preserves order and list intrep. +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are delete. +# +# Side effects: +# None + +proc ::struct::list::Ldelete {var item} { + upvar 1 $var list + set pos [lsearch -exact $list $item] + if {$pos < 0} return + set list [lreplace [K $list [set list {}]] $pos $pos] + return +} + +# ::struct::list::Lequal -- +# +# Compares two lists for equality +# (Same length, Same elements in same order). +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None + +proc ::struct::list::Lequal {a b} { + # Author of this command is "Richard Suchenwirth" + + if {[::llength $a] != [::llength $b]} {return 0} + if {[::lindex $a 0] == $a && [::lindex $b 0] == $b} {return [string equal $a $b]} + foreach i $a j $b {if {![Lequal $i $j]} {return 0}} + return 1 +} + +# ::struct::list::Lrepeatn -- +# +# Create a list repeating the same value over again. +# +# Parameters: +# value value to use in the created list. +# args Dimension(s) of the (nested) list to create. +# +# Results: +# A list +# +# Side effects: +# None + +proc ::struct::list::Lrepeatn {value args} { + if {[::llength $args] == 1} {set args [::lindex $args 0]} + set buf {} + foreach number $args { + incr number 0 ;# force integer (1) + set buf {} + for {set i 0} {$i<$number} {incr i} { + ::lappend buf $value + } + set value $buf + } + return $buf + # (1): See 'Stress testing' (wiki) for why this makes the code safer. +} + +# ::struct::list::Lrepeat -- +# +# Create a list repeating the same value over again. +# [Identical to the Tcl 8.5 lrepeat command] +# +# Parameters: +# n Number of replications. +# args values to use in the created list. +# +# Results: +# A list +# +# Side effects: +# None + +# Do a compatibility version of [repeat] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + + proc ::struct::list::Lrepeat {positiveCount value args} { + if {![string is integer -strict $positiveCount]} { + return -code error "expected integer but got \"$positiveCount\"" + } elseif {$positiveCount < 1} { + return -code error {must have a count of at least 1} + } + + set args [linsert $args 0 $value] + + if {$positiveCount == 1} { + # Tcl itself has already listified the incoming parameters + # via 'args'. + return $args + } + + set result [::list] + while {$positiveCount > 0} { + if {($positiveCount % 2) == 0} { + set args [concat $args $args] + set positiveCount [expr {$positiveCount/2}] + } else { + set result [concat $result $args] + incr positiveCount -1 + } + } + return $result + } + +} else { + # For 8.5 simply redirect the method to the core command. + + interp alias {} ::struct::list::Lrepeat {} lrepeat +} + +# ::struct::list::LdbJoin(Keyed) -- +# +# Relational table joins. +# +# Parameters: +# args key specs and tables to join +# +# Results: +# A table/matrix as nested list. See +# struct/matrix set/get rect for structure. +# +# Side effects: +# None + +proc ::struct::list::LdbJoin {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? ?-keys varname? \{key table\}..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + if {([llength $args] % 2) != 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? \{key table\}..." + } + + # One table only, join is identity + if {[llength $args] == 2} {return [lindex $args 1]} + + # Use first table for setup. + + foreach {key table} $args break + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitMap state width $key $table] + + # Extend state with the remaining tables. + + foreach {key table} [lrange $args 2 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapExtendInner state $key $table]} + left {set keylist [MapExtendLeftOuter state width $key $table]} + right {set keylist [MapExtendRightOuter state width $key $table]} + full {set keylist [MapExtendFullOuter state width $key $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +proc ::struct::list::LdbJoinKeyed {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? table..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + # One table only, join is identity + if {[llength $args] == 1} { + return [Dekey [lindex $args 0]] + } + + # Use first table for setup. + + set table [lindex $args 0] + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitKeyedMap state width $table] + + # Extend state with the remaining tables. + + foreach table [lrange $args 1 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapKeyedExtendInner state $table]} + left {set keylist [MapKeyedExtendLeftOuter state width $table]} + right {set keylist [MapKeyedExtendRightOuter state width $table]} + full {set keylist [MapKeyedExtendFullOuter state width $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +## Helpers for the relational joins. +## Map is an array mapping from keys to a list +## of rows with that key + +proc ::struct::list::Cartesian {leftmap rightmap key} { + upvar $leftmap left $rightmap right + set joined [::list] + foreach lrow $left($key) { + foreach row $right($key) { + lappend joined [concat $lrow $row] + } + } + set left($key) $joined + return +} + +proc ::struct::list::SingleRightCartesian {mapvar key rightrow} { + upvar $mapvar map + set joined [::list] + foreach lrow $map($key) { + lappend joined [concat $lrow $rightrow] + } + set map($key) $joined + return +} + +proc ::struct::list::MapToTable {mapvar keys} { + # Note: keys must not appear multiple times in the list. + + upvar $mapvar map + set table [::list] + foreach k $keys { + foreach row $map($k) {lappend table $row} + } + return $table +} + +## More helpers, core join operations: Init, Extend. + +proc ::struct::list::InitMap {mapvar wvar key table} { + upvar $mapvar map $wvar width + set width [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + lappend map($keyval) $row + } else { + set map($keyval) [::list $row] + } + } + return [array names map] +} + +proc ::struct::list::MapExtendInner {mapvar key table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + return [array names map] +} + +proc ::struct::list::MapExtendRightOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendLeftOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendFullOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + lappend keylist $keyval + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +## Keyed helpers + +proc ::struct::list::InitKeyedMap {mapvar wvar table} { + upvar $mapvar map $wvar width + set width [llength [lindex [lindex $table 0] 1]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + lappend map($keyval) $rowdata + } else { + set map($keyval) [::list $rowdata] + } + } + return [array names map] +} + +proc ::struct::list::MapKeyedExtendInner {mapvar table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + + return [array names map] +} + +proc ::struct::list::MapKeyedExtendRightOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendLeftOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendFullOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + lappend keylist $keyval + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::Dekey {keyedtable} { + set table [::list] + foreach row $keyedtable {lappend table [lindex $row 1]} + return $table +} + +# ::struct::list::Lswap -- +# +# Exchange two elements of a list. +# +# Parameters: +# listvar Name of the variable containing the list to manipulate. +# i, j Indices of the list elements to exchange. +# +# Results: +# The modified list +# +# Side effects: +# None + +proc ::struct::list::Lswap {listvar i j} { + upvar $listvar list + + if {($i < 0) || ($j < 0)} { + return -code error {list index out of range} + } + set len [llength $list] + if {($i >= $len) || ($j >= $len)} { + return -code error {list index out of range} + } + + if {$i != $j} { + set tmp [lindex $list $i] + lset list $i [lindex $list $j] + lset list $j $tmp + } + return $list +} + +# ::struct::list::Lfirstperm -- +# +# Returns the lexicographically first permutation of the +# specified list. +# +# Parameters: +# list The list whose first permutation is sought. +# +# Results: +# A modified list containing the lexicographically first +# permutation of the input. +# +# Side effects: +# None + +proc ::struct::list::Lfirstperm {list} { + return [lsort $list] +} + +# ::struct::list::Lnextperm -- +# +# Accepts a permutation of a set of elements and returns the +# next permutatation in lexicographic sequence. +# +# Parameters: +# list The list containing the current permutation. +# +# Results: +# A modified list containing the lexicographically next +# permutation after the input permutation. +# +# Side effects: +# None + +proc ::struct::list::Lnextperm {perm} { + # Find the smallest subscript j such that we have already visited + # all permutations beginning with the first j elements. + + set len [expr {[llength $perm] - 1}] + + set j $len + set ajp1 [lindex $perm $j] + while { $j > 0 } { + incr j -1 + set aj [lindex $perm $j] + if { [string compare $ajp1 $aj] > 0 } { + set foundj {} + break + } + set ajp1 $aj + } + if { ![info exists foundj] } return + + # Find the smallest element greater than the j'th among the elements + # following aj. Let its index be l, and interchange aj and al. + + set l $len + while { [string compare $aj [set al [lindex $perm $l]]] >= 0 } { + incr l -1 + } + lset perm $j $al + lset perm $l $aj + + # Reverse a_j+1 ... an + + set k [expr {$j + 1}] + set l $len + while { $k < $l } { + set al [lindex $perm $l] + lset perm $l [lindex $perm $k] + lset perm $k $al + incr k + incr l -1 + } + + return $perm +} + +# ::struct::list::Lpermutations -- +# +# Returns a list containing all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# list The list whose permutations are sought. +# +# Results: +# A list of lists, containing all permutations of the +# input. +# +# Side effects: +# None + +proc ::struct::list::Lpermutations {list} { + + if {[llength $list] < 2} { + return [::list $list] + } + + set res {} + set p [Lfirstperm $list] + while {[llength $p]} { + lappend res $p + set p [Lnextperm $p] + } + return $res +} + +# ::struct::list::Lforeachperm -- +# +# Executes a script for all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# var Name of the loop variable. +# list The list whose permutations are sought. +# body The tcl script to run per permutation of +# the input. +# +# Results: +# The empty string. +# +# Side effects: +# None + +proc ::struct::list::Lforeachperm {var list body} { + upvar $var loopvar + + if {[llength $list] < 2} { + set loopvar $list + # TODO run body. + + # The first invocation of the body, also the last, as only one + # permutation is possible. That makes handling of the result + # codes easier. + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 {} + 4 {} + default { + # Includes code 2 + return -code $code $result + } + } + return + } + + set p [Lfirstperm $list] + while {[llength $p]} { + set loopvar $p + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + set p [Lnextperm $p] + } + return +} + +proc ::struct::list::Lshuffle {list} { + for {set i [llength $list]} {$i > 1} {lset list $j $t} { + set j [expr {int(rand() * $i)}] + set t [lindex $list [incr i -1]] + lset list $i [lindex $list $j] + } + return $list +} + +# ### ### ### ######### ######### ######### + +proc ::struct::list::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'list::list' into the general structure namespace. + namespace import -force list::list + namespace export list +} +package provide struct::list 1.8.3 diff --git a/tcllib/modules/struct/list.test b/tcllib/modules/struct/list.test new file mode 100644 index 0000000..bd1574c --- /dev/null +++ b/tcllib/modules/struct/list.test @@ -0,0 +1,1311 @@ +# Tests for the 'list' module in the 'struct' library. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcllib +# procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# +# RCS: @(#) $Id: list.test,v 1.32 2011/09/17 14:35:36 mic42 Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 2.0 + +testing { + useLocal list.tcl struct::list +} + +# ------------------------------------------------------------------------- + +interp alias {} lcs {} ::struct::list::list longestCommonSubsequence + +test list-lcs-1.1 {longestCommonSubsequence, no args} { + catch { lcs } msg + set msg +} [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 0] + +test list-lcs-1.2 {longestCommonSubsequence, one arg} { + catch { lcs x } msg + set msg +} [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 1] + +test list-lcs-2.1 {longestCommonSubsequence, two empty lists} { + list [catch { lcs {} {} } msg] $msg +} {0 {{} {}}} + +test list-lcs-2.2 {longestCommonSubsequence, insert 1 into an empty list} { + list [catch { lcs {} {a} } msg] $msg +} {0 {{} {}}} + +test list-lcs-2.3 {longestCommonSubsequence, delete 1 from singleton list} { + list [catch { lcs {a} {} } msg] $msg +} {0 {{} {}}} + +test list-lcs-2.4 {longestCommonSubsequence, preserve singleton list} { + list [catch { lcs {a} {a} } msg] $msg +} {0 {0 0}} + +test list-lcs-2.5 {longestCommonSubsequence, 1-element change in singleton list} { + list [catch { lcs {a} {b} } msg] $msg +} {0 {{} {}}} + +test list-lcs-2.6 {longestCommonSubsequence, insert 1 in front of singleton list} { + list [catch { lcs {a} {b a} } msg] $msg +} {0 {0 1}} + +test list-lcs-2.7 {longestCommonSubsequence, insert 1 at end of singleton list} { + list [catch {lcs {a} {a b}} msg] $msg +} {0 {0 0}} + +test list-lcs-2.8 {longestCommonSubsequence, duplicate element} { + list [catch {lcs {a} {a a}} msg] $msg +} {0 {0 0}} + +test list-lcs-2.9 {longestCommonSubsequence, interchange 2} { + list [catch {lcs {a b} {b a}} msg] $msg +} {0 {1 0}} + +test list-lcs-2.10 {longestCommonSubsequence, insert before 2} { + list [catch {lcs {a b} {b a b}} msg] $msg +} {0 {{0 1} {1 2}}} + +test list-lcs-2.11 {longestCommonSubsequence, insert inside 2} { + list [catch {lcs {a b} {a a b}} msg] $msg +} {0 {{0 1} {0 2}}} + +test list-lcs-2.12 {longestCommonSubsequence, insert after 2} { + list [catch {lcs {a b} {a b a}} msg] $msg +} {0 {{0 1} {0 1}}} + +test list-lcs-2.13 {longestCommonSubsequence, delete first of 2} { + list [catch {lcs {a b} a} msg] $msg +} {0 {0 0}} + +test list-lcs-2.14 {longestCommonSubsequence, delete second of 2} { + list [catch {lcs {a b} b} msg] $msg +} {0 {1 0}} + +test list-lcs-2.15 {longestCommonSubsequence, change first of 2} { + list [catch {lcs {a b} {c b}} msg] $msg +} {0 {1 1}} + +test list-lcs-2.16 {longestCommonSubsequence, change first of 2 to dupe} { + list [catch {lcs {a b} {b b}} msg] $msg +} {0 {1 0}} + +test list-lcs-2.17 {longestCommonSubsequence, change second of 2} { + list [catch {lcs {a b} {a c}} msg] $msg +} {0 {0 0}} + +test list-lcs-2.18 {longestCommonSubsequence, change second of 2 to dupe} { + list [catch {lcs {a b} {a a}} msg] $msg +} {0 {0 0}} + +test list-lcs-2.19 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg +} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + +test list-lcs-2.20 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs-3.1 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs-3.2 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg +} {0 {{0 1 3 5 6} {1 2 4 8 9}}} + +test list-lcs-3.3 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg +} {0 {3 4}} + +test list-lcs-3.4 {longestCommonSubsequence, stupid length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg +} {0 {{} {}}} + + +#---------------------------------------------------------------------- + +interp alias {} lcs2 {} ::struct::list::list longestCommonSubsequence2 + +test list-lcs2-1.1 {longestCommonSubsequence2, no args} { + catch { lcs2 } msg + set msg +} [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 0] + +test list-lcs2-1.2 {longestCommonSubsequence2, one arg} { + catch { lcs2 x } msg + set msg +} [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 1] + +test list-lcs2-2.1 {longestCommonSubsequence2, two empty lists} { + list [catch { lcs2 {} {} } msg] $msg +} {0 {{} {}}} + +test list-lcs2-2.2 {longestCommonSubsequence2, insert 1 into an empty list} { + list [catch { lcs2 {} {a} } msg] $msg +} {0 {{} {}}} + +test list-lcs2-2.3 {longestCommonSubsequence2, delete 1 from singleton list} { + list [catch { lcs2 {a} {} } msg] $msg +} {0 {{} {}}} + +test list-lcs2-2.4 {longestCommonSubsequence2, preserve singleton list} { + list [catch { lcs2 {a} {a} } msg] $msg +} {0 {0 0}} + +test list-lcs2-2.5 {longestCommonSubsequence2, 1-element change in singleton list} { + list [catch { lcs2 {a} {b} } msg] $msg +} {0 {{} {}}} + +test list-lcs2-2.6 {longestCommonSubsequence2, insert 1 in front of singleton list} { + list [catch { lcs2 {a} {b a} } msg] $msg +} {0 {0 1}} + +test list-lcs2-2.7 {longestCommonSubsequence2, insert 1 at end of singleton list} { + list [catch {lcs2 {a} {a b}} msg] $msg +} {0 {0 0}} + +test list-lcs2-2.8 {longestCommonSubsequence2, duplicate element} { + list [catch {lcs2 {a} {a a}} msg] $msg +} {0 {0 0}} + +test list-lcs2-2.9 {longestCommonSubsequence2, interchange 2} { + list [catch {lcs2 {a b} {b a}} msg] $msg +} {0 {1 0}} + +test list-lcs2-2.10 {longestCommonSubsequence2, insert before 2} { + list [catch {lcs2 {a b} {b a b}} msg] $msg +} {0 {{0 1} {1 2}}} + +test list-lcs2-2.11 {longestCommonSubsequence2, insert inside 2} { + list [catch {lcs2 {a b} {a a b}} msg] $msg +} {0 {{0 1} {0 2}}} + +test list-lcs2-2.12 {longestCommonSubsequence2, insert after 2} { + list [catch {lcs2 {a b} {a b a}} msg] $msg +} {0 {{0 1} {0 1}}} + +test list-lcs2-2.13 {longestCommonSubsequence2, delete first of 2} { + list [catch {lcs2 {a b} a} msg] $msg +} {0 {0 0}} + +test list-lcs2-2.14 {longestCommonSubsequence2, delete second of 2} { + list [catch {lcs2 {a b} b} msg] $msg +} {0 {1 0}} + +test list-lcs2-2.15 {longestCommonSubsequence2, change first of 2} { + list [catch {lcs2 {a b} {c b}} msg] $msg +} {0 {1 1}} + +test list-lcs2-2.16 {longestCommonSubsequence2, change first of 2 to dupe} { + list [catch {lcs2 {a b} {b b}} msg] $msg +} {0 {1 0}} + +test list-lcs2-2.17 {longestCommonSubsequence2, change second of 2} { + list [catch {lcs2 {a b} {a c}} msg] $msg +} {0 {0 0}} + +test list-lcs2-2.18 {longestCommonSubsequence2, change second of 2 to dupe} { + list [catch {lcs2 {a b} {a a}} msg] $msg +} {0 {0 0}} + +test list-lcs2-2.19 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg +} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + +test list-lcs2-2.20 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs2-3.1 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs2-3.2 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs2-3.3 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + +test list-lcs2-3.4 {longestCommonSubsequence2, stupid length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg +} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + +#---------------------------------------------------------------------- + +interp alias {} lcsi {} ::struct::list::list lcsInvert +interp alias {} lcsim {} ::struct::list::list lcsInvertMerge + +test list-lcsInv-4.0 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion = deleted {0 0} {-1 0} + # changed {3 3} {2 2} + # deleted {6 7} {4 5} + # added {10 11} {8 8} + + list [catch {lcsi [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg +} {0 {{deleted {0 0} {-1 0}} {changed {3 3} {2 2}} {deleted {6 7} {4 5}} {added {10 11} {8 8}}}} + +test list-lcsInv-4.1 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion/Merge = deleted {0 0} {-1 0} + # unchanged {1 2} {0 1} + # changed {3 3} {2 2} + # unchanged {4 5} {3 4} + # deleted {6 7} {4 5} + # unchanged {8 10} {5 7} + # added {10 11} {8 8} + + list [catch {lcsim [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg +} {0 {{deleted {0 0} {-1 0}} {unchanged {1 2} {0 1}} {changed {3 3} {2 2}} {unchanged {4 5} {3 4}} {deleted {6 7} {4 5}} {unchanged {8 10} {5 7}} {added {10 11} {8 8}}}} + + +proc diff2 {s1 s2} { + set l1 [split $s1 {}] + set l2 [split $s2 {}] + set x [lcs $l1 $l2] + lcsim $x [llength $l1] [llength $l2] +} +test list-lcsInv-4.2 {lcsInvertMerge} { + # Handling of 'unchanged' chunks at the beginning of the result + # (when result actually empty). + + diff2 ab "a b" +} {{unchanged {0 0} {0 0}} {added {0 1} {1 1}} {unchanged {1 1} {2 2}}} + +test list-lcsInv-4.3 {lcsInvertMerge} { + diff2 abcde afcge +} {{unchanged {0 0} {0 0}} {changed {1 1} {1 1}} {unchanged {2 2} {2 2}} {changed {3 3} {3 3}} {unchanged {4 4} {4 4}}} + +#---------------------------------------------------------------------- + +interp alias {} reverse {} ::struct::list::list reverse + +test reverse-1.1 {reverse method} { + reverse {a b c} +} {c b a} + +test reverse-1.2 {reverse method} { + reverse a +} {a} + +test reverse-1.3 {reverse method} { + reverse {} +} {} + +test reverse-2.1 {reverse errors} { + list [catch {reverse} msg] $msg +} [list 1 [tcltest::wrongNumArgs ::struct::list::Lreverse {sequence} 0]] + +#---------------------------------------------------------------------- + +interp alias {} assign {} ::struct::list::list assign + +test assign-4.1 {assign method} { + catch {unset ::x ::y} + list [assign {foo bar} x y] $x $y +} {{} foo bar} + +test assign-4.2 {assign method} { + catch {unset x y} + list [assign {foo bar baz} x y] $x $y +} {baz foo bar} + +test assign-4.3 {assign method} { + catch {unset x y z} + list [assign {foo bar} x y z] $x $y $z +} {{} foo bar {}} + +if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {sequence v args} 1] +} else { + # 8.5+ + #set err [tcltest::wrongNumArgs {lassign} {list varName ?varName ...?} 1] + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {list varName ?varName ...?} 1] +} + +# In 8.6+ assign is the native lassign and it does nothing gracefully, +# per TIP 323, making assign-4.4 not an error anymore. +test assign-4.4 {assign method} {!tcl8.6plus} { + catch {assign {foo bar}} msg ; set msg +} $err + +test assign-4.5 {assign method} { + list [assign {foo bar} x] $x +} {bar foo} + +catch {unset x y z} + +#---------------------------------------------------------------------- + +interp alias {} flatten {} ::struct::list::list flatten + +test flatten-1.1 {flatten command} { + flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} +} {1 2 3 4 5 6 7 {8 9} 10} + +test flatten-1.2 {flatten command} { + flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} +} {1 2 3 4 5 6 7 8 9 10} + +test flatten-1.3 {flatten command} { + flatten {a b} +} {a b} + +test flatten-1.4 {flatten command} { + flatten [list "\[a\]" "\[b\]"] +} {{[a]} {[b]}} + +test flatten-1.5 {flatten command} { + flatten [list "'" "\""] +} {' {"}} ; # " help emacs highlighting + +test flatten-1.6 {flatten command} { + flatten [list "{" "}"] +} "\\\{ \\\}" + +test flatten-2.1 {flatten errors} { + list [catch {flatten} msg] $msg +} {1 {wrong#args: should be "::struct::list::Lflatten ?-full? ?--? sequence"}} + +test flatten-2.2 {flatten errors} { + list [catch {flatten -all {a {b c d} {e {f g}}}} msg] $msg +} {1 {Unknown option "-all", should be either -full, or --}} + + +#---------------------------------------------------------------------- + +interp alias {} map {} ::struct::list::list map + +proc cc {a} {return $a$a} +proc + {a} {expr {$a + $a}} +proc * {a} {expr {$a * $a}} +proc projection {n list} {::lindex $list $n} + +test map-4.1 {map command} { + map {a b c d} cc +} {aa bb cc dd} + +test map-4.2 {map command} { + map {1 2 3 4 5} + +} {2 4 6 8 10} + +test map-4.3 {map command} { + map {1 2 3 4 5} * +} {1 4 9 16 25} + +test map-4.4 {map command} { + map {} * +} {} + +test map-4.5 {map command} { + map {{a b c} {1 2 3} {d f g}} {projection 1} +} {b 2 f} + + +#---------------------------------------------------------------------- + +interp alias {} mapfor {} ::struct::list::list mapfor + +test mapfor-4.1 {mapfor command} { + mapfor x {a b c d} { set x $x$x } +} {aa bb cc dd} + +test mapfor-4.2 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x + $x}} +} {2 4 6 8 10} + +test mapfor-4.3 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x * $x}} +} {1 4 9 16 25} + +test mapfor-4.4 {mapfor command} { + mapfor x {} {expr {$x * $x}} +} {} + +test mapfor-4.5 {mapfor command} { + mapfor x {{a b c} {1 2 3} {d f g}} {lindex $x 1} +} {b 2 f} + +#---------------------------------------------------------------------- + +interp alias {} fold {} ::struct::list::list fold + +proc cc {a b} {return $a$b} +proc + {a b} {expr {$a + $b}} +proc * {a b} {expr {$a * $b}} + +test fold-4.1 {fold command} { + fold {a b c d} {} cc +} {abcd} + +test fold-4.2 {fold command} { + fold {1 2 3 4 5} 0 + +} {15} + +test fold-4.3 {fold command} { + fold {1 2 3 4 5} 1 * +} {120} + +test fold-4.4 {fold command} { + fold {} 1 * +} {1} + +#---------------------------------------------------------------------- + +interp alias {} filter {} ::struct::list::list filter + +proc even {i} {expr {($i % 2) == 0}} + +test filter-4.1 {filter command} { + filter {1 2 3 4 5 6 7 8} even +} {2 4 6 8} + +test filter-4.2 {filter command} { + filter {} even +} {} + +test filter-4.3 {filter command} { + filter {3 5 7} even +} {} + +test filter-4.4 {filter command} { + filter {2 4 6} even +} {2 4 6} + +# Alternate which elements are filtered by using a global variable +# flag. Used to test that the `cmdprefix' is evaluated in the caller's +# scope. +# +# The flag variable should be set on the -setup phase. + +proc alternating {_} { + upvar 1 flag flag; + set flag [expr {!($flag)}]; + return $flag; +} + +test filter-4.5 {filter evaluates cmdprefix on outer scope} -setup { + set flag 1 +} -body { + filter {1 2 3 4 5 6} alternating +} -cleanup { + unset flag +} -result {2 4 6} + +#---------------------------------------------------------------------- + +interp alias {} filterfor {} ::struct::list::list filterfor + +test filterfor-4.1 {filterfor command} { + filterfor i {1 2 3 4 5 6 7 8} {($i % 2) == 0} +} {2 4 6 8} + +test filterfor-4.2 {filterfor command} { + filterfor i {} {($i % 2) == 0} +} {} + +test filterfor-4.3 {filterfor command} { + filterfor i {3 5 7} {($i % 2) == 0} +} {} + +test filterfor-4.4 {filterfor command} { + filterfor i {2 4 6} {($i % 2) == 0} +} {2 4 6} + +#---------------------------------------------------------------------- + +interp alias {} lsplit {} ::struct::list::list split + +proc even {i} {expr {($i % 2) == 0}} + +test split-4.1 {split command} { + lsplit {1 2 3 4 5 6 7 8} even +} {{2 4 6 8} {1 3 5 7}} + +test split-4.2 {split command} { + lsplit {} even +} {{} {}} + +test split-4.3 {split command} { + lsplit {3 5 7} even +} {{} {3 5 7}} + +test split-4.4 {split command} { + lsplit {2 4 6} even +} {{2 4 6} {}} + +test split-4.5 {split command} { + list [lsplit {1 2 3 4 5 6 7 8} even pass fail] $pass $fail +} {{4 4} {2 4 6 8} {1 3 5 7}} + +test split-4.6 {split command} { + list [lsplit {} even pass fail] $pass $fail +} {{0 0} {} {}} + +test split-4.7 {split command} { + list [lsplit {3 5 7} even pass fail] $pass $fail +} {{0 3} {} {3 5 7}} + +test split-4.8 {split command} { + list [lsplit {2 4 6} even pass fail] $pass $fail +} {{3 0} {2 4 6} {}} + + +# See test filter-4.5 for explanations. + +test split-4.9 {split evaluates cmdprefix on outer scope} -setup { + set flag 1 +} -body { + list [lsplit {1 2 3 4 5 6 7 8} alternating pass fail] $pass $fail +} -cleanup { + unset flag +} -result {{4 4} {2 4 6 8} {1 3 5 7}} + +#---------------------------------------------------------------------- + +interp alias {} shift {} ::struct::list::list shift + +test shift-4.1 {shift command} { + set v {1 2 3 4 5 6 7 8} + list [shift v] $v +} {1 {2 3 4 5 6 7 8}} + +test shift-4.2 {shift command} { + set v {1} + list [shift v] $v +} {1 {}} + +test shift-4.3 {shift command} { + set v {} + list [shift v] $v +} {{} {}} + +#---------------------------------------------------------------------- + +interp alias {} iota {} ::struct::list::list iota + +test iota-4.1 {iota command} { + iota 0 +} {} + +test iota-4.2 {iota command} { + iota 1 +} {0} + +test iota-4.3 {iota command} { + iota 11 +} {0 1 2 3 4 5 6 7 8 9 10} + + +#---------------------------------------------------------------------- + +interp alias {} repeatn {} ::struct::list::list repeatn + +test repeatn-4.1 {repeatn command} { + repeatn 0 +} {} + +test repeatn-4.2 {repeatn command} { + repeatn 0 3 +} {0 0 0} + +test repeatn-4.3 {repeatn command} { + repeatn 0 3 4 +} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + +test repeatn-4.4 {repeatn command} { + repeatn 0 {3 4} +} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + +#---------------------------------------------------------------------- + +interp alias {} repeat {} ::struct::list::list repeat + +if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 0] +} elseif {![package vsatisfies [package provide Tcl] 8.6]} { + # 8.5+ + #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 0] + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 0] +} else { + # 8.6+ + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] +} +test repeat-4.1 {repeat command} { + catch {repeat} msg + set msg +} $err + + +if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value args} 1] +} elseif {![package vsatisfies [package provide Tcl] 8.6]} { + # 8.5+ + #set err [tcltest::wrongNumArgs {lrepeat} {positiveCount value ?value ...?} 1] + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 1] +} else { + # 8.6+ + set err [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] +} +# In 8.6+ repeat is the native lrepeat and it does nothing gracefully, +# per TIP 323, making repeat-4.2 not an error anymore. +test repeat-4.2 {repeat command} {!tcl8.6plus} { + catch {repeat a} msg + set msg +} $err + +test repeat-4.3 {repeat command} { + catch {repeat a b} msg + set msg +} {expected integer but got "a"} + +# In 8.6+ repeat is the native lrepeat and it does nothing gracefully, +# per TIP 323, making repeat-4.2 not an error anymore. +test repeat-4.4 {repeat command} {!tcl8.6plus} { + catch {repeat 0 b} msg + set msg +} {must have a count of at least 1} + +if {![package vsatisfies [package provide Tcl] 8.6]} { + # before 8.6 + set err {must have a count of at least 1} +} else { + # 8.6+, native lrepeat changed error message. + set err {bad count "-1": must be integer >= 0} +} +test repeat-4.5 {repeat command} { + catch {repeat -1 b} msg + set msg +} $err + +test repeat-4.6 {repeat command} { + repeat 1 b c +} {b c} + +test repeat-4.7 {repeat command} { + repeat 3 a +} {a a a} + +test repeat-4.8 {repeat command} { + repeat 3 [repeat 3 0] +} {{0 0 0} {0 0 0} {0 0 0}} + +test repeat-4.9 {repeat command} { + repeat 3 a b c +} {a b c a b c a b c} + +test repeat-4.10 {repeat command} { + repeat 3 [repeat 2 a] b c +} {{a a} b c {a a} b c {a a} b c} + +#---------------------------------------------------------------------- + +interp alias {} equal {} ::struct::list::list equal + +test equal-4.1 {equal command} { + equal 0 0 +} 1 + +test equal-4.2 {equal command} { + equal 0 1 +} 0 + +test equal-4.3 {equal command} { + equal {0 0 0} {0 0} +} 0 + +test equal-4.4 {equal command} { + equal {{0 2 3} 1} {{0 2 3} 1} +} 1 + +test equal-4.5 {equal command} { + equal [list [list a]] {{a}} +} 1 + +test equal-4.6 {equal command} { + equal {{a}} [list [list a]] +} 1 + +test equal-4.7 {equal command} { + set a {{a}} + set b [list [list a]] + expr {[equal $a $b] == [equal $b $a]} +} 1 + +test equal-4.8 {equal command} { + set a {{a b}} + set b [list [list a b]] + expr {[equal $a $b] == [equal $b $a]} +} 1 + +test equal-4.9 {equal command} { + set a {{a} {b}} + set b [list [list a] [list b]] + expr {[equal $a $b] == [equal $b $a]} +} 1 + +#---------------------------------------------------------------------- + +interp alias {} delete {} ::struct::list::list delete + +test delete-1.0 {delete command} { + catch {delete} msg + set msg +} {wrong # args: should be "::struct::list::Ldelete var item"} + +test delete-1.1 {delete command} { + catch {delete x} msg + set msg +} {wrong # args: should be "::struct::list::Ldelete var item"} + +test delete-1.2 {delete command} { + set l {} + delete l x + set l +} {} + +test delete-1.3 {delete command} { + set l {a x b} + delete l x + set l +} {a b} + +test delete-1.4 {delete command} { + set l {x a b} + delete l x + set l +} {a b} + +test delete-1.5 {delete command} { + set l {a b x} + delete l x + set l +} {a b} + +test delete-1.6 {delete command} { + set l {a b} + delete l x + set l +} {a b} + +catch { unset l } +#---------------------------------------------------------------------- + +interp alias {} dbjoin {} ::struct::list::list dbJoin +interp alias {} dbjoink {} ::struct::list::list dbJoinKeyed + +#---------------------------------------------------------------------- +# Input data sets ... + +set empty {} +set table_as [list \ + {0 foo} \ + {1 snarf} \ + {2 blue} \ + ] +set table_am [list \ + {0 foo} \ + {0 bar} \ + {1 snarf} \ + {1 rim} \ + {2 blue} \ + {2 dog} \ + ] +set table_bs [list \ + {0 bagel} \ + {1 snatz} \ + {3 driver} \ + ] +set table_bm [list \ + {0 bagel} \ + {0 loaf} \ + {1 snatz} \ + {1 grid} \ + {3 driver} \ + {3 tcl} \ + ] +set table_cs [list \ + {0 smurf} \ + {3 bird} \ + {4 galapagos} \ + ] +set table_cm [list \ + {0 smurf} \ + {0 blt} \ + {3 bird} \ + {3 itcl} \ + {4 galapagos} \ + {4 tk} \ + ] + +#---------------------------------------------------------------------- +# Result data sets ... + +set nyi __not_yet_written__ + +set ijss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + ] +set ijsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + ] +set ijms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + ] +set ijmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + ] + +set ljss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + ] +set ljsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + ] +set ljms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] +set ljmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] + +set rjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list {} {} 3 driver] \ + ] +set rjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] +set rjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list {} {} 3 driver] \ + ] +set rjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + +set fjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + ] +set fjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] +set fjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + ] +set fjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + +set ijmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} +} +set ljmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} +} +set rjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} +} +set fjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} +} + +#---------------------------------------------------------------------- +# Helper, translation to keyed format. + +proc keyed {table} { + # Get the key out of the row, hardwired to column 0 + set res [list] + foreach row $table {lappend res [list [lindex $row 0] $row]} + return $res +} + +#---------------------------------------------------------------------- +# I. One table joins + +set n 0 ; # Counter for test cases +foreach {jtype inout} { + -inner empty -inner table_as -inner table_am + -left empty -left table_as -left table_am + -right empty -right table_as -right table_am + -full empty -full table_as -full table_am +} { + test dbjoin-1.$n "1-table join $jtype $inout" { + dbjoin $jtype 0 [set $inout] + } [set $inout] ; # {} + + test dbjoinKeyed-1.$n "1-table join $jtype $inout" { + dbjoink $jtype [keyed [set $inout]] + } [set $inout] ; # {} + + incr n +} + +#---------------------------------------------------------------------- +# II. Two table joins + +set n 0 ; # Counter for test cases +foreach {jtype left right result} { + -inner empty empty empty + -inner empty table_bs empty + -inner table_as empty empty + -inner table_as table_bs ijss + -inner table_as table_bm ijsm + -inner table_am table_bs ijms + -inner table_am table_bm ijmm + + -left empty empty empty + -left empty table_bs empty + -left table_as empty table_as + -left table_as table_bs ljss + -left table_as table_bm ljsm + -left table_am table_bs ljms + -left table_am table_bm ljmm + + -right empty empty empty + -right empty table_bs table_bs + -right table_as empty empty + -right table_as table_bs rjss + -right table_as table_bm rjsm + -right table_am table_bs rjms + -right table_am table_bm rjmm + + -full empty empty empty + -full empty table_bs table_bs + -full table_as empty table_as + -full table_as table_bs fjss + -full table_as table_bm fjsm + -full table_am table_bs fjms + -full table_am table_bm fjmm +} { + test dbjoin-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n +} + +#---------------------------------------------------------------------- +# III. Three table joins + +set n 0 ; # Counter for test cases +foreach {jtype left middle right result} { + -inner table_am table_bm table_cm ijmmm + -left table_am table_bm table_cm ljmmm + -right table_am table_bm table_cm rjmmm + -full table_am table_bm table_cm fjmmm +} { + test dbjoin-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $middle] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $middle]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n +} + +#---------------------------------------------------------------------- + +interp alias {} swap {} ::struct::list::list swap + +foreach {n list i j err res} { + 0 {} 0 0 1 {list index out of range} + 1 {} 3 4 1 {list index out of range} + 2 {a b c d e} -1 0 1 {list index out of range} + 3 {a b c d e} 0 -1 1 {list index out of range} + 4 {a b c d e} 6 0 1 {list index out of range} + 5 {a b c d e} 0 6 1 {list index out of range} + 6 {a b c d e} 0 0 0 {a b c d e} + 7 {a b c d e} 0 1 0 {b a c d e} + 8 {a b c d e} 1 0 0 {b a c d e} + 9 {a b c d e} 0 4 0 {e b c d a} + 10 {a b c d e} 4 0 0 {e b c d a} + 11 {a b c d e} 2 4 0 {a b e d c} + 12 {a b c d e} 4 2 0 {a b e d c} + 13 {a b c d e} 1 3 0 {a d c b e} + 14 {a b c d e} 3 1 0 {a d c b e} +} { + if {$err} { + test swap-1.$n {swap command error} { + set l $list + catch {swap l $i $j} msg + set msg + } $res ; # {} + } else { + test swap-1.$n {swap command} { + set l $list + swap l $i $j + } $res ; # {} + } +} + + +#---------------------------------------------------------------------- + +interp alias {} firstperm {} ::struct::list::list firstperm +interp alias {} nextperm {} ::struct::list::list nextperm +interp alias {} foreachperm {} ::struct::list::list foreachperm +interp alias {} permutations {} ::struct::list::list permutations + +test permutations-0.0 {permutations command, single element list} { + permutations a +} a + + +array set ps { + {Tom Dick Harry Bob} { + 0 {Bob Dick Harry Tom} {Tom Harry Bob Dick} + { + {Bob Dick Harry Tom} {Bob Dick Tom Harry} + {Bob Harry Dick Tom} {Bob Harry Tom Dick} + {Bob Tom Dick Harry} {Bob Tom Harry Dick} + {Dick Bob Harry Tom} {Dick Bob Tom Harry} + {Dick Harry Bob Tom} {Dick Harry Tom Bob} + {Dick Tom Bob Harry} {Dick Tom Harry Bob} + {Harry Bob Dick Tom} {Harry Bob Tom Dick} + {Harry Dick Bob Tom} {Harry Dick Tom Bob} + {Harry Tom Bob Dick} {Harry Tom Dick Bob} + {Tom Bob Dick Harry} {Tom Bob Harry Dick} + {Tom Dick Bob Harry} {Tom Dick Harry Bob} + {Tom Harry Bob Dick} {Tom Harry Dick Bob} + } + } + {3 2 1 4} { + 1 {1 2 3 4} {3 2 4 1} + { + {1 2 3 4} {1 2 4 3} {1 3 2 4} {1 3 4 2} + {1 4 2 3} {1 4 3 2} {2 1 3 4} {2 1 4 3} + {2 3 1 4} {2 3 4 1} {2 4 1 3} {2 4 3 1} + {3 1 2 4} {3 1 4 2} {3 2 1 4} {3 2 4 1} + {3 4 1 2} {3 4 2 1} {4 1 2 3} {4 1 3 2} + {4 2 1 3} {4 2 3 1} {4 3 1 2} {4 3 2 1} + } + } +} + +foreach k [array names ps] { + foreach {n firstp nextp allp} $ps($k) break + + test firstperm-1.$n {firstperm command} { + firstperm $k + } $firstp ; # {} + + test nextperm-1.$n {nextperm command} { + nextperm $k + } $nextp ; # {} + + # Note: The lrange below is necessary a trick/hack to kill the + # existing string representation of allp, and get a pure list out + # of it. Otherwise the string based comparison of test will fail, + # seeing different string reps of the same list. + + test permutations-1.$n {permutations command} { + permutations $k + } [lrange $allp 0 end] ; # {} + + test foreachperm-1.$n {foreachperm command} { + set res {} + foreachperm x $k {lappend res $x} + set res + } [lrange $allp 0 end] ; # {} +} + +test nextperm-2.0 {bug 3593689, busyloop} { + nextperm {1 10 9 8 7 6 5 4 3 2} +} {1 2 10 3 4 5 6 7 8 9} + +#---------------------------------------------------------------------- + +interp alias {} shuffle {} ::struct::list::list shuffle + +test shuffle-1.0 {} -body { + shuffle +} -returnCodes error -result {wrong # args: should be "::struct::list::Lshuffle list"} + +test shuffle-2.0 {shuffle nothing} -body { + shuffle {} +} -result {} + +test shuffle-2.1 {shuffle single} -body { + shuffle {a} +} -result {a} + +foreach {k n data} { + 1 2 {a b} + 2 4 {c d b a} + 3 9 {0 1 2 3 4 5 6 7 8} + 4 15 {a b c d e f 8 6 4 2 0 1 3 5 7} +} { + test shuffle-2.2.$k "shuffle $n" -body { + lsort [shuffle $data] + } -result [lsort $data] +} + +#---------------------------------------------------------------------- +testsuiteCleanup diff --git a/tcllib/modules/struct/matrix.man b/tcllib/modules/struct/matrix.man new file mode 100644 index 0000000..5c7be35 --- /dev/null +++ b/tcllib/modules/struct/matrix.man @@ -0,0 +1,539 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::matrix n 2.0.3] +[keywords matrix] +[copyright {2002-2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate matrix objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::matrix [opt 2.0.3]] +[description] +[para] + +A matrix is a rectangular collection of cells, i.e. organized in rows +and columns. Each cell contains exactly one value of arbitrary +form. The cells in the matrix are addressed by pairs of integer +numbers, with the first (left) number in the pair specifying the +column and the second (right) number specifying the row the cell is +in. These indices are counted from 0 upward. The special non-numeric +index [const end] refers to the last row or column in the matrix, +depending on the context. Indices of the form + +[const end]-[var number] are counted from the end of the row or +column, like they are for standard Tcl lists. Trying to access +non-existing cells causes an error. + +[para] + +The matrices here are created empty, i.e. they have neither rows nor +columns. The user then has to add rows and columns as needed by his +application. A specialty of this structure is the ability to export an +array-view onto its contents. Such can be used by tkTable, for +example, to link the matrix into the display. + +[para] + +The main command of the package is: + +[list_begin definitions] + +[call [cmd ::struct::matrix] [opt [arg matrixName]] [opt "[const =]|[const :=]|[const as]|[const deserialize] [arg source]"]] + +The command creates a new matrix object with an associated global Tcl +command whose name is [arg matrixName]. This command may be used to +invoke various operations on the matrix. It has the following general +form: + +[list_begin definitions] +[call [cmd matrixName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] +[para] + +If [arg matrixName] is not specified a unique name will be generated +by the package itself. If a [arg source] is specified the new matrix +will be initialized to it. For the operators [const =], [const :=], +and [const as] the argument [arg source] is interpreted as the name of +another matrix object, and the assignment operator [method =] will be +executed. For [const deserialize] the [arg source] is a serialized +matrix object and [method deserialize] will be executed. + +[para] + +In other words +[para] +[example { + ::struct::matrix mymatrix = b +}] +[para] +is equivalent to +[para] +[example { + ::struct::matrix mymatrix + mymatrix = b +}] +[para] +and +[para] +[example { + ::struct::matrix mymatrix deserialize $b +}] +[para] +is equivalent to +[para] +[example { + ::struct::matrix mymatrix + mymatrix deserialize $b +}] + +[list_end] + +[para] + +The following commands are possible for matrix objects: + +[list_begin definitions] + +[call [arg matrixName] [method =] [arg sourcematrix]] + +This is the assignment operator for matrix objects. It copies the matrix +contained in the matrix object [arg sourcematrix] over the matrix data in +[arg matrixName]. The old contents of [arg matrixName] are deleted by +this operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg matrixName] [method deserialize] [lb][arg sourcematrix] [method serialize][rb] +[example_end] + +[call [arg matrixName] [method -->] [arg destmatrix]] + +This is the reverse assignment operator for matrix objects. It copies +the matrix contained in the matrix object [arg matrixName] over the matrix +data in the object [arg destmatrix]. + +The old contents of [arg destmatrix] are deleted by this operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg destmatrix] [method deserialize] [lb][arg matrixName] [method serialize][rb] +[example_end] + +[call [arg matrixName] [method {add column}] [opt [arg values]]] + +Extends the matrix by one column and then acts like [method {set column}] +(see below) on this new column if there were [arg values] +supplied. Without [arg values] the new cells will be set to the empty +string. The new column is appended immediately behind the last +existing column. + +[call [arg matrixName] [method {add row}] [opt [arg values]]] + +Extends the matrix by one row and then acts like [method {set row}] (see +below) on this new row if there were [arg values] supplied. Without +[arg values] the new cells will be set to the empty string. The new +row is appended immediately behind the last existing row. + +[call [arg matrixName] [method {add columns}] [arg n]] + +Extends the matrix by [arg n] columns. The new cells will be set to +the empty string. The new columns are appended immediately behind the +last existing column. A value of [arg n] equal to or smaller than 0 is +not allowed. + +[call [arg matrixName] [method {add rows}] [arg n]] + +Extends the matrix by [arg n] rows. The new cells will be set to the +empty string. The new rows are appended immediately behind the last +existing row. A value of [arg n] equal to or smaller than 0 is not +allowed. + +[call [arg matrixName] [method cells]] + +Returns the number of cells currently managed by the matrix. This is +the product of [method rows] and [method columns]. + +[call [arg matrixName] [method cellsize] [arg {column row}]] + +Returns the length of the string representation of the value currently +contained in the addressed cell. + +[call [arg matrixName] [method columns]] + +Returns the number of columns currently managed by the matrix. + +[call [arg matrixName] [method columnwidth] [arg column]] + +Returns the length of the longest string representation of all the +values currently contained in the cells of the addressed column if +these are all spanning only one line. For cell values spanning +multiple lines the length of their longest line goes into the +computation. + +[para][emph Note:] The command recognizes ANSI color control sequences +and excludes them from the width of a line, as they are logically of +zero width. + +[call [arg matrixName] [method {delete column}] [arg column]] + +Deletes the specified column from the matrix and shifts all columns +with higher indices one index down. + +[call [arg matrixName] [method {delete columns}] [arg n]] + +Deletes [arg n] columns from the right of the matrix. The value of +[arg n] has to satisfy the constraint + +"0 < [arg n] < [lb][cmd matrixName] [method columns][rb]" + +[call [arg matrixName] [method {delete row}] [arg row]] + +Deletes the specified row from the matrix and shifts all row with +higher indices one index down. + +[call [arg matrixName] [method {delete rows}] [arg n]] + +Deletes [arg n] rows from the bottom of the matrix. The value of +[arg n] has to satisfy the constraint + +"0 < [arg n] < [lb][cmd matrixName] [method rows][rb]" + +[call [arg matrixName] [method deserialize] [arg serialization]] + +This is the complement to [method serialize]. It replaces matrix data +in [arg matrixName] with the matrix described by the [arg serialization] +value. The old contents of [arg matrixName] are deleted by this +operation. + +[call [arg matrixName] [method destroy]] + +Destroys the matrix, including its storage space and associated +command. + +[call [arg matrixName] [method {format 2string}] [opt [arg report]]] + +Formats the matrix using the specified report object and returns the +string containing the result of this operation. The report has to +support the [method printmatrix] method. If no [arg report] is +specified the system will use an internal report definition to format +the matrix. + +[call [arg matrixName] [method {format 2chan}] [opt "[opt [arg report]] [arg channel]"]] + +Formats the matrix using the specified report object and writes the +string containing the result of this operation into the channel. The +report has to support the [method printmatrix2channel] method. If no +[arg report] is specified the system will use an internal report +definition to format the matrix. If no [arg channel] is specified the +system will use [const stdout]. + +[call [arg matrixName] [method {get cell}] [arg {column row}]] + +Returns the value currently contained in the cell identified by row +and column index. + +[call [arg matrixName] [method {get column}] [arg column]] + +Returns a list containing the values from all cells in the column +identified by the index. The contents of the cell in row 0 are stored +as the first element of this list. + +[call [arg matrixName] [method {get rect}] [arg {column_tl row_tl column_br row_br}]] + +Returns a list of lists of cell values. The values stored in the +result come from the sub-matrix whose top-left and bottom-right cells +are specified by [arg {column_tl, row_tl}] and + +[arg {column_br, row_br}] resp. Note that the following equations have +to be true: "[arg column_tl] <= [arg column_br]" and "[arg row_tl] <= +[arg row_br]". The result is organized as follows: The outer list is +the list of rows, its elements are lists representing a single +row. The row with the smallest index is the first element of the outer +list. The elements of the row lists represent the selected cell +values. The cell with the smallest index is the first element in each +row list. + +[call [arg matrixName] [method {get row}] [arg row]] + +Returns a list containing the values from all cells in the row +identified by the index. The contents of the cell in column 0 are +stored as the first element of this list. + +[call [arg matrixName] [method {insert column}] [arg column] [opt [arg values]]] + +Extends the matrix by one column and then acts like [method {set column}] +(see below) on this new column if there were [arg values] +supplied. Without [arg values] the new cells will be set to the empty +string. The new column is inserted just before the column specified by +the given index. This means, if [arg column] is less than or equal to +zero, then the new column is inserted at the beginning of the matrix, +before the first column. If [arg column] has the value [const end], +or if it is greater than or equal to the number of columns in the +matrix, then the new column is appended to the matrix, behind the last +column. The old column at the chosen index and all columns with higher +indices are shifted one index upward. + +[call [arg matrixName] [method {insert row}] [arg row] [opt [arg values]]] + +Extends the matrix by one row and then acts like [method {set row}] (see +below) on this new row if there were [arg values] supplied. Without +[arg values] the new cells will be set to the empty string. The new +row is inserted just before the row specified by the given index. This +means, if [arg row] is less than or equal to zero, then the new row is +inserted at the beginning of the matrix, before the first row. If + +[arg row] has the value [const end], or if it is greater than or +equal to the number of rows in the matrix, then the new row is +appended to the matrix, behind the last row. The old row at that index +and all rows with higher indices are shifted one index upward. + +[call [arg matrixName] [method link] [opt -transpose] [arg arrayvar]] + +Links the matrix to the specified array variable. This means that the +contents of all cells in the matrix is stored in the array too, with +all changes to the matrix propagated there too. The contents of the +cell [arg (column,row)] is stored in the array using the key + +[arg column,row]. If the option [option -transpose] is specified the +key [arg row,column] will be used instead. It is possible to link the +matrix to more than one array. Note that the link is bidirectional, +i.e. changes to the array are mirrored in the matrix too. + +[call [arg matrixName] [method links]] + +Returns a list containing the names of all array variables the matrix +was linked to through a call to method [method link]. + +[call [arg matrixName] [method rowheight] [arg row]] + +Returns the height of the specified row in lines. This is the highest +number of lines spanned by a cell over all cells in the row. + +[call [arg matrixName] [method rows]] + +Returns the number of rows currently managed by the matrix. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method all] [arg pattern]] + +Searches the whole matrix for cells matching the [arg pattern] and +returns a list with all matches. Each item in the aforementioned list +is a list itself and contains the column and row index of the matching +cell, in this order. The results are ordered by column first and row +second, both times in ascending order. This means that matches to the +left and the top of the matrix come before matches to the right and +down. + +[para] + +The type of the pattern (string, glob, regular expression) is +determined by the option after the [method search] keyword. If no +option is given it defaults to [option -exact]. + +[para] + +If the option [option -nocase] is specified the search will be +case-insensitive. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method column] [arg {column pattern}]] + +Like [method {search all}], but the search is restricted to the +specified column. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method row] [arg {row pattern}]] + +Like [method {search all}], but the search is restricted to the +specified row. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method rect] [arg {column_tl row_tl column_br row_br pattern}]] + +Like [method {search all}], but the search is restricted to the +specified rectangular area of the matrix. + +[call [arg matrixName] [method serialize] [opt [arg {column_tl row_tl column_br row_br}]]] + +This method serializes the sub-matrix spanned up by the rectangle +specification. In other words it returns a tcl [emph value] completely +describing that matrix. If no rectangle is specified the whole matrix +will be serialized. + +This allows, for example, the transfer of matrix objects (or parts +thereof) over arbitrary channels, persistence, etc. + +This method is also the basis for both the copy constructor and the +assignment operator. + +[para] + +The result of this method has to be semantically identical over all +implementations of the matrix interface. This is what will enable us +to copy matrix data between different implementations of the same +interface. + +[para] + +The result is a list containing exactly three items. + +[para] + +The first two elements of the list specify the number of rows and +columns of the matrix, in that order. The values integer numbers +greater than or equal to zero. + +[para] + +The last element of the list contains the values of the matrix cells +we have serialized, in the form of a value like it is returned by the +[method {get rect}]. However empty cells to the right and bottom of +the matrix can be left out of that value as the size information in +the serialization allows the receiver the creation of a matrix with +the proper size despite the missing values. + +[example { + # A possible serialization for the matrix structure + # + # | a b d g | + # | c e | + # | f | + # + # is + # + # 3 4 {{a b d g} {c e} {f}} +}] +[para] + +[call [arg matrixName] [method {set cell}] [arg {column row value}]] + +Sets the value in the cell identified by row and column index to the +data in the third argument. + +[call [arg matrixName] [method {set column}] [arg {column values}]] + +Sets the values in the cells identified by the column index to the +elements of the list provided as the third argument. Each element of +the list is assigned to one cell, with the first element going into +the cell in row 0 and then upward. If there are less values in the +list than there are rows the remaining rows are set to the empty +string. If there are more values in the list than there are rows the +superfluous elements are ignored. The matrix is not extended by this +operation. + +[call [arg matrixName] [method {set rect}] [arg {column row values}]] + +Takes a list of lists of cell values and writes them into the +submatrix whose top-left cell is specified by the two indices. If the +sublists of the outerlist are not of equal length the shorter sublists +will be filled with empty strings to the length of the longest +sublist. If the submatrix specified by the top-left cell and the +number of rows and columns in the [arg values] extends beyond the +matrix we are modifying the over-extending parts of the values are +ignored, i.e. essentially cut off. This subcommand expects its input +in the format as returned by [method {get rect}]. + +[call [arg matrixName] [method {set row}] [arg {row values}]] + +Sets the values in the cells identified by the row index to the +elements of the list provided as the third argument. Each element of +the list is assigned to one cell, with the first element going into +the cell in column 0 and then upward. If there are less values in the +list than there are columns the remaining columns are set to the empty +string. If there are more values in the list than there are columns +the superfluous elements are ignored. The matrix is not extended by +this operation. + +[call [arg matrixName] [method {sort columns}] [opt [option -increasing]|[option -decreasing]] [arg row]] + +Sorts the columns in the matrix using the data in the specified +[arg row] as the key to sort by. The options [option -increasing] +and [option -decreasing] have the same meaning as for [cmd lsort]. +If no option is specified [option -increasing] is assumed. + +[call [arg matrixName] [method {sort rows}] [opt [option -increasing]|[option -decreasing]] [arg column]] + +Sorts the rows in the matrix using the data in the specified +[arg column] as the key to sort by. The options [option -increasing] +and [option -decreasing] have the same meaning as for [cmd lsort]. +If no option is specified [option -increasing] is assumed. + +[call [arg matrixName] [method {swap columns}] [arg {column_a column_b}]] + +Swaps the contents of the two specified columns. + +[call [arg matrixName] [method {swap rows}] [arg {row_a row_b}]] + +Swaps the contents of the two specified rows. + +[call [arg matrixName] [method transpose]] + +Transposes the contents of the matrix, i.e. swaps rows for columns and +vice versa. + +[call [arg matrixName] [method unlink] [arg arrayvar]] + +Removes the link between the matrix and the specified arrayvariable, +if there is one. + +[list_end] + +[section EXAMPLES] +[para] + +The examples below assume a 5x5 matrix M with the first row containing +the values 1 to 5, with 1 in the top-left cell. Each other row +contains the contents of the row above it, rotated by one cell to the +right. + +[para] +[example { + % M get rect 0 0 4 4 + {{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}} +}] + +[para] +[example { + % M set rect 1 1 {{0 0 0} {0 0 0} {0 0 0}} + % M get rect 0 0 4 4 + {{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}} +}] + +[para] + +Assuming that the style definitions in the example section of the +manpage for the package [package report] are loaded into the +interpreter now an example which formats a matrix into a tabular +report. The code filling the matrix with data is not shown. contains +useful data. + +[para] + +[example { + % ::struct::matrix m + % # ... fill m with data, assume 5 columns + % ::report::report r 5 style captionedtable 1 + % m format 2string r + +---+-------------------+-------+-------+--------+ + |000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| + +---+-------------------+-------+-------+--------+ + |001|CATCH return ok |7 |13 |53.85 | + |002|CATCH return error |68 |91 |74.73 | + |003|CATCH no catch used|7 |14 |50.00 | + |004|IF if true numeric |12 |33 |36.36 | + |005|IF elseif |15 |47 |31.91 | + | |true numeric | | | | + +---+-------------------+-------+-------+--------+ + % + % # alternate way of doing the above + % r printmatrix m +}] + +[vset CATEGORY {struct :: matrix}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/matrix.tcl b/tcllib/modules/struct/matrix.tcl new file mode 100644 index 0000000..e38dd5a --- /dev/null +++ b/tcllib/modules/struct/matrix.tcl @@ -0,0 +1,2792 @@ +# matrix.tcl -- +# +# Implementation of a matrix data structure for Tcl. +# +# Copyright (c) 2001-2013 by Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# Heapsort code Copyright (c) 2003 by Edwin A. Suominen <ed@eepatents.com>, +# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: matrix.tcl,v 1.23 2008/02/20 00:39:39 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::struct {} + +namespace eval ::struct::matrix { + # Data storage in the matrix module + # ------------------------------- + # + # One namespace per object, containing + # + # - Two scalar variables containing the current number of rows and columns. + # - Four array variables containing the array data, the caches for + # row heights and column widths and the information about linked arrays. + # + # The variables are + # - columns #columns in data + # - rows #rows in data + # - data cell contents + # - colw cache of column widths + # - rowh cache of row heights + # - link information about linked arrays + # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] + # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. + + # counter is used to give a unique name for unnamed matrices + variable counter 0 + + # Only export one command, the one used to instantiate a new matrix + namespace export matrix +} + +# ::struct::matrix::matrix -- +# +# Create a new matrix with a given name; if no name is given, use +# matrixX, where X is a number. +# +# Arguments: +# name Optional name of the matrix; if null or not given, generate one. +# +# Results: +# name Name of the matrix created + +proc ::struct::matrix::matrix {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "matrix${counter}" + } + 2 { + # Standard call. New empty matrix. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype matrix + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + if { [llength [info commands $name]] } { + return -code error "command \"$name\" already exists, unable to create matrix" + } + + # Set up the namespace + namespace eval $name { + variable columns 0 + variable rows 0 + + variable data + variable colw + variable rowh + variable link + variable lock + variable unset + + array set data {} + array set colw {} + array set rowh {} + array set link {} + set lock 0 + set unset {} + } + + # Create the command to manipulate the matrix + interp alias {} $name {} ::struct::matrix::MatrixProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + matrix {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + return $name +} + +########################## +# Private functions follow + +# ::struct::matrix::MatrixProc -- +# +# Command that processes all matrix object commands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::MatrixProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if {[llength [info commands ::struct::matrix::$sub]] == 0} { + set optlist [lsort [info commands ::struct::matrix::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_= -- +# +# Assignment operator. Copies the source matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# source Name of the matrix object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::matrix::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::matrix::_--> -- +# +# Reverse assignment operator. Copies this matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object to copy +# dest Name of the matrix object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::matrix::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::matrix::_add -- +# +# Command that processes all 'add' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'add' to invoke. +# args Arguments for subcommand of 'add'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_add {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __add_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__add_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_delete -- +# +# Command that processes all 'delete' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'delete' to invoke. +# args Arguments for subcommand of 'delete'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_delete {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __delete_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__delete_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_format -- +# +# Command that processes all 'format' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'format' to invoke. +# args Arguments for subcommand of 'format'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_format {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __format_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__format_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_get -- +# +# Command that processes all 'get' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'get' to invoke. +# args Arguments for subcommand of 'get'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_get {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __get_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__get_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_insert -- +# +# Command that processes all 'insert' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'insert' to invoke. +# args Arguments for subcommand of 'insert'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_insert {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __insert_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__insert_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_search -- +# +# Command that processes all 'search' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# args Arguments for search. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_search {name args} { + set mode exact + set nocase 0 + + while {1} { + switch -glob -- [lindex $args 0] { + -exact - -glob - -regexp { + set mode [string range [lindex $args 0] 1 end] + set args [lrange $args 1 end] + } + -nocase { + set nocase 1 + set args [lrange $args 1 end] + } + -* { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -nocase, -exact, -glob, or -regexp" + } + default { + break + } + } + } + + # Possible argument signatures after option processing + # + # \ | args + # --+-------------------------------------------------------- + # 2 | all pattern + # 3 | row row pattern, column col pattern + # 6 | rect ctl rtl cbr rbr pattern + # + # All range specifications are internally converted into a + # rectangle. + + switch -exact -- [llength $args] { + 2 - 3 - 6 {} + default { + return -code error \ + "wrong # args: should be\ + \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" + } + } + + set range [lindex $args 0] + set pattern [lindex $args end] + set args [lrange $args 1 end-1] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + switch -exact -- $range { + all { + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + column { + set ctl [ChkColumnIndex $name [lindex $args 0]] + set cbr $ctl + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + row { + set rtl [ChkRowIndex $name [lindex $args 0]] + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rbr $rtl + } + rect { + foreach {ctl rtl cbr rbr} $args break + set ctl [ChkColumnIndex $name $ctl] + set rtl [ChkRowIndex $name $rtl] + set cbr [ChkColumnIndex $name $cbr] + set rbr [ChkRowIndex $name $rbr] + if {($ctl > $cbr) || ($rtl > $rbr)} { + return -code error "Invalid cell indices, wrong ordering" + } + } + default { + return -code error "invalid range spec \"$range\": should be all, column, row, or rect" + } + } + + if {$nocase} { + set pattern [string tolower $pattern] + } + + set matches [list] + for {set r $rtl} {$r <= $rbr} {incr r} { + for {set c $ctl} {$c <= $cbr} {incr c} { + set v $data($c,$r) + if {$nocase} { + set v [string tolower $v] + } + switch -exact -- $mode { + exact {set matched [string equal $pattern $v]} + glob {set matched [string match $pattern $v]} + regexp {set matched [regexp -- $pattern $v]} + } + if {$matched} { + lappend matches [list $c $r] + } + } + } + return $matches +} + +# ::struct::matrix::_set -- +# +# Command that processes all 'set' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'set' to invoke. +# args Arguments for subcommand of 'set'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_set {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __set_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__set_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_sort -- +# +# Command that processes all 'sort' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'sort' to invoke. +# args Arguments for subcommand of 'sort'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_sort {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + if {[string equal $cmd "rows"]} { + set code r + set byrows 1 + } elseif {[string equal $cmd "columns"]} { + set code c + set byrows 0 + } else { + return -code error \ + "bad option \"$cmd\": must be columns, or rows" + } + + set revers 0 ;# Default: -increasing + while {1} { + switch -glob -- [lindex $args 0] { + -increasing {set revers 0} + -decreasing {set revers 1} + default { + if {[llength $args] > 1} { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -increasing, or -decreasing" + } + break + } + } + set args [lrange $args 1 end] + } + # ASSERT: [llength $args] == 1 + + if {[llength $args] != 1} { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + + set key [lindex $args 0] + + if {$byrows} { + set key [ChkColumnIndex $name $key] + variable ${name}::rows + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $rows + } else { + set key [ChkRowIndex $name $key] + variable ${name}::columns + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $columns + } + + for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { + SortMaxHeapify $name $i $key $code $heapSize $revers + } + + # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 + for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { + if {$byrows} { + SwapRows $name 0 $i + } else { + SwapColumns $name 0 $i + } + incr heapSize -1 + SortMaxHeapify $name 0 $key $code $heapSize $revers + } + return +} + +# ::struct::matrix::_swap -- +# +# Command that processes all 'swap' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'swap' to invoke. +# args Arguments for subcommand of 'swap'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_swap {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __swap_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__swap_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::__add_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is appended immediately +# behind the last existing column. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_column {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new column is not added to the width cache, the other + # columns are not touched, the cache therefore unchanged. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($columns,$r) $v + incr r + } + incr columns + return +} + +# ::struct::matrix::__add_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is appended immediately behind the +# last existing row. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_row {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new row is not added to the height cache, the other + # rows are not touched, the cache therefore unchanged. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$rows) $v + incr c + } + incr rows + return +} + +# ::struct::matrix::__add_columns -- +# +# Extends the matrix by "n" columns. The new cells will be set +# to the empty string. The new columns are appended immediately +# behind the last existing column. A value of "n" equal to or +# smaller than 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new columns to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddColumns $name $n + return +} + +proc ::struct::matrix::AddColumns {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set r 0} {$r < $rows} {incr r} { + set data($columns,$r) "" + } + incr columns + incr n -1 + } + + return +} + +# ::struct::matrix::__add_rows -- +# +# Extends the matrix by "n" rows. The new cells will be set to +# the empty string. The new rows are appended immediately behind +# the last existing row. A value of "n" equal to or smaller than +# 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new rows to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddRows $name $n + return +} + +proc ::struct::matrix::AddRows {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set c 0} {$c < $columns} {incr c} { + set data($c,$rows) "" + } + incr rows + incr n -1 + } + return +} + +# ::struct::matrix::_cells -- +# +# Returns the number of cells currently managed by the +# matrix. This is the product of "rows" and "columns". +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cells {name} { + variable ${name}::rows + variable ${name}::columns + return [expr {$rows * $columns}] +} + +# ::struct::matrix::_cellsize -- +# +# Returns the length of the string representation of the value +# currently contained in the addressed cell. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to query +# row Row index of the cell to query +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cellsize {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return [string length $data($column,$row)] +} + +# ::struct::matrix::_columns -- +# +# Returns the number of columns currently managed by the +# matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of columns in the matrix. + +proc ::struct::matrix::_columns {name} { + variable ${name}::columns + return $columns +} + +# ::struct::matrix::_columnwidth -- +# +# Returns the length of the longest string representation of all +# the values currently contained in the cells of the addressed +# column if these are all spanning only one line. For cell +# values spanning multiple lines the length of their longest +# line goes into the computation. +# +# Arguments: +# name Name of the matrix object. +# column The index of the column whose width is asked for. +# +# Results: +# See description. + +proc ::struct::matrix::_columnwidth {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::colw + + if {![info exists colw($column)]} { + variable ${name}::rows + variable ${name}::data + + set width 0 + for {set r 0} {$r < $rows} {incr r} { + foreach line [split $data($column,$r) \n] { + # Look for ANSI color control sequences and remove + # them. Avoid counting their characters as such + # sequences as a whole represent a state change, and + # are logically of zero/no width. + regsub -all "\033\\\[\[0-9;\]*m" $line {} line + set len [string length $line] + if {$len > $width} { + set width $len + } + } + } + + set colw($column) $width + } + + return $colw($column) +} + +# ::struct::matrix::__delete_column -- +# +# Deletes the specified column from the matrix and shifts all +# columns with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# column The index of the column to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_column {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { + set data($c,$r) $data($cn,$r) + if {[info exists colw($cn)]} { + set colw($c) $colw($cn) + unset colw($cn) + } + } + unset data($c,$r) + catch {unset rowh($r)} + } + incr columns -1 + return +} + +# ::struct::matrix::__delete_columns -- +# +# Shrink the matrix by "n" columns (from the right). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of columns in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of columns to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::columns + + if {$n > $columns} { + return -code error "A value of n > #columns is not allowed" + } + + DeleteColumns $name $n + return +} + +# ::struct::matrix::__delete_row -- +# +# Deletes the specified row from the matrix and shifts all +# row with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# row The index of the row to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_row {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { + set data($c,$r) $data($c,$rn) + if {[info exists rowh($rn)]} { + set rowh($r) $rowh($rn) + unset rowh($rn) + } + } + unset data($c,$r) + catch {unset colw($c)} + } + incr rows -1 + return +} + +# ::struct::matrix::__delete_rows -- +# +# Shrink the matrix by "n" rows (from the bottom). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of rows in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of rows to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::rows + + if {$n > $rows} { + return -code error "A value of n > #rows is not allowed" + } + + DeleteRows $name $n + return +} + +# ::struct::matrix::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# serial Serialized matrix to copy from. +# +# Results: +# Nothing. + +proc ::struct::matrix::_deserialize {name serial} { + # As we destroy the original matrix as part of + # the copying process we don't have to deal + # with issues like node names from the new matrix + # interfering with the old ... + + # I. Get the serialization of the source matrix + # and check it for validity. + + CheckSerialization $serial r c values + + # Get all the relevant data into the scope + + variable ${name}::rows + variable ${name}::columns + + # Resize the destination matrix for the new data + + if {$r > $rows} { + AddRows $name [expr {$r - $rows}] + } elseif {$r < $rows} { + DeleteRows $name [expr {$rows - $r}] + } + if {$c > $columns} { + AddColumns $name [expr {$c - $columns}] + } elseif {$c < $columns} { + DeleteColumns $name [expr {$columns - $c}] + } + + set rows $r + set columns $c + + # Copy the new data over the old information. + + set row 0 + foreach rv $values { + SetRow $name $row $rv + incr row + } + while {$row < $rows} { + # Fill with empty rows if there are not enough. + SetRow $name $row {} + incr row + } + return +} + +# ::struct::matrix::_destroy -- +# +# Destroy a matrix, including its associated command and data storage. +# +# Arguments: +# name Name of the matrix to destroy. +# +# Results: +# None. + +proc ::struct::matrix::_destroy {name} { + variable ${name}::link + + # Unlink all existing arrays before destroying the object so that + # we don't leave dangling references / traces. + + foreach avar [array names link] { + _unlink $name $avar + } + + namespace delete $name + interp alias {} $name {} +} + +# ::struct::matrix::__format_2string -- +# +# Formats the matrix using the specified report object and +# returns the string containing the result of this +# operation. The report has to support the "printmatrix" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# +# Results: +# A string containing the formatting result. + +proc ::struct::matrix::__format_2string {name {report {}}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # 1. Go through all columns and compute the column widths. + # 2. Then iterate through all rows and dump then into a + # string, formatted to the number of characters per columns + + array set cw {} + set cols [_columns $name] + for {set c 0} {$c < $cols} {incr c} { + set cw($c) [_columnwidth $name $c] + } + + set result [list] + set n [_rows $name] + for {set r 0} {$r < $n} {incr r} { + set rh [_rowheight $name $r] + if {$rh < 2} { + # Simple row. + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [__get_cell $name $c $r] + lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" + } + lappend result [join $line " "] + } else { + # Complex row, multiple passes + for {set h 0} {$h < $rh} {incr h} { + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [lindex [split [__get_cell $name $c $r] \n] $h] + lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" + } + lappend result [join $line " "] + } + } + } + return [join $result \n] + } else { + return [$report printmatrix $name] + } +} + +# ::struct::matrix::__format_2chan -- +# +# Formats the matrix using the specified report object and +# writes the string containing the result of this operation into +# the channel. The report has to support the +# "printmatrix2channel" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# chan Handle of the channel to write to. +# +# Results: +# None. + +proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # We delegate this to the string formatter and print its result. + puts -nonewline [__format_2string $name] + } else { + $report printmatrix2channel $name $chan + } + return +} + +# ::struct::matrix::__get_cell -- +# +# Returns the value currently contained in the cell identified +# by row and column index. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# row Row index of the addressed cell. +# +# Results: +# value Value currently stored in the addressed cell. + +proc ::struct::matrix::__get_cell {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return $data($column,$row) +} + +# ::struct::matrix::__get_column -- +# +# Returns a list containing the values from all cells in the +# column identified by the index. The contents of the cell in +# row 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_column {name column} { + set column [ChkColumnIndex $name $column] + return [GetColumn $name $column] +} + +proc ::struct::matrix::GetColumn {name column} { + variable ${name}::data + variable ${name}::rows + + set result [list] + for {set r 0} {$r < $rows} {incr r} { + lappend result $data($column,$r) + } + return $result +} + +# ::struct::matrix::__get_rect -- +# +# Returns a list of lists of cell values. The values stored in +# the result come from the submatrix whose top-left and +# bottom-right cells are specified by "column_tl", "row_tl" and +# "column_br", "row_br" resp. Note that the following equations +# have to be true: column_tl <= column_br and row_tl <= row_br. +# The result is organized as follows: The outer list is the list +# of rows, its elements are lists representing a single row. The +# row with the smallest index is the first element of the outer +# list. The elements of the row lists represent the selected +# cell values. The cell with the smallest index is the first +# element in each row list. +# +# Arguments: +# name Name of the matrix. +# column_tl Column index of the top-left cell of the area. +# row_tl Row index of the top-left cell of the the area +# column_br Column index of the bottom-right cell of the area. +# row_br Row index of the bottom-right cell of the the area +# +# Results: +# List of a list of values stored in the addressed area. + +proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + return [GetRect $name $column_tl $row_tl $column_br $row_br] +} + +proc ::struct::matrix::GetRect {name column_tl row_tl column_br row_br} { + variable ${name}::data + set result [list] + + for {set r $row_tl} {$r <= $row_br} {incr r} { + set row [list] + for {set c $column_tl} {$c <= $column_br} {incr c} { + lappend row $data($c,$r) + } + lappend result $row + } + + return $result +} + +# ::struct::matrix::__get_row -- +# +# Returns a list containing the values from all cells in the +# row identified by the index. The contents of the cell in +# column 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# row Row index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_row {name row} { + set row [ChkRowIndex $name $row] + return [GetRow $name $row] +} + +proc ::struct::matrix::GetRow {name row} { + variable ${name}::data + variable ${name}::columns + + set result [list] + for {set c 0} {$c < $columns} {incr c} { + lappend result $data($c,$row) + } + return $result +} + +# ::struct::matrix::__insert_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is inserted just before +# the column specified by the given index. This means, if +# "column" is less than or equal to zero, then the new column is +# inserted at the beginning of the matrix, before the first +# column. If "column" has the value "Bend", or if it is greater +# than or equal to the number of columns in the matrix, then the +# new column is appended to the matrix, behind the last +# column. The old column at the chosen index and all columns +# with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# column Index of the column where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_column {name column {values {}}} { + # Allow both negative and too big indices. + set column [ChkColumnIndexAll $name $column] + + variable ${name}::columns + + if {$column > $columns} { + # Same as 'addcolumn' + __add_column $name $values + return + } + + variable ${name}::data + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + set firstcol $column + if {$firstcol < 0} { + set firstcol 0 + } + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all rows, move all columns + + # Move all data from the higher columns one up and then insert the + # new data into the freed space. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { + set data($cn,$r) $data($c,$r) + if {[info exists colw($c)]} { + set colw($cn) $colw($c) + unset colw($c) + } + } + set data($firstcol,$r) [lindex $values $r] + catch {unset rowh($r)} + } + incr columns + return +} + +# ::struct::matrix::__insert_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is inserted just before the row +# specified by the given index. This means, if "row" is less +# than or equal to zero, then the new row is inserted at the +# beginning of the matrix, before the first row. If "row" has +# the value "end", or if it is greater than or equal to the +# number of rows in the matrix, then the new row is appended to +# the matrix, behind the last row. The old row at that index and +# all rows with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# row Index of the row where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_row {name row {values {}}} { + # Allow both negative and too big indices. + set row [ChkRowIndexAll $name $row] + + variable ${name}::rows + + if {$row > $rows} { + # Same as 'addrow' + __add_row $name $values + return + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + variable ${name}::colw + + set firstrow $row + if {$firstrow < 0} { + set firstrow 0 + } + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all columns, move all rows + + # Move all data from the higher rows one up and then insert the + # new data into the freed space. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { + set data($c,$rn) $data($c,$r) + if {[info exists rowh($r)]} { + set rowh($rn) $rowh($r) + unset rowh($r) + } + } + set data($c,$firstrow) [lindex $values $c] + catch {unset colw($c)} + } + incr rows + return +} + +# ::struct::matrix::_link -- +# +# Links the matrix to the specified array variable. This means +# that the contents of all cells in the matrix is stored in the +# array too, with all changes to the matrix propagated there +# too. The contents of the cell "(column,row)" is stored in the +# array using the key "column,row". If the option "-transpose" +# is specified the key "row,column" will be used instead. It is +# possible to link the matrix to more than one array. Note that +# the link is bidirectional, i.e. changes to the array are +# mirrored in the matrix too. +# +# Arguments: +# name Name of the matrix object. +# option Either empty of '-transpose'. +# avar Name of the variable to link to +# +# Results: +# None + +proc ::struct::matrix::_link {name args} { + switch -exact -- [llength $args] { + 0 { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + 1 { + set transpose 0 + set variable [lindex $args 0] + } + 2 { + foreach {t variable} $args break + if {[string compare $t -transpose]} { + return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" + } + set transpose 1 + } + default { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + } + + variable ${name}::link + + if {[info exists link($variable)]} { + return -code error "$name link: Variable \"$variable\" already linked to matrix" + } + + # Ok, a new variable we are linked to. Record this information, + # dump our current contents into the array, at last generate the + # traces actually performing the link. + + set link($variable) $transpose + + upvar #0 $variable array + variable ${name}::data + + foreach key [array names data] { + foreach {c r} [split $key ,] break + if {$transpose} { + set array($r,$c) $data($key) + } else { + set array($c,$r) $data($key) + } + } + + trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] + trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] + return +} + +# ::struct::matrix::_links -- +# +# Retrieves the names of all array variable the matrix is +# officially linked to. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# List of variables the matrix is linked to. + +proc ::struct::matrix::_links {name} { + variable ${name}::link + return [array names link] +} + +# ::struct::matrix::_rowheight -- +# +# Returns the height of the specified row in lines. This is the +# highest number of lines spanned by a cell over all cells in +# the row. +# +# Arguments: +# name Name of the matrix +# row Index of the row queried for its height +# +# Results: +# The height of the specified row in lines. + +proc ::struct::matrix::_rowheight {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::rowh + + if {![info exists rowh($row)]} { + variable ${name}::columns + variable ${name}::data + + set height 1 + for {set c 0} {$c < $columns} {incr c} { + set cheight [llength [split $data($c,$row) \n]] + if {$cheight > $height} { + set height $cheight + } + } + + set rowh($row) $height + } + return $rowh($row) +} + +# ::struct::matrix::_rows -- +# +# Returns the number of rows currently managed by the matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of rows in the matrix. + +proc ::struct::matrix::_rows {name} { + variable ${name}::rows + return $rows +} + +# ::struct::matrix::_serialize -- +# +# Serialize a matrix object (partially) into a transportable value. +# If only a rectangle is serialized the result will be a sub- +# matrix in the mathematical sense of the word. +# +# Arguments: +# name Name of the matrix. +# args rectangle to place into the serialized matrix +# +# Results: +# A list structure describing the part of the matrix which was serialized. + +proc ::struct::matrix::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # matrix are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + set nargs [llength $args] + if {($nargs != 0) && ($nargs != 4)} { + return -code error "$name: wrong # args: serialize ?column_tl row_tl column_br row_br?" + } + + variable ${name}::rows + variable ${name}::columns + + if {$nargs == 4} { + foreach {column_tl row_tl column_br row_br} $args break + + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + set rn [expr {$row_br - $row_tl + 1}] + set cn [expr {$column_br - $column_tl + 1}] + } else { + set column_tl 0 + set row_tl 0 + set column_br [expr {$columns - 1}] + set row_br [expr {$rows - 1}] + set rn $rows + set cn $columns + } + + # We could optimize and remove empty cells to the right and rows + # to the bottom. For now we don't. + + return [list \ + $rn $cn \ + [GetRect $name $column_tl $row_tl $column_br $row_br]] +} + +# ::struct::matrix::__set_cell -- +# +# Sets the value in the cell identified by row and column index +# to the data in the third argument. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to set. +# row Row index of the cell to set. +# value The new value of the cell. +# +# Results: +# None. + +proc ::struct::matrix::__set_cell {name column row value} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + + if {![string compare $value $data($column,$row)]} { + # No change, ignore call! + return + } + + set data($column,$row) $value + + if {$value != {}} { + variable ${name}::colw + variable ${name}::rowh + catch {unset colw($column)} + catch {unset rowh($row)} + } + return +} + +# ::struct::matrix::__set_column -- +# +# Sets the values in the cells identified by the column index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in row 0 and then upward. If there +# are less values in the list than there are rows the remaining +# rows are set to the empty string. If there are more values in +# the list than there are rows the superfluous elements are +# ignored. The matrix is not extended by this operation. +# +# Arguments: +# name Name of the matrix. +# column Index of the column to set. +# values Values to set into the column. +# +# Results: +# None. + +proc ::struct::matrix::__set_column {name column values} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the column in the width cache. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($column,$r) $v + incr r + } + catch {unset colw($column)} + return +} + +# ::struct::matrix::__set_rect -- +# +# Takes a list of lists of cell values and writes them into the +# submatrix whose top-left cell is specified by the two +# indices. If the sublists of the outer list are not of equal +# length the shorter sublists will be filled with empty strings +# to the length of the longest sublist. If the submatrix +# specified by the top-left cell and the number of rows and +# columns in the "values" extends beyond the matrix we are +# modifying the over-extending parts of the values are ignored, +# i.e. essentially cut off. This subcommand expects its input in +# the format as returned by "getrect". +# +# Arguments: +# name Name of the matrix object. +# column Column index of the topleft cell to set. +# row Row index of the topleft cell to set. +# values Values to set. +# +# Results: +# None. + +proc ::struct::matrix::__set_rect {name column row values} { + # Allow negative indices! + set column [ChkColumnIndexNeg $name $column] + set row [ChkRowIndexNeg $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {$row < 0} { + # Remove rows from the head of values to restrict it to the + # overlapping area. + + set values [lrange $values [expr {0 - $row}] end] + set row 0 + } + + # Restrict it at the end too. + if {($row + [llength $values]) > $rows} { + set values [lrange $values 0 [expr {$rows - $row - 1}]] + } + + # Same for columns, but store it in some vars as this is required + # in a loop. + set firstcol 0 + if {$column < 0} { + set firstcol [expr {0 - $column}] + set column 0 + } + + # Now pan through values and area and copy the external data into + # the matrix. + + set r $row + foreach line $values { + set line [lrange $line $firstcol end] + + set l [expr {$column + [llength $line]}] + if {$l > $columns} { + set line [lrange $line 0 [expr {$columns - $column - 1}]] + } elseif {$l < [expr {$columns - $firstcol}]} { + # We have to take the offset into the line into account + # or we add fillers we don't need, overwriting part of the + # data array we shouldn't. + + for {} {$l < [expr {$columns - $firstcol}]} {incr l} { + lappend line {} + } + } + + set c $column + foreach cell $line { + if {$cell != {}} { + catch {unset rowh($r)} + catch {unset colw($c)} + } + set data($c,$r) $cell + incr c + } + incr r + } + return +} + +# ::struct::matrix::__set_row -- +# +# Sets the values in the cells identified by the row index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in column 0 and then upward. If +# there are less values in the list than there are columns the +# remaining columns are set to the empty string. If there are +# more values in the list than there are columns the superfluous +# elements are ignored. The matrix is not extended by this +# operation. +# +# Arguments: +# name Name of the matrix. +# row Index of the row to set. +# values Values to set into the row. +# +# Results: +# None. + +proc ::struct::matrix::__set_row {name row values} { + set row [ChkRowIndex $name $row] + SetRow $name $row $values +} + +proc ::struct::matrix::SetRow {name row values} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the row in the height cache. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$row) $v + incr c + } + catch {unset rowh($row)} + return +} + +# ::struct::matrix::__swap_columns -- +# +# Swaps the contents of the two specified columns. +# +# Arguments: +# name Name of the matrix. +# column_a Index of the first column to swap +# column_b Index of the second column to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_columns {name column_a column_b} { + set column_a [ChkColumnIndex $name $column_a] + set column_b [ChkColumnIndex $name $column_b] + return [SwapColumns $name $column_a $column_b] +} + +proc ::struct::matrix::SwapColumns {name column_a column_b} { + variable ${name}::data + variable ${name}::rows + variable ${name}::colw + + # Note: This operation does not influence the height cache for all + # rows and the width cache only insofar as its contents has to be + # swapped too for the two columns we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set r 0} {$r < $rows} {incr r} { + set tmp $data($column_a,$r) + set data($column_a,$r) $data($column_b,$r) + set data($column_b,$r) $tmp + } + + set cwa [info exists colw($column_a)] + set cwb [info exists colw($column_b)] + + if {$cwa && $cwb} { + set tmp $colw($column_a) + set colw($column_a) $colw($column_b) + set colw($column_b) $tmp + } elseif {$cwa} { + # Move contents, don't swap. + set colw($column_b) $colw($column_a) + unset colw($column_a) + } elseif {$cwb} { + # Move contents, don't swap. + set colw($column_a) $colw($column_b) + unset colw($column_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::__swap_rows -- +# +# Swaps the contents of the two specified rows. +# +# Arguments: +# name Name of the matrix. +# row_a Index of the first row to swap +# row_b Index of the second row to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_rows {name row_a row_b} { + set row_a [ChkRowIndex $name $row_a] + set row_b [ChkRowIndex $name $row_b] + return [SwapRows $name $row_a $row_b] +} + +proc ::struct::matrix::SwapRows {name row_a row_b} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + + # Note: This operation does not influence the width cache for all + # columns and the height cache only insofar as its contents has to be + # swapped too for the two rows we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set c 0} {$c < $columns} {incr c} { + set tmp $data($c,$row_a) + set data($c,$row_a) $data($c,$row_b) + set data($c,$row_b) $tmp + } + + set rha [info exists rowh($row_a)] + set rhb [info exists rowh($row_b)] + + if {$rha && $rhb} { + set tmp $rowh($row_a) + set rowh($row_a) $rowh($row_b) + set rowh($row_b) $tmp + } elseif {$rha} { + # Move contents, don't swap. + set rowh($row_b) $rowh($row_a) + unset rowh($row_a) + } elseif {$rhb} { + # Move contents, don't swap. + set rowh($row_a) $rowh($row_b) + unset rowh($row_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::_transpose -- +# +# Exchanges rows and columns of the matrix +# +# Arguments: +# name Name of the matrix. +# +# Results: +# None. + +proc ::struct::matrix::_transpose {name} { + variable ${name}::rows + variable ${name}::columns + + if {$rows == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set rows $columns + set columns 0 + return + + } elseif {$columns == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set columns $rows + set rows 0 + return + } + + variable ${name}::data + variable ${name}::rowh + variable ${name}::colw + + # Exchanging the row/col caches is easy, independent of the actual + # dimensions of the matrix. + + set rhc [array get rowh] + set cwc [array get colw] + + unset rowh ; array set rowh $cwc + unset colw ; array set colw $rhc + + if {$rows == $columns} { + # A square matrix. We have to swap data around, but there is + # need to resize any of the arrays. Only the core is present. + + set n $columns + + } elseif {$rows > $columns} { + # Rectangular matrix, we have to delete rows, and add columns. + + for {set r $columns} {$r < $rows} {incr r} { + for {set c 0} {$c < $columns} {incr c} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $columns ; # Size of the core. + } else { + # rows < columns. Rectangular matrix, we have to delete + # columns, and add rows. + + for {set c $rows} {$c < $columns} {incr c} { + for {set r 0} {$r < $rows} {incr r} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $rows ; # Size of the core. + } + + set tmp $rows + set rows $columns + set columns $tmp + + # Whatever the actual dimensions, a square core is always + # present. The data of this core is now shuffled + + for {set i 0} {$i < $n} {incr i} { + for {set j $i ; incr j} {$j < $n} {incr j} { + set tmp $data($i,$j) + set data($i,$j) $data($j,$i) + set data($j,$i) $tmp + } + } + return +} + +# ::struct::matrix::_unlink -- +# +# Removes the link between the matrix and the specified +# arrayvariable, if there is one. +# +# Arguments: +# name Name of the matrix. +# avar Name of the linked array. +# +# Results: +# None. + +proc ::struct::matrix::_unlink {name avar} { + + variable ${name}::link + + if {![info exists link($avar)]} { + # Ignore unlinking of unknown variables. + return + } + + # Delete the traces first, then remove the link management + # information from the object. + + upvar #0 $avar array + variable ${name}::data + + trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] + trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] + + unset link($avar) + return +} + +# ::struct::matrix::ChkColumnIndex -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndex {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "bad column index $column, column does not exist" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndex -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndex {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {($rr < 0) || ($rr >= $rows)} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + if {$rows <= 0} { + return -code error "bad row index $row, row does not exist" + } + return [expr {$rows - 1}] + } + {[0-9]+} { + if {($row < 0) || ($row >= $rows)} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexNeg -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexNeg {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {$cc >= $columns} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + return [expr {$columns - 1}] + } + {[0-9]+} { + if {$column >= $columns} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexNeg -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexNeg {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {$rr >= $rows} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + return [expr {$rows - 1}] + } + {[0-9]+} { + if {$row >= $rows} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexAll -- +# +# Helper to transform column indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexAll {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + return $cc + } + end { + return $columns + } + {[0-9]+} { + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexAll -- +# +# Helper to transform row indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexAll {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + return $rr + } + end { + return $rows + } + {[0-9]+} { + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::MatTraceIn -- +# +# Helper propagating changes made to an array +# into the matrix the array is linked to. +# +# Arguments: +# avar Name of the array which was changed. +# name Matrix to write the changes to. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceIn {avar name var idx op} { + # Propagate changes in the linked array back into the matrix. + + variable ${name}::lock + if {$lock} {return} + + # We have to cover two possibilities when encountering an "unset" operation ... + # 1. The external array was destroyed: perform automatic unlink. + # 2. An individual element was unset: Set the corresponding cell to the empty string. + # See SF Tcllib Bug #532791. + + if {(![string compare $op u]) && ($idx == {})} { + # Possibility 1: Array was destroyed + $name unlink $avar + return + } + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + # Use standard method to propagate the change. + # => Get automatically index checks, cache updates, ... + + if {![string compare $op u]} { + # Unset possibility 2: Element was unset. + # Note: Setting the cell to the empty string will + # invoke MatTraceOut for this array and thus try + # to recreate the destroyed element of the array. + # We don't want this. But we do want to propagate + # the change to other arrays, as "unset". To do + # all of this we use another state variable to + # signal this situation. + + variable ${name}::unset + set unset $avar + + $name set cell $c $r "" + + set unset {} + return + } + + $name set cell $c $r $array($idx) + return +} + +# ::struct::matrix::MatTraceOut -- +# +# Helper propagating changes made to the matrix into the linked arrays. +# +# Arguments: +# avar Name of the array to write the changes to. +# name Matrix which was changed. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceOut {avar name var idx op} { + # Propagate changes in the matrix data array into the linked array. + + variable ${name}::unset + + if {![string compare $avar $unset]} { + # Do not change the variable currently unsetting + # one of its elements. + return + } + + variable ${name}::lock + set lock 1 ; # Disable MatTraceIn [#532783] + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + if {$unset != {}} { + # We are currently propagating the unset of an + # element in a different linked array to this + # array. We make sure that this is an unset too. + + unset array($c,$r) + } else { + set array($c,$r) $data($idx) + } + set lock 0 + return +} + +# ::struct::matrix::SortMaxHeapify -- +# +# Helper for the 'sort' method. Performs the central algorithm +# which converts the matrix into a heap, easily sortable. +# +# Arguments: +# name Matrix object which is sorted. +# i Index of the row/column currently being sorted. +# key Index of the column/row to sort the rows/columns by. +# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). +# heapSize Number of rows/columns to sort. +# rev Boolean flag, set if sorting is done revers (-decreasing). +# +# Sideeffects: +# Transforms the matrix into a heap of rows/columns, +# swapping them around. +# +# Results: +# None. + +proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { + # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 + switch $rowCol { + r { set A [GetColumn $name $key] } + c { set A [GetRow $name $key] } + } + # Weird expressions below for clarity, as CLRS uses A[1...n] + # format and TCL uses A[0...n-1] + set left [expr {int(2*($i+1) -1)}] + set right [expr {int(2*($i+1)+1 -1)}] + + # left, right are tested as < rather than <= because they are + # in A[0...n-1] + if { + $left < $heapSize && + ( !$rev && [lindex $A $left] > [lindex $A $i] || + $rev && [lindex $A $left] < [lindex $A $i] ) + } { + set largest $left + } else { + set largest $i + } + + if { + $right < $heapSize && + ( !$rev && [lindex $A $right] > [lindex $A $largest] || + $rev && [lindex $A $right] < [lindex $A $largest] ) + } { + set largest $right + } + + if { $largest != $i } { + switch $rowCol { + r { SwapRows $name $i $largest } + c { SwapColumns $name $i $largest } + } + SortMaxHeapify $name $largest $key $rowCol $heapSize $rev + } + return +} + +# ::struct::matrix::CheckSerialization -- +# +# Validate the serialization of a matrix. +# +# Arguments: +# ser Serialization to validate. +# rvar Variable to store the number of rows into. +# cvar Variable to store the number of columns into. +# dvar Variable to store the matrix data into. +# +# Results: +# none + +proc ::struct::matrix::CheckSerialization {ser rvar cvar dvar} { + upvar 1 \ + $rvar rows \ + $cvar columns \ + $dvar data + + # Overall length ok ? + if {[llength $ser] != 3} { + return -code error \ + "error in serialization: list length not 3." + } + + foreach {r c d} $ser break + + # Check rows/columns information + + if {![string is integer -strict $r] || ($r < 0)} { + return -code error \ + "error in serialization: bad number of rows \"$r\"." + } + if {![string is integer -strict $c] || ($c < 0)} { + return -code error \ + "error in serialization: bad number of columns \"$c\"." + } + + # Validate data against rows/columns. We can have less data than + # rows or columns, the missing cells will be initialized to the + # empty string. But too many is considered as a signal of + # being something wrong. + + if {[llength $d] > $r} { + return -code error \ + "error in serialization: data for to many rows." + } + foreach rv $d { + if {[llength $rv] > $c} { + return -code error \ + "error in serialization: data for to many columns." + } + } + + # Ok. The data is now ready for the caller. + + set data $d + set rows $r + set columns $c + return +} + +# ::struct::matrix::DeleteRows -- +# +# Deletes n rows from the bottom of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of rows to delete (no greater than the number of rows). +# +# Results: +# None. + +proc ::struct::matrix::DeleteRows {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + set rowstart [expr {$rows - $n}] + + for {set c 0} {$c < $columns} {incr c} { + for {set r $rowstart} {$r < $rows} {incr r} { + unset data($c,$r) + catch {unset rowh($r)} + } + catch {unset colw($c)} + } + set rows $rowstart + return +} + +# ::struct::matrix::DeleteColumns -- +# +# Deletes n columns from the right of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of columns to delete. +# +# Results: +# None. + +proc ::struct::matrix::DeleteColumns {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + set colstart [expr {$columns - $n}] + + for {set r 0} {$r < $rows} {incr r} { + for {set c $colstart} {$c < $columns} {incr c} { + unset data($c,$r) + catch {unset colw($c)} + } + catch {unset rowh($r)} + } + set columns $colstart + return +} + + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'matrix::matrix' into the general structure namespace. + namespace import -force matrix::matrix + namespace export matrix +} +package provide struct::matrix 2.0.3 diff --git a/tcllib/modules/struct/matrix.test b/tcllib/modules/struct/matrix.test new file mode 100644 index 0000000..ac25df5 --- /dev/null +++ b/tcllib/modules/struct/matrix.test @@ -0,0 +1,2314 @@ +# -*- tcl -*- +# matrix.test: tests for the matrix structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2001 by Andreas Kupries <a.kupries@westend.com> +# All rights reserved. +# +# RCS: @(#) $Id: matrix.test,v 1.21 2006/10/09 21:41:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + useLocalFile matrix.testsupport +} +testing { + useLocal matrix.tcl struct::matrix +} + +# ------------------------------------------------------------------------- + +namespace import struct::matrix + +#---------------------------------------------------------------------- +# Serialized matrix for some tests. + +set matdata {{2 0 f j} {c g b a} {a 02 01 3}} + +#---------------------------------------------------------------------- + +test matrix-0.1 {matrix errors} { + matrix mymatrix + catch {matrix mymatrix} msg + mymatrix destroy + set msg +} "command \"::mymatrix\" already exists, unable to create matrix" + +test matrix-0.2 {matrix errors} { + matrix mymatrix + catch {mymatrix} msg + mymatrix destroy + set msg +} "wrong # args: should be \"::mymatrix option ?arg arg ...?\"" + +test matrix-0.3 {matrix errors} { + matrix mymatrix + catch {mymatrix foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be -->, =, add, cells, cellsize, columns, columnwidth, delete, deserialize, destroy, format, get, insert, link, links, rowheight, rows, search, serialize, set, sort, swap, transpose, or unlink" + +test matrix-0.4 {matrix errors} { + matrix mymatrix + catch {mymatrix add foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, columns, row, or rows" + +test matrix-0.5 {matrix errors} { + matrix mymatrix + catch {mymatrix delete foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, columns, row, or rows" + +test matrix-0.6 {matrix errors} { + matrix mymatrix + catch {mymatrix get foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be cell, column, rect, or row" + +test matrix-0.7 {matrix errors} { + matrix mymatrix + catch {mymatrix set foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be cell, column, rect, or row" + +test matrix-0.8 {matrix errors} { + matrix mymatrix + catch {mymatrix format foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be 2chan, or 2string" + +test matrix-0.9 {matrix errors} { + matrix mymatrix + catch {mymatrix swap foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be columns, or rows" + +test matrix-0.10 {matrix errors} { + catch {matrix set} msg + set msg +} "command \"::set\" already exists, unable to create matrix" + +test matrix-0.11 {matrix errors} { + matrix mymatrix + catch {mymatrix set cell 0 0 foo} msg + mymatrix destroy + set msg +} {bad column index 0, column does not exist} + +test matrix-0.12 {matrix errors} { + matrix mymatrix + mymatrix add column + catch {mymatrix set cell 0 0 foo} msg + mymatrix destroy + set msg +} {bad row index 0, row does not exist} + +test matrix-0.13 {matrix errors} { + matrix mymatrix + catch {mymatrix insert foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, or row" + +test matrix-1.0 {create} { + set name [matrix] + set result [list $name [string equal [info commands $name] "$name"]] + $name destroy + set result +} [list ::matrix1 1] + + +test matrix-1.1 {columns, rows & cells} { + matrix mymatrix + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {0 0 0} + +test matrix-1.2 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {0 1 0} + +test matrix-1.3 {columns, rows & cells} { + matrix mymatrix + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {1 0 0} + +test matrix-1.4 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {1 1 1} + +test matrix-1.5 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + mymatrix add row + mymatrix add column + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {2 2 4} + +test matrix-2.0 {add error} { + matrix mymatrix + catch {mymatrix add} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix add option ?arg arg ...?"} + +test matrix-2.1 {add column, add row} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2} {3 4}} + +test matrix-2.2 {add column, add row} { + matrix mymatrix + mymatrix add column + mymatrix add row + mymatrix add column + mymatrix add row + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {}} {{} {}}} + +test matrix-2.3 {add columns, add rows} { + matrix mymatrix + mymatrix add columns 4 + mymatrix add rows 4 + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} + +test matrix-2.4 {add columns, add rows} { + matrix mymatrix + mymatrix add rows 4 + mymatrix add columns 4 + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} + +test matrix-2.5 {add columns, add rows} { + matrix mymatrix + catch {mymatrix add columns 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-2.6 {add columns, add rows} { + matrix mymatrix + catch {mymatrix add rows 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-2.7 {add column, add row, cut off} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2 5 6 7} + mymatrix add row {3 4 8 9 10} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2} {3 4}} + + + +test matrix-3.1 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + set result [list [mymatrix cellsize 0 0] [mymatrix columnwidth 1] [mymatrix rowheight 1]] + mymatrix destroy + set result +} {1 2 2} + +test matrix-3.2 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize -1 -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-3.3 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 5 -1} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-3.4 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 0 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-3.5 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 0 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-3.6 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix rowheight -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-3.7 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix rowheight 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-3.8 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix columnwidth -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-3.9 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix columnwidth 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + + +test matrix-3.10 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row [list "\033\[01;34mapps\033\[0m"] + set result [list [mymatrix cellsize 0 0] [mymatrix columnwidth 0] [mymatrix rowheight 0]] + mymatrix destroy + set result +} {16 4 1} + +test matrix-4.0 {delete error} { + matrix mymatrix + catch {mymatrix delete} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix delete option ?arg arg ...?"} + +test matrix-4.1 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2a} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\na"] + + set resa [list [mymatrix columnwidth 0]] + lappend resa [mymatrix columnwidth 1] + lappend resa [mymatrix columnwidth 2] + + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column 1 + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row 1 + lappend result [mymatrix get rect 0 0 end end] + + lappend resa [mymatrix columnwidth 0] + lappend resa [mymatrix columnwidth 1] + + mymatrix destroy + lappend result $resa + set result +} {{{1 2a 5} {3 4 6} {7 8 {9 +a}}} {{1 5} {3 6} {7 {9 +a}}} {{1 5} {7 {9 +a}}} {1 2 1 1 1}} + +test matrix-4.1a {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2a} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\na"] + + set resb [list [mymatrix rowheight 0]] + lappend resb [mymatrix rowheight 1] + lappend resb [mymatrix rowheight 2] + + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete row 1 + mymatrix delete column 1 + lappend result [mymatrix get rect 0 0 end end] + + lappend resb [mymatrix rowheight 0] + lappend resb [mymatrix rowheight 1] + + mymatrix destroy + lappend result $resb + set result +} {{{1 2a 5} {3 4 6} {7 8 {9 +a}}} {{1 5} {7 {9 +a}}} {1 1 2 1 2}} + +test matrix-4.2 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column 0 + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row 0 + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{1 2 5} {3 4 6} {7 8 9}} {{2 5} {4 6} {8 9}} {{4 6} {8 9}}} + +test matrix-4.3 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column end + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row end + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{1 2 5} {3 4 6} {7 8 9}} {{1 2} {3 4} {7 8}} {{1 2} {3 4}}} + +test matrix-4.4 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete column -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-4.5 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete column 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-4.6 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete row -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-4.7 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete row 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-4.8 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete rows 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-4.9 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete rows -1} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-4.10 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete rows 1} result + mymatrix destroy + set result +} {A value of n > #rows is not allowed} + +test matrix-4.11 {deletion of rows and columns} { + matrix mymatrix + mymatrix add rows 2 + catch {mymatrix delete rows 3} result + mymatrix destroy + set result +} {A value of n > #rows is not allowed} + +test matrix-4.12 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete columns 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-4.13 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete columns -1} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix-4.14 {deletion of rows and columns} { + matrix mymatrix + catch {mymatrix delete columns 1} result + mymatrix destroy + set result +} {A value of n > #columns is not allowed} + +test matrix-4.15 {deletion of rows and columns} { + matrix mymatrix + mymatrix add rows 2 + catch {mymatrix delete columns 3} result + mymatrix destroy + set result +} {A value of n > #columns is not allowed} + +test matrix-4.16 {deletion of rows and columns} { + matrix mymatrix + mymatrix add rows 2 + mymatrix add columns 3 + mymatrix set rect 0 0 {{a b c} {d e f}} + mymatrix delete rows 1 + set result [mymatrix get rect 0 0 2 0] + mymatrix destroy + set result +} {{a b c}} + +test matrix-4.17 {deletion of rows and columns} { + matrix mymatrix + mymatrix add rows 2 + mymatrix add columns 3 + mymatrix set rect 0 0 {{a b c} {d e f}} + mymatrix delete columns 1 + set result [mymatrix get rect 0 0 1 1] + mymatrix destroy + set result +} {{a b} {d e}} + +test matrix-4.18 {deletion of rows and columns} { + matrix mymatrix + mymatrix add rows 2 + mymatrix add columns 3 + mymatrix set rect 0 0 {{a b c} {d e f}} + mymatrix delete rows 1 + mymatrix delete columns 1 + set result [mymatrix get rect 0 0 1 0] + mymatrix destroy + set result +} {{a b}} + + +test matrix-5.0 {format error} { + matrix mymatrix + catch {mymatrix format} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix format option ?arg arg ...?"} + +test matrix-5.1 {formatting} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix format 2string tclformat] + mymatrix destroy + set result +} "# ::mymatrix 3 x 3 +matrix ::mymatrix +::mymatrix add rows 3 +::mymatrix add columns 3 +::mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" + +test matrix-5.2 {internal format} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix format 2string] + mymatrix destroy + set result +} "1 2 5\n3 4 6\n7 8 9" + +test matrix-5.3 {internal format} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3a 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\nb"] + set result [mymatrix format 2string] + mymatrix destroy + set result +} "1 2 5\n3a 4 6\n7 8 9\n b" + +if {![catch {package require memchan}]} { + # We have memory channels and can therefore test + # 'format2channel-via' too. + + test matrix-5.4 {formatting} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + set chan [memchan] + mymatrix format 2chan tclformat $chan + mymatrix destroy + + seek $chan 0 + set result [read $chan] + close $chan + set result + } "# mymatrix 3 x 3 +matrix mymatrix +mymatrix add rows 3 +mymatrix add columns 3 +mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" +} + +test matrix-6.0 {set/get error} { + matrix mymatrix + catch {mymatrix set} msga + catch {mymatrix get} msgb + mymatrix destroy + list $msga $msgb +} {{wrong # args: should be "::mymatrix set option ?arg arg ...?"} {wrong # args: should be "::mymatrix get option ?arg arg ...?"}} + +test matrix-6.1 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get cell 0 2] + mymatrix destroy + set result +} 7 + +test matrix-6.2 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get column 1] + mymatrix destroy + set result +} {2 4 8} + +test matrix-6.3 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get row 2] + mymatrix destroy + set result +} {7 8 9} + +test matrix-6.4 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get rect 1 1 end end] + mymatrix destroy + set result +} {{4 6} {8 9}} + +test matrix-6.5 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set cell 0 2 foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {foo 8 9}} + +test matrix-6.6 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b c} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 c 9}} + +test matrix-6.7 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz nex} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz nex}} + +test matrix-6.8 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect 1 1 {{c d} {e f}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 c d} {7 e f}} + +test matrix-6.9 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 {} 9}} + +test matrix-6.10 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b c d e f} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 c 9}} + +test matrix-6.11 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz {}}} + +test matrix-6.12 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz nex floz} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz nex}} + +test matrix-6.13 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect 1 1 {{c d e} {f g h} {i j k}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 c d} {7 f g}} + +test matrix-6.14 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect -1 -1 {{c d e} {f g h} {i j k}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{g h 5} {j k 6} {7 8 9}} + +test matrix-6.15 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell -1 2} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-6.16 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 5 2} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.17 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 0 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-6.18 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 0 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-6.19 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get column -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-6.20 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get column 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.21 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get row -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-6.22 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get row 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-6.23 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect -1 1 end end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-6.24 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 5 1 end end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.25 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 -1 end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-6.26 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 5 end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.27 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 -1 end end} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-6.28 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 5 end end} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-6.29 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 end -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-6.30 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 end 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-6.31 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set column -1 {a b c}} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-6.32 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set column 5 {a b c}} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.33 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set row -1 {a b c}} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-6.34 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set row 5 {a b c}} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-6.35 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set rect 5 1 {{a b} {c d}}} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-6.36 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set rect 1 5 {{a b} {c d}}} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + + +test matrix-6.43 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect end end 1 1} result + mymatrix destroy + set result +} {Invalid cell indices, wrong ordering} + +test matrix-6.44 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix set cell 0 0 foo + set result [list [mymatrix get rect 0 0 end end]] + mymatrix set cell 0 0 foo + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {foo foo} + + + + +test matrix-7.0 {swap error} { + matrix mymatrix + catch {mymatrix swap} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix swap option ?arg arg ...?"} + +test matrix-7.1 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix swap columns 1 end + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 5 2} {3 6 4} {7 9 8}} + +test matrix-7.2 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix swap rows 1 end + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {7 8 9} {3 4 6}} + +test matrix-7.3 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns -1 end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-7.4 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 5 end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-7.5 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 1 -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix-7.6 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 1 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix-7.7 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows -1 end} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-7.8 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 5 end} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-7.9 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 1 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix-7.10 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 1 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix-8.0 {insert error} { + matrix mymatrix + catch {mymatrix insert} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix insert option ?arg arg ...?"} + +test matrix-8.1 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 0 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} + +test matrix-8.2 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 2 5} {3 b 4 6} {7 c 8 9}} + +test matrix-8.3 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column end {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} + +test matrix-8.4 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 3 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} + +test matrix-8.5 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column -1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} + + +test matrix-8.6 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 0 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a b c} {1 2 5} {3 4 6} {7 8 9}} + +test matrix-8.7 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {a b c} {3 4 6} {7 8 9}} + +test matrix-8.8 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row end {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {7 8 9} {a b c}} + +test matrix-8.9 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 3 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {7 8 9} {a b c}} + +test matrix-8.10 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row -1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a b c} {1 2 5} {3 4 6} {7 8 9}} + +test matrix-8.11 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix insert row 1 {1} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {1} + +test matrix-8.12 {insertion} { + matrix mymatrix + mymatrix add row + mymatrix insert column 1 {1} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {1} + +test matrix-9.0 {link errors} { + matrix mymatrix + catch {mymatrix link} msg + mymatrix destroy + set msg +} {::mymatrix: wrong # args: link ?-transpose? arrayvariable} + +test matrix-9.1 {link errors} { + matrix mymatrix + catch {mymatrix link 1 2 3} msg + mymatrix destroy + set msg +} {::mymatrix: wrong # args: link ?-transpose? arrayvariable} + +test matrix-9.2 {link errors} { + matrix mymatrix + catch {mymatrix link foo 2} msg + mymatrix destroy + set msg +} {::mymatrix: illegal syntax: link ?-transpose? arrayvariable} + +test matrix-9.3 {link errors} { + matrix mymatrix + mymatrix link foo + catch {mymatrix link foo} msg + mymatrix destroy + set msg +} {::mymatrix link: Variable "foo" already linked to matrix} + +test matrix-9.4 {linking, initial transfer} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set result [dictsort [array get a]] + mymatrix destroy + set result +} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9} + +test matrix-9.5 {linking, initial transfer} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link -transpose a + set result [dictsort [array get a]] + mymatrix destroy + set result +} {0,0 1 0,1 2 0,2 5 1,0 3 1,1 4 1,2 6 2,0 7 2,1 8 2,2 9} + + +test matrix-9.6 {linking, trace array -> matrix} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set a(1,0) foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 foo 5} {3 4 6} {7 8 9}} + +test matrix-9.7 {linking, trace array -> matrix} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link -transpose a + set a(1,0) foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {foo 4 6} {7 8 9}} + +test matrix-9.8 {linking, trace and unlink} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set a(1,0) foo + set result [list [mymatrix get rect 0 0 end end]] + mymatrix unlink a + set a(1,0) 2 + lappend result [dictsort [array get a]] + mymatrix destroy + set result +} {{{1 foo 5} {3 4 6} {7 8 9}} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9}} + +test matrix-9.9 {linking} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + catch {set a(1,5) foo} result + mymatrix destroy + set result +} {can't set "a(1,5)": bad row index 5, row does not exist} + +test matrix-9.10 {unlink unknown} { + matrix mymatrix + set result [list [mymatrix links]] + mymatrix unlink foo + lappend result [mymatrix links] + mymatrix destroy + set result +} {{} {}} + +test matrix-9.11 {auto unlink} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set result [list [mymatrix links]] + unset a + lappend result [mymatrix links] + mymatrix destroy + set result +} {a {}} + +test matrix-9.12 {unset in linked array} { + matrix mymatrix + mymatrix add columns 3 + mymatrix add row {1 2 3} + mymatrix add row {a b c} + + catch {unset a} + mymatrix link a + + set result [list] + lappend result [dictsort [array get a]] + unset a(0,0) + lappend result [mymatrix get rect 0 0 end end] + + mymatrix destroy + set result +} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {{{} 2 3} {a b c}}} + +test matrix-9.12a {unset in linked array} { + matrix mymatrix + mymatrix add columns 3 + mymatrix add row {1 2 3} + mymatrix add row {a b c} + + catch {unset a} + mymatrix link a + catch {unset b} + mymatrix link b + + set result [list] + lappend result [dictsort [array get a]] + unset a(0,0) + lappend result [dictsort [array get b]] + + mymatrix destroy + set result +} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {0,1 a 1,0 2 1,1 b 2,0 3 2,1 c}} + +test matrix-9.13 {operation on linked matrix} { + catch {unset a} + matrix mymatrix + mymatrix add columns 4 + mymatrix add row {1 2 3} + mymatrix link a + mymatrix add row {a b c d} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 3 {}} {a b c d}} + +test matrix-10.1 {search errors} { + matrix mymatrix + catch {mymatrix search} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix-10.2 {search errors} { + matrix mymatrix + catch {mymatrix search 1} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix-10.3 {search errors} { + matrix mymatrix + catch {mymatrix search 1 2 3 4 5} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix-10.4 {search errors} { + matrix mymatrix + catch {mymatrix search 1 2 3 4 5 6 7 8} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix-10.5 {search errors} { + matrix mymatrix + catch {mymatrix search -foo 2 3 4} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -nocase, -exact, -glob, or -regexp} + +test matrix-10.6 {search errors} { + matrix mymatrix + catch {mymatrix search -exact foo 3 4} msg + mymatrix destroy + set msg +} {invalid range spec "foo": should be all, column, row, or rect} + +test matrix-10.7 {search errors} { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + catch {mymatrix search -exact rect 4 0 2 1 foo} msg + mymatrix destroy + set msg +} {Invalid cell indices, wrong ordering} + +test matrix-10.8 {search errors} { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + catch {mymatrix search -exact rect 2 1 4 0 foo} msg + mymatrix destroy + set msg +} {Invalid cell indices, wrong ordering} + + +test matrix-10.9 "searching, default" { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + set result [mymatrix search row 2 b] + mymatrix destroy + set result +} {{1 2}} + +foreach {n mode range pattern result} { + 10 -exact {all} {ab} {{0 3}} + 11 -glob {all} {a*} {{0 2} {0 3}} + 12 -regexp {all} {b.} {{1 3}} + 13 -exact {row 2} {b} {{1 2}} + 14 -glob {row 3} {b*} {{1 3}} + 15 -regexp {row 4} {d} {{0 4} {1 4}} + 16 -exact {column 2} {c} {{2 2}} + 17 -glob {column 0} {a*} {{0 2} {0 3}} + 18 -regexp {column 1} {b.*} {{1 2} {1 3}} + 19 -exact {rect 1 1 3 3} {c} {{2 2}} + 20 -glob {rect 1 1 3 3} {b*} {{1 2} {1 3}} + 21 -regexp {rect 1 1 3 3} {b.*} {{1 2} {1 3}} + 22 -nocase {rect 1 1 3 3} {C} {{2 2}} +} { + test matrix-10.$n "searching ($mode $range $pattern)" { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + set result [eval mymatrix search $mode $range $pattern] + mymatrix destroy + set result + } $result ; # {} +} + + +test matrix-11.0 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort} msg + mymatrix destroy + set msg +} [tcltest::wrongNumArgs {::struct::matrix::_sort} {name cmd args} 1] + +test matrix-11.1 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort} msg + mymatrix destroy + set msg +} [tcltest::wrongNumArgs {::struct::matrix::_sort} {name cmd args} 1] + +test matrix-11.2 {sorting matrices: bad method} { + matrix mymatrix + catch {mymatrix sort foo} msg + mymatrix destroy + set msg +} {bad option "foo": must be columns, or rows} + +test matrix-11.3 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort rows} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix sort option ?arg arg ...?"} + +test matrix-11.4 {sorting matrices: to many arguments} { + matrix mymatrix + catch {mymatrix sort rows foo bar} msg + mymatrix destroy + set msg +} {invalid option "foo": should be -increasing, or -decreasing} + +test matrix-11.5 {sorting matrices: bad option} { + matrix mymatrix + catch {mymatrix sort rows -foo bar} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -increasing, or -decreasing} + +test matrix-11.6 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort columns} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix sort option ?arg arg ...?"} + +test matrix-11.7 {sorting matrices: to many arguments} { + matrix mymatrix + catch {mymatrix sort columns foo bar} msg + mymatrix destroy + set msg +} {invalid option "foo": should be -increasing, or -decreasing} + +test matrix-11.8 {sorting matrices: bad option} { + matrix mymatrix + catch {mymatrix sort columns -foo bar} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -increasing, or -decreasing} + +test matrix-11.9 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows -1} msg + mymatrix destroy + set msg +} {bad column index -1, column does not exist} + +test matrix-11.10 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows 4} msg + mymatrix destroy + set msg +} {bad column index 4, column does not exist} + +test matrix-11.11 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows foo} msg + mymatrix destroy + set msg +} {bad column index "foo", syntax error} + +test matrix-11.12 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns -1} msg + mymatrix destroy + set msg +} {bad row index -1, row does not exist} + +test matrix-11.13 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns 3} msg + mymatrix destroy + set msg +} {bad row index 3, row does not exist} + +test matrix-11.14 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns foo} msg + mymatrix destroy + set msg +} {bad row index "foo", syntax error} + + +foreach {n cmd res resd} { + 1 {rows 0} {{2 0 f j} {a 02 01 3} {c g b a}} {{c g b a} {a 02 01 3} {2 0 f j}} + 2 {rows 1} {{2 0 f j} {a 02 01 3} {c g b a}} {{c g b a} {a 02 01 3} {2 0 f j}} + 3 {rows 2} {{a 02 01 3} {c g b a} {2 0 f j}} {{2 0 f j} {c g b a} {a 02 01 3}} + 4 {rows 3} {{a 02 01 3} {c g b a} {2 0 f j}} {{2 0 f j} {c g b a} {a 02 01 3}} + 5 {columns 0} {{0 2 f j} {g c b a} {02 a 01 3}} {{j f 2 0} {a b c g} {3 01 a 02}} + 6 {columns 1} {{j f 2 0} {a b c g} {3 01 a 02}} {{0 2 f j} {g c b a} {02 a 01 3}} + 7 {columns 2} {{f 0 j 2} {b g a c} {01 02 3 a}} {{2 j 0 f} {c a g b} {a 3 02 01}} +} { + test matrix-12.$n "sorting matrices: $cmd" { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + mymatrix set rect 0 0 $matdata + eval [list mymatrix sort] $cmd + set result [mymatrix get rect 0 0 3 2] + mymatrix destroy + set result + } $res + + test matrix-13.$n "sorting matrices: $cmd, -decreasing" { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + mymatrix set rect 0 0 $matdata + eval [linsert [linsert $cmd 1 -decreasing] 0 mymatrix sort] + set result [mymatrix get rect 0 0 3 2] + mymatrix destroy + set result + } $resd +} + +test matrix-14.0 {transposition} { + matrix mymatrix + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns]] + mymatrix destroy + set result +} {0 0} + +test matrix-14.1 {transposition} { + matrix mymatrix + mymatrix add rows 2 + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns]] + mymatrix destroy + set result +} {0 2} + +test matrix-14.2 {transposition} { + matrix mymatrix + mymatrix add columns 2 + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns]] + mymatrix destroy + set result +} {2 0} + +test matrix-14.3 {transposition} { + matrix mymatrix + mymatrix add rows 2 + mymatrix add columns 3 + mymatrix set rect 0 0 {{a b c} {d e f}} + + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns] [mymatrix get rect 0 0 1 2]] + mymatrix destroy + set result +} {3 2 {{a d} {b e} {c f}}} + +test matrix-14.4 {transposition} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 2 + mymatrix set rect 0 0 {{a d} {b e} {c f}} + + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns] [mymatrix get rect 0 0 2 1]] + mymatrix destroy + set result +} {2 3 {{a b c} {d e f}}} + +test matrix-14.5 {transposition} { + matrix mymatrix + mymatrix add rows 2 + mymatrix add columns 2 + mymatrix set rect 0 0 {{a b} {d e}} + + mymatrix transpose + set result [list [mymatrix rows] [mymatrix columns] [mymatrix get rect 0 0 1 1]] + mymatrix destroy + set result +} {2 2 {{a d} {b e}}} + + + +############################################################ +# V. Objects to values and back ... +# - serialize deserialize = --> +############################################################ + +test matrix-15.0 {serialization, bogus rectangle} { + matrix mymatrix + catch {mymatrix serialize 1 1 3 3} result + mymatrix destroy + set result +} {bad column index 1, column does not exist} + +test matrix-15.1 {serialization, all} { + matrix mymatrix + mymatrix add columns 4 + mymatrix add rows 3 + mymatrix set rect 0 0 $matdata + + set serial [mymatrix serialize] + set result [validate_serial mymatrix $serial] + mymatrix destroy + set result + + # set serial = + # {3 4 {{2 0 f j} {c g b a} {a 02 01 3}}} +} ok + +test matrix-15.2 {serialization, submatrix} { + matrix mymatrix + mymatrix add columns 4 + mymatrix add rows 3 + mymatrix set rect 0 0 $matdata + + set serial [mymatrix serialize 1 1 2 2] + set result [validate_serial mymatrix $serial {1 1 2 2}] + mymatrix destroy + set result + + # set serial = + # {2 2 {{g b} {02 01}}} +} ok + +# --------------------------------------------------- + +test matrix-16.0 {deserialization, wrong #args} { + matrix mymatrix + catch {mymatrix deserialize foo bar} result + mymatrix destroy + set result +} [tcltest::tooManyArgs {::struct::matrix::_deserialize} {name serial}] + +test matrix-16.1 {deserialization} { + matrix mymatrix + set serial {3 4} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: list length not 3.}} + +test matrix-16.2 {deserialization} { + matrix mymatrix + set serial {1 1 {{1}} .} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: list length not 3.}} + +test matrix-16.3 {deserialization} { + matrix mymatrix + set serial {. 1 {}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: bad number of rows ".".}} + +test matrix-16.4 {deserialization} { + matrix mymatrix + set serial {-1 1 {}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: bad number of rows "-1".}} + +test matrix-16.5 {deserialization} { + matrix mymatrix + set serial {1 . {}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: bad number of columns ".".}} + +test matrix-16.6 {deserialization} { + matrix mymatrix + set serial {1 -1 {}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: bad number of columns "-1".}} + +test matrix-16.7 {deserialization} { + matrix mymatrix + set serial {2 2 {{a b} {c d} {e f}}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: data for to many rows.}} + +test matrix-16.8 {deserialization} { + matrix mymatrix + set serial {2 2 {{a b} {c d e}}} + set fail [catch {mymatrix deserialize $serial} result] + mymatrix destroy + list $fail $result +} {1 {error in serialization: data for to many columns.}} + +test matrix-16.9 {deserialization} { + matrix mymatrix + + # Our check of the success of the deserialization + # is to validate the generated matrix against the + # serialized data. + + set serial {4 3 {{a b c} {d e} {f}}} + + set result [list] + lappend result [validate_serial mymatrix $serial] + + mymatrix deserialize $serial + lappend result [validate_serial mymatrix $serial] + mymatrix destroy + set result +} {dim/row-mismatch ok} + +test matrix-16.10 {deserialization} { + matrix mymatrix + + # Our check of the success of the deserialization + # is to validate the generated matrix against the + # serialized data. + + # Applying to serialization one after the + # other. Checking that the second operation + # completely squashes the data from the first. + + set seriala {4 3 {{a b c} {d e} {f}}} + set serialb {2 2 {{. /} {= %}}} + + set result [list] + lappend result [validate_serial mymatrix $seriala] + lappend result [validate_serial mymatrix $serialb] + + mymatrix deserialize $seriala + lappend result [validate_serial mymatrix $seriala] + lappend result [validate_serial mymatrix $serialb] + + mymatrix deserialize $serialb + lappend result [validate_serial mymatrix $seriala] + lappend result [validate_serial mymatrix $serialb] + + mymatrix destroy + set result +} {dim/row-mismatch dim/row-mismatch ok dim/row-mismatch dim/row-mismatch ok} + +# --------------------------------------------------- + +test matrix-17.1 {matrix assignment} { + matrix mymatrix + catch {mymatrix = foo bar} result + mymatrix destroy + set result +} [tcltest::tooManyArgs {::struct::matrix::_=} {name source}] + +test matrix-17.2 {matrix assignment} { + set serial {2 2 {{. /} {= %}}} + + matrix mymatrix + matrix bmatrix + + mymatrix deserialize $serial + + set result [validate_serial bmatrix $serial] + bmatrix = mymatrix + lappend result [validate_serial bmatrix $serial] + + mymatrix destroy + bmatrix destroy + set result +} {dim/row-mismatch ok} + +# --------------------------------------------------- + +test matrix-18.1 {reverse matrix assignment} { + matrix mymatrix + catch {mymatrix --> foo bar} result + mymatrix destroy + set result +} [tcltest::tooManyArgs {::struct::matrix::_-->} {name dest}] + +test matrix-18.2 {reverse matrix assignment} { + + set serial {4 3 {{a b c} {d e} {f}}} + + matrix mymatrix + matrix bmatrix + + mymatrix deserialize $serial + + set result [validate_serial bmatrix $serial] + mymatrix --> bmatrix + lappend result [validate_serial bmatrix $serial] + + mymatrix destroy + bmatrix destroy + set result +} {dim/row-mismatch ok} + +# --------------------------------------------------- + +test matrix-19.1 {copy construction, wrong # args} { + catch {matrix mymatrix = a b} result + set result +} {wrong # args: should be "matrix ?name ?=|:=|as|deserialize source??"} + +test matrix-19.2 {copy construction, unknown operator} { + catch {matrix mymatrix foo a} result + set result +} {wrong # args: should be "matrix ?name ?=|:=|as|deserialize source??"} + +test matrix-19.3 {copy construction, value} { + set serial {4 3 {{a b c} {d e} {f}}} + + matrix mymatrix deserialize $serial + set result [validate_serial mymatrix $serial] + mymatrix destroy + + set result +} ok + +test matrix-19.4 {copy construction, matrix} { + set serial {4 3 {{a b c} {d e} {f}}} + + matrix mymatrix deserialize $serial + matrix bmatrix = mymatrix + + set result [validate_serial bmatrix $serial] + mymatrix destroy + bmatrix destroy + + set result +} ok + +# --------------------------------------------------- + +# Future tests: query rowheight, column width before and after delete +# row/column to ascertain that the cached values are correctly +# shifted. + +# Test 'format 2chan', have to redirect a channel for this. + +# Future: Tests involving cached information (row heights, col widths) +# should use special commands to peek at the cache only, without +# recalculation. + +testsuiteCleanup + diff --git a/tcllib/modules/struct/matrix.testsupport b/tcllib/modules/struct/matrix.testsupport new file mode 100644 index 0000000..0d50e5e --- /dev/null +++ b/tcllib/modules/struct/matrix.testsupport @@ -0,0 +1,116 @@ +# -*- tcl -*- +# Testsuite utilities specific to struct::matrix, v1 and v2. +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### +## "report object" to test the format methods. +## v1/v2 + +proc tclformat {cmd matrix {chan stdout}} { + switch -exact -- $cmd { + printmatrix { + set r [$matrix rows] + set c [$matrix rows] + set out [list "# $matrix $c x $r"] + lappend out "matrix $matrix" + lappend out "$matrix add rows $r" + lappend out "$matrix add columns $c" + lappend out "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]" + return [join $out \n] + } + printmatrix2channel { + set r [$matrix rows] + set c [$matrix rows] + puts $chan "# $matrix $c x $r" + puts $chan "matrix $matrix" + puts $chan "$matrix add rows $r" + puts $chan "$matrix add columns $c" + puts $chan "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]" + return "" + } + default { + return -code error "Unknown method $cmd" + } + } +} + +# ### ### ### ######### ######### ######### +## Validation of the serialization of a matrix object against the +## object. +## v2 only. + +proc validate_serial {m serial {rect {}}} { + # Need a list with length 3. + + if {[llength $serial] != 3} { + return serial/wrong#elements + } + + foreach {r c d} $serial break + + # Check dimensions against source + + if {$rect == {}} { + set ro [$m rows] + set co [$m columns] + + set ctl 0 ; set cbr $co ; incr cbr -1 + set rtl 0 ; set rbr $ro ; incr rbr -1 + } else { + foreach {ctl rtl cbr rbr} $rect break + set ro [expr {$rbr - $rtl + 1}] + set co [expr {$cbr - $ctl + 1}] + } + if {$r != $ro} { + return dim/row-mismatch + } + if {$c != $co} { + return dim/column-mismatch + } + + # Check cell data size against dimensions. + + if {[llength $d] > $r} { + return data/rows/to-many + } + foreach rv $d { + if {[llength $rv] > $c} { + return data/columns/to-many + } + } + + # Check cell data against matrix itself, + # possibly offset to the chosen rectangle. + + set r $rtl + foreach rv $d { + set c $ctl + foreach cv $rv { + if {![string equal [$m get cell $c $r] $cv]} { + return data/cell/$c/$r/content-mismatch + } + incr c + } + while {$c < $cbr} { + # Empty cell to the right, check that they are truly empty + if {[$m get cell $c $r] != {}} { + return data/cell/$c/$r/not-empty/missing-from-serial + } + incr c + } + incr r + } + while {$r < $rbr} { + # Empty row at the bottom, check that they are truly empty + for {set c $ctl} {$c < $cbr} {incr c} { + if {[$m get cell $c $r] != {}} { + return data/cell/$c/$r/not-empty/missing-from-serial + } + } + incr r + } + + return ok +} + +# ### ### ### ######### ######### ######### diff --git a/tcllib/modules/struct/matrix1.man b/tcllib/modules/struct/matrix1.man new file mode 100644 index 0000000..78ce4d3 --- /dev/null +++ b/tcllib/modules/struct/matrix1.man @@ -0,0 +1,381 @@ +[comment {-*- tcl -*-}] +[manpage_begin {struct::matrix_v1} n 1.2.1] +[keywords matrix] +[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate matrix objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::matrix [opt 1.2.1]] +[description] +[para] + +The [cmd ::struct::matrix] command creates a new matrix object with an +associated global Tcl command whose name is [arg matrixName]. This +command may be used to invoke various operations on the matrix. It has +the following general form: + +[list_begin definitions] +[call [cmd matrixName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] + +[para] + +A matrix is a rectangular collection of cells, i.e. organized in rows +and columns. Each cell contains exactly one value of arbitrary +form. The cells in the matrix are addressed by pairs of integer +numbers, with the first (left) number in the pair specifying the +column and the second (right) number specifying the row the cell is +in. These indices are counted from 0 upward. The special non-numeric +index [const end] refers to the last row or column in the matrix, +depending on the context. Indices of the form + +[const end]-[var number] are counted from the end of the row or +column, like they are for standard Tcl lists. Trying to access +non-existing cells causes an error. + +[para] + +The matrices here are created empty, i.e. they have neither rows nor +columns. The user then has to add rows and columns as needed by his +application. A specialty of this structure is the ability to export an +array-view onto its contents. Such can be used by tkTable, for +example, to link the matrix into the display. + +[para] + +The following commands are possible for matrix objects: + +[list_begin definitions] + +[call [arg matrixName] [method {add column}] [opt [arg values]]] + +Extends the matrix by one column and then acts like [method setcolumn] +(see below) on this new column if there were [arg values] +supplied. Without [arg values] the new cells will be set to the empty +string. The new column is appended immediately behind the last +existing column. + +[call [arg matrixName] [method {add row}] [opt [arg values]]] + +Extends the matrix by one row and then acts like [method setrow] (see +below) on this new row if there were [arg values] supplied. Without +[arg values] the new cells will be set to the empty string. The new +row is appended immediately behind the last existing row. + +[call [arg matrixName] [method {add columns}] [arg n]] + +Extends the matrix by [arg n] columns. The new cells will be set to +the empty string. The new columns are appended immediately behind the +last existing column. A value of [arg n] equal to or smaller than 0 is +not allowed. + +[call [arg matrixName] [method {add rows}] [arg n]] + +Extends the matrix by [arg n] rows. The new cells will be set to the +empty string. The new rows are appended immediately behind the last +existing row. A value of [arg n] equal to or smaller than 0 is not +allowed. + +[call [arg matrixName] [method cells]] + +Returns the number of cells currently managed by the matrix. This is +the product of [method rows] and [method columns]. + +[call [arg matrixName] [method cellsize] [arg {column row}]] + +Returns the length of the string representation of the value currently +contained in the addressed cell. + +[call [arg matrixName] [method columns]] + +Returns the number of columns currently managed by the matrix. + +[call [arg matrixName] [method columnwidth] [arg column]] + +Returns the length of the longest string representation of all the +values currently contained in the cells of the addressed column if +these are all spanning only one line. For cell values spanning +multiple lines the length of their longest line goes into the +computation. + +[call [arg matrixName] [method {delete column}] [arg column]] + +Deletes the specified column from the matrix and shifts all columns +with higher indices one index down. + +[call [arg matrixName] [method {delete row}] [arg row]] + +Deletes the specified row from the matrix and shifts all row with +higher indices one index down. + +[call [arg matrixName] [method destroy]] + +Destroys the matrix, including its storage space and associated +command. + +[call [arg matrixName] [method {format 2string}] [opt [arg report]]] + +Formats the matrix using the specified report object and returns the +string containing the result of this operation. The report has to +support the [method printmatrix] method. If no [arg report] is +specified the system will use an internal report definition to format +the matrix. + +[call [arg matrixName] [method {format 2chan}] [opt "[opt [arg report]] [arg channel]"]] + +Formats the matrix using the specified report object and writes the +string containing the result of this operation into the channel. The +report has to support the [method printmatrix2channel] method. If no +[arg report] is specified the system will use an internal report +definition to format the matrix. If no [arg channel] is specified the +system will use [const stdout]. + +[call [arg matrixName] [method {get cell}] [arg {column row}]] + +Returns the value currently contained in the cell identified by row +and column index. + +[call [arg matrixName] [method {get column}] [arg column]] + +Returns a list containing the values from all cells in the column +identified by the index. The contents of the cell in row 0 are stored +as the first element of this list. + +[call [arg matrixName] [method {get rect}] [arg {column_tl row_tl column_br row_br}]] + +Returns a list of lists of cell values. The values stored in the +result come from the sub-matrix whose top-left and bottom-right cells +are specified by [arg {column_tl, row_tl}] and + +[arg {column_br, row_br}] resp. Note that the following equations have +to be true: "[arg column_tl] <= [arg column_br]" and "[arg row_tl] <= +[arg row_br]". The result is organized as follows: The outer list is +the list of rows, its elements are lists representing a single +row. The row with the smallest index is the first element of the outer +list. The elements of the row lists represent the selected cell +values. The cell with the smallest index is the first element in each +row list. + +[call [arg matrixName] [method {get row}] [arg row]] + +Returns a list containing the values from all cells in the row +identified by the index. The contents of the cell in column 0 are +stored as the first element of this list. + +[call [arg matrixName] [method {insert column}] [arg column] [opt [arg values]]] + +Extends the matrix by one column and then acts like [method setcolumn] +(see below) on this new column if there were [arg values] +supplied. Without [arg values] the new cells will be set to the empty +string. The new column is inserted just before the column specified by +the given index. This means, if [arg column] is less than or equal to +zero, then the new column is inserted at the beginning of the matrix, +before the first column. If [arg column] has the value [const end], +or if it is greater than or equal to the number of columns in the +matrix, then the new column is appended to the matrix, behind the last +column. The old column at the chosen index and all columns with higher +indices are shifted one index upward. + +[call [arg matrixName] [method {insert row}] [arg row] [opt [arg values]]] + +Extends the matrix by one row and then acts like [method setrow] (see +below) on this new row if there were [arg values] supplied. Without +[arg values] the new cells will be set to the empty string. The new +row is inserted just before the row specified by the given index. This +means, if [arg row] is less than or equal to zero, then the new row is +inserted at the beginning of the matrix, before the first row. If + +[arg row] has the value [const end], or if it is greater than or +equal to the number of rows in the matrix, then the new row is +appended to the matrix, behind the last row. The old row at that index +and all rows with higher indices are shifted one index upward. + +[call [arg matrixName] [method link] [opt -transpose] [arg arrayvar]] + +Links the matrix to the specified array variable. This means that the +contents of all cells in the matrix is stored in the array too, with +all changes to the matrix propagated there too. The contents of the +cell [arg (column,row)] is stored in the array using the key + +[arg column,row]. If the option [option -transpose] is specified the +key [arg row,column] will be used instead. It is possible to link the +matrix to more than one array. Note that the link is bidirectional, +i.e. changes to the array are mirrored in the matrix too. + +[call [arg matrixName] [method links]] + +Returns a list containing the names of all array variables the matrix +was linked to through a call to method [method link]. + +[call [arg matrixName] [method rowheight] [arg row]] + +Returns the height of the specified row in lines. This is the highest +number of lines spanned by a cell over all cells in the row. + +[call [arg matrixName] [method rows]] + +Returns the number of rows currently managed by the matrix. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method all] [arg pattern]] + +Searches the whole matrix for cells matching the [arg pattern] and +returns a list with all matches. Each item in the aforementioned list +is a list itself and contains the column and row index of the matching +cell, in this order. The results are ordered by column first and row +second, both times in ascending order. This means that matches to the +left and the top of the matrix come before matches to the right and +down. + +[para] + +The type of the pattern (string, glob, regular expression) is +determined by the option after the [method search] keyword. If no +option is given it defaults to [option -exact]. + +[para] + +If the option [option -nocase] is specified the search will be +case-insensitive. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method column] [arg {column pattern}]] + +Like [method {search all}], but the search is restricted to the +specified column. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method row] [arg {row pattern}]] + +Like [method {search all}], but the search is restricted to the +specified row. + +[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method rect] [arg {column_tl row_tl column_br row_br pattern}]] + +Like [method {search all}], but the search is restricted to the +specified rectangular area of the matrix. + +[call [arg matrixName] [method {set cell}] [arg {column row value}]] + +Sets the value in the cell identified by row and column index to the +data in the third argument. + +[call [arg matrixName] [method {set column}] [arg {column values}]] + +Sets the values in the cells identified by the column index to the +elements of the list provided as the third argument. Each element of +the list is assigned to one cell, with the first element going into +the cell in row 0 and then upward. If there are less values in the +list than there are rows the remaining rows are set to the empty +string. If there are more values in the list than there are rows the +superfluous elements are ignored. The matrix is not extended by this +operation. + +[call [arg matrixName] [method {set rect}] [arg {column row values}]] + +Takes a list of lists of cell values and writes them into the +submatrix whose top-left cell is specified by the two indices. If the +sublists of the outerlist are not of equal length the shorter sublists +will be filled with empty strings to the length of the longest +sublist. If the submatrix specified by the top-left cell and the +number of rows and columns in the [arg values] extends beyond the +matrix we are modifying the over-extending parts of the values are +ignored, i.e. essentially cut off. This subcommand expects its input +in the format as returned by [method getrect]. + +[call [arg matrixName] [method {set row}] [arg {row values}]] + +Sets the values in the cells identified by the row index to the +elements of the list provided as the third argument. Each element of +the list is assigned to one cell, with the first element going into +the cell in column 0 and then upward. If there are less values in the +list than there are columns the remaining columns are set to the empty +string. If there are more values in the list than there are columns +the superfluous elements are ignored. The matrix is not extended by +this operation. + +[call [arg matrixName] [method {sort columns}] [opt [option -increasing]|[option -decreasing]] [arg row]] + +Sorts the columns in the matrix using the data in the specified +[arg row] as the key to sort by. The options [option -increasing] +and [option -decreasing] have the same meaning as for [cmd lsort]. +If no option is specified [option -increasing] is assumed. + +[call [arg matrixName] [method {sort rows}] [opt [option -increasing]|[option -decreasing]] [arg column]] + +Sorts the rows in the matrix using the data in the specified +[arg column] as the key to sort by. The options [option -increasing] +and [option -decreasing] have the same meaning as for [cmd lsort]. +If no option is specified [option -increasing] is assumed. + +[call [arg matrixName] [method {swap columns}] [arg {column_a column_b}]] + +Swaps the contents of the two specified columns. + +[call [arg matrixName] [method {swap rows}] [arg {row_a row_b}]] + +Swaps the contents of the two specified rows. + +[call [arg matrixName] [method unlink] [arg arrayvar]] + +Removes the link between the matrix and the specified arrayvariable, +if there is one. + +[list_end] + +[section EXAMPLES] +[para] + +The examples below assume a 5x5 matrix M with the first row containing +the values 1 to 5, with 1 in the top-left cell. Each other row +contains the contents of the row above it, rotated by one cell to the +right. + +[para] +[example { + % M getrect 0 0 4 4 + {{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}} +}] + +[para] +[example { + % M setrect 1 1 {{0 0 0} {0 0 0} {0 0 0}} + % M getrect 0 0 4 4 + {{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}} +}] + +[para] + +Assuming that the style definitions in the example section of the +manpage for the package [package report] are loaded into the +interpreter now an example which formats a matrix into a tabular +report. The code filling the matrix with data is not shown. contains +useful data. + +[para] + +[example { + % ::struct::matrix m + % # ... fill m with data, assume 5 columns + % ::report::report r 5 style captionedtable 1 + % m format 2string r + +---+-------------------+-------+-------+--------+ + |000|VERSIONS: |2:8.4a3|1:8.4a3|1:8.4a3%| + +---+-------------------+-------+-------+--------+ + |001|CATCH return ok |7 |13 |53.85 | + |002|CATCH return error |68 |91 |74.73 | + |003|CATCH no catch used|7 |14 |50.00 | + |004|IF if true numeric |12 |33 |36.36 | + |005|IF elseif |15 |47 |31.91 | + | |true numeric | | | | + +---+-------------------+-------+-------+--------+ + % + % # alternate way of doing the above + % r printmatrix m +}] + +[vset CATEGORY {struct :: matrix}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/matrix1.tcl b/tcllib/modules/struct/matrix1.tcl new file mode 100644 index 0000000..6efa0b0 --- /dev/null +++ b/tcllib/modules/struct/matrix1.tcl @@ -0,0 +1,2287 @@ +# matrix.tcl -- +# +# Implementation of a matrix data structure for Tcl. +# +# Copyright (c) 2001 by Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# Heapsort code Copyright (c) 2003 by Edwin A. Suominen <ed@eepatents.com>, +# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: matrix1.tcl,v 1.3 2005/09/28 04:51:24 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::struct {} + +namespace eval ::struct::matrix { + # Data storage in the matrix module + # ------------------------------- + # + # One namespace per object, containing + # + # - Two scalar variables containing the current number of rows and columns. + # - Four array variables containing the array data, the caches for + # rowheights and columnwidths and the information about linked arrays. + # + # The variables are + # - columns #columns in data + # - rows #rows in data + # - data cell contents + # - colw cache of columnwidths + # - rowh cache of rowheights + # - link information about linked arrays + # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] + # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. + + # counter is used to give a unique name for unnamed matrices + variable counter 0 + + # Only export one command, the one used to instantiate a new matrix + namespace export matrix +} + +# ::struct::matrix::matrix -- +# +# Create a new matrix with a given name; if no name is given, use +# matrixX, where X is a number. +# +# Arguments: +# name Optional name of the matrix; if null or not given, generate one. +# +# Results: +# name Name of the matrix created + +proc ::struct::matrix::matrix {{name ""}} { + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "matrix${counter}" + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 namespace current] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + if { [llength [info commands $name]] } { + return -code error "command \"$name\" already exists, unable to create matrix" + } + + # Set up the namespace + namespace eval $name { + variable columns 0 + variable rows 0 + + variable data + variable colw + variable rowh + variable link + variable lock + variable unset + + array set data {} + array set colw {} + array set rowh {} + array set link {} + set lock 0 + set unset {} + } + + # Create the command to manipulate the matrix + interp alias {} $name {} ::struct::matrix::MatrixProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::matrix::MatrixProc -- +# +# Command that processes all matrix object commands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::MatrixProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if {[llength [info commands ::struct::matrix::$sub]] == 0} { + set optlist [lsort [info commands ::struct::matrix::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_add -- +# +# Command that processes all 'add' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'add' to invoke. +# args Arguments for subcommand of 'add'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_add {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __add_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__add_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_delete -- +# +# Command that processes all 'delete' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'delete' to invoke. +# args Arguments for subcommand of 'delete'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_delete {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __delete_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__delete_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_format -- +# +# Command that processes all 'format' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'format' to invoke. +# args Arguments for subcommand of 'format'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_format {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __format_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__format_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_get -- +# +# Command that processes all 'get' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'get' to invoke. +# args Arguments for subcommand of 'get'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_get {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __get_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__get_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_insert -- +# +# Command that processes all 'insert' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'insert' to invoke. +# args Arguments for subcommand of 'insert'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_insert {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __insert_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__insert_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_search -- +# +# Command that processes all 'search' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# args Arguments for search. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_search {name args} { + set mode exact + set nocase 0 + + while {1} { + switch -glob -- [lindex $args 0] { + -exact - -glob - -regexp { + set mode [string range [lindex $args 0] 1 end] + set args [lrange $args 1 end] + } + -nocase { + set nocase 1 + } + -* { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -nocase, -exact, -glob, or -regexp" + } + default { + break + } + } + } + + # Possible argument signatures after option processing + # + # \ | args + # --+-------------------------------------------------------- + # 2 | all pattern + # 3 | row row pattern, column col pattern + # 6 | rect ctl rtl cbr rbr pattern + # + # All range specifications are internally converted into a + # rectangle. + + switch -exact -- [llength $args] { + 2 - 3 - 6 {} + default { + return -code error \ + "wrong # args: should be\ + \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" + } + } + + set range [lindex $args 0] + set pattern [lindex $args end] + set args [lrange $args 1 end-1] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + switch -exact -- $range { + all { + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + column { + set ctl [ChkColumnIndex $name [lindex $args 0]] + set cbr $ctl + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + row { + set rtl [ChkRowIndex $name [lindex $args 0]] + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rbr $rtl + } + rect { + foreach {ctl rtl cbr rbr} $args break + set ctl [ChkColumnIndex $name $ctl] + set rtl [ChkRowIndex $name $rtl] + set cbr [ChkColumnIndex $name $cbr] + set rbr [ChkRowIndex $name $rbr] + if {($ctl > $cbr) || ($rtl > $rbr)} { + return -code error "Invalid cell indices, wrong ordering" + } + } + default { + return -code error "invalid range spec \"$range\": should be all, column, row, or rect" + } + } + + if {$nocase} { + set pattern [string tolower $pattern] + } + + set matches [list] + for {set r $rtl} {$r <= $rbr} {incr r} { + for {set c $ctl} {$c <= $cbr} {incr c} { + set v $data($c,$r) + if {$nocase} { + set v [string tolower $v] + } + switch -exact -- $mode { + exact {set matched [string equal $pattern $v]} + glob {set matched [string match $pattern $v]} + regexp {set matched [regexp -- $pattern $v]} + } + if {$matched} { + lappend matches [list $c $r] + } + } + } + return $matches +} + +# ::struct::matrix::_set -- +# +# Command that processes all 'set' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'set' to invoke. +# args Arguments for subcommand of 'set'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_set {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __set_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__set_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_sort -- +# +# Command that processes all 'sort' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'sort' to invoke. +# args Arguments for subcommand of 'sort'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_sort {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + if {[string equal $cmd "rows"]} { + set code r + set byrows 1 + } elseif {[string equal $cmd "columns"]} { + set code c + set byrows 0 + } else { + return -code error \ + "bad option \"$cmd\": must be columns, or rows" + } + + set revers 0 ;# Default: -increasing + while {1} { + switch -glob -- [lindex $args 0] { + -increasing {set revers 0} + -decreasing {set revers 1} + default { + if {[llength $args] > 1} { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -increasing, or -decreasing" + } + break + } + } + set args [lrange $args 1 end] + } + # ASSERT: [llength $args] == 1 + + if {[llength $args] != 1} { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + + set key [lindex $args 0] + + if {$byrows} { + set key [ChkColumnIndex $name $key] + variable ${name}::rows + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $rows + } else { + set key [ChkRowIndex $name $key] + variable ${name}::columns + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $columns + } + + for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { + SortMaxHeapify $name $i $key $code $heapSize $revers + } + + # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 + for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { + if {$byrows} { + SwapRows $name 0 $i + } else { + SwapColumns $name 0 $i + } + incr heapSize -1 + SortMaxHeapify $name 0 $key $code $heapSize $revers + } + return +} + +# ::struct::matrix::_swap -- +# +# Command that processes all 'swap' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'swap' to invoke. +# args Arguments for subcommand of 'swap'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_swap {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __swap_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__swap_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::__add_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is appended immediately +# behind the last existing column. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_column {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new column is not added to the width cache, the other + # columns are not touched, the cache therefore unchanged. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($columns,$r) $v + incr r + } + incr columns + return +} + +# ::struct::matrix::__add_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is appended immediately behind the +# last existing row. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_row {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new row is not added to the height cache, the other + # rows are not touched, the cache therefore unchanged. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$rows) $v + incr c + } + incr rows + return +} + +# ::struct::matrix::__add_columns -- +# +# Extends the matrix by "n" columns. The new cells will be set +# to the empty string. The new columns are appended immediately +# behind the last existing column. A value of "n" equal to or +# smaller than 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new columns to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set r 0} {$r < $rows} {incr r} { + set data($columns,$r) "" + } + incr columns + incr n -1 + } + + return +} + +# ::struct::matrix::__add_rows -- +# +# Extends the matrix by "n" rows. The new cells will be set to +# the empty string. The new rows are appended immediately behind +# the last existing row. A value of "n" equal to or smaller than +# 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new rows to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set c 0} {$c < $columns} {incr c} { + set data($c,$rows) "" + } + incr rows + incr n -1 + } + return +} + +# ::struct::matrix::_cells -- +# +# Returns the number of cells currently managed by the +# matrix. This is the product of "rows" and "columns". +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cells {name} { + variable ${name}::rows + variable ${name}::columns + return [expr {$rows * $columns}] +} + +# ::struct::matrix::_cellsize -- +# +# Returns the length of the string representation of the value +# currently contained in the addressed cell. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to query +# row Row index of the cell to query +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cellsize {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return [string length $data($column,$row)] +} + +# ::struct::matrix::_columns -- +# +# Returns the number of columns currently managed by the +# matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of columns in the matrix. + +proc ::struct::matrix::_columns {name} { + variable ${name}::columns + return $columns +} + +# ::struct::matrix::_columnwidth -- +# +# Returns the length of the longest string representation of all +# the values currently contained in the cells of the addressed +# column if these are all spanning only one line. For cell +# values spanning multiple lines the length of their longest +# line goes into the computation. +# +# Arguments: +# name Name of the matrix object. +# column The index of the column whose width is asked for. +# +# Results: +# See description. + +proc ::struct::matrix::_columnwidth {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::colw + + if {![info exists colw($column)]} { + variable ${name}::rows + variable ${name}::data + + set width 0 + for {set r 0} {$r < $rows} {incr r} { + foreach line [split $data($column,$r) \n] { + set len [string length $line] + if {$len > $width} { + set width $len + } + } + } + + set colw($column) $width + } + + return $colw($column) +} + +# ::struct::matrix::__delete_column -- +# +# Deletes the specified column from the matrix and shifts all +# columns with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# column The index of the column to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_column {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { + set data($c,$r) $data($cn,$r) + if {[info exists colw($cn)]} { + set colw($c) $colw($cn) + unset colw($cn) + } + } + unset data($c,$r) + catch {unset rowh($r)} + } + incr columns -1 + return +} + +# ::struct::matrix::__delete_row -- +# +# Deletes the specified row from the matrix and shifts all +# row with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# row The index of the row to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_row {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { + set data($c,$r) $data($c,$rn) + if {[info exists rowh($rn)]} { + set rowh($r) $rowh($rn) + unset rowh($rn) + } + } + unset data($c,$r) + catch {unset colw($c)} + } + incr rows -1 + return +} + +# ::struct::matrix::_destroy -- +# +# Destroy a matrix, including its associated command and data storage. +# +# Arguments: +# name Name of the matrix to destroy. +# +# Results: +# None. + +proc ::struct::matrix::_destroy {name} { + variable ${name}::link + + # Unlink all existing arrays before destroying the object so that + # we don't leave dangling references / traces. + + foreach avar [array names link] { + _unlink $name $avar + } + + namespace delete $name + interp alias {} $name {} +} + +# ::struct::matrix::__format_2string -- +# +# Formats the matrix using the specified report object and +# returns the string containing the result of this +# operation. The report has to support the "printmatrix" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# +# Results: +# A string containing the formatting result. + +proc ::struct::matrix::__format_2string {name {report {}}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # 1. Go through all columns and compute the column widths. + # 2. Then iterate through all rows and dump then into a + # string, formatted to the number of characters per columns + + array set cw {} + set cols [_columns $name] + for {set c 0} {$c < $cols} {incr c} { + set cw($c) [_columnwidth $name $c] + } + + set result [list] + set n [_rows $name] + for {set r 0} {$r < $n} {incr r} { + set rh [_rowheight $name $r] + if {$rh < 2} { + # Simple row. + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [__get_cell $name $c $r] + lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" + } + lappend result [join $line " "] + } else { + # Complex row, multiple passes + for {set h 0} {$h < $rh} {incr h} { + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [lindex [split [__get_cell $name $c $r] \n] $h] + lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" + } + lappend result [join $line " "] + } + } + } + return [join $result \n] + } else { + return [$report printmatrix $name] + } +} + +# ::struct::matrix::__format_2chan -- +# +# Formats the matrix using the specified report object and +# writes the string containing the result of this operation into +# the channel. The report has to support the +# "printmatrix2channel" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# chan Handle of the channel to write to. +# +# Results: +# None. + +proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # We delegate this to the string formatter and print its result. + puts -nonewline [__format_2string $name] + } else { + $report printmatrix2channel $name $chan + } + return +} + +# ::struct::matrix::__get_cell -- +# +# Returns the value currently contained in the cell identified +# by row and column index. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# row Row index of the addressed cell. +# +# Results: +# value Value currently stored in the addressed cell. + +proc ::struct::matrix::__get_cell {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return $data($column,$row) +} + +# ::struct::matrix::__get_column -- +# +# Returns a list containing the values from all cells in the +# column identified by the index. The contents of the cell in +# row 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_column {name column} { + set column [ChkColumnIndex $name $column] + return [GetColumn $name $column] +} + +proc ::struct::matrix::GetColumn {name column} { + variable ${name}::data + variable ${name}::rows + + set result [list] + for {set r 0} {$r < $rows} {incr r} { + lappend result $data($column,$r) + } + return $result +} + +# ::struct::matrix::__get_rect -- +# +# Returns a list of lists of cell values. The values stored in +# the result come from the submatrix whose top-left and +# bottom-right cells are specified by "column_tl", "row_tl" and +# "column_br", "row_br" resp. Note that the following equations +# have to be true: column_tl <= column_br and row_tl <= row_br. +# The result is organized as follows: The outer list is the list +# of rows, its elements are lists representing a single row. The +# row with the smallest index is the first element of the outer +# list. The elements of the row lists represent the selected +# cell values. The cell with the smallest index is the first +# element in each row list. +# +# Arguments: +# name Name of the matrix. +# column_tl Column index of the top-left cell of the area. +# row_tl Row index of the top-left cell of the the area +# column_br Column index of the bottom-right cell of the area. +# row_br Row index of the bottom-right cell of the the area +# +# Results: +# List of a list of values stored in the addressed area. + +proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + + variable ${name}::data + set result [list] + + for {set r $row_tl} {$r <= $row_br} {incr r} { + set row [list] + for {set c $column_tl} {$c <= $column_br} {incr c} { + lappend row $data($c,$r) + } + lappend result $row + } + + return $result +} + +# ::struct::matrix::__get_row -- +# +# Returns a list containing the values from all cells in the +# row identified by the index. The contents of the cell in +# column 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# row Row index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_row {name row} { + set row [ChkRowIndex $name $row] + return [GetRow $name $row] +} + +proc ::struct::matrix::GetRow {name row} { + variable ${name}::data + variable ${name}::columns + + set result [list] + for {set c 0} {$c < $columns} {incr c} { + lappend result $data($c,$row) + } + return $result +} + +# ::struct::matrix::__insert_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is inserted just before +# the column specified by the given index. This means, if +# "column" is less than or equal to zero, then the new column is +# inserted at the beginning of the matrix, before the first +# column. If "column" has the value "Bend", or if it is greater +# than or equal to the number of columns in the matrix, then the +# new column is appended to the matrix, behind the last +# column. The old column at the chosen index and all columns +# with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# column Index of the column where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_column {name column {values {}}} { + # Allow both negative and too big indices. + set column [ChkColumnIndexAll $name $column] + + variable ${name}::columns + + if {$column > $columns} { + # Same as 'addcolumn' + __add_column $name $values + return + } + + variable ${name}::data + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + set firstcol $column + if {$firstcol < 0} { + set firstcol 0 + } + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all rows, move all columns + + # Move all data from the higher columns one up and then insert the + # new data into the freed space. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { + set data($cn,$r) $data($c,$r) + if {[info exists colw($c)]} { + set colw($cn) $colw($c) + unset colw($c) + } + } + set data($firstcol,$r) [lindex $values $r] + catch {unset rowh($r)} + } + incr columns + return +} + +# ::struct::matrix::__insert_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is inserted just before the row +# specified by the given index. This means, if "row" is less +# than or equal to zero, then the new row is inserted at the +# beginning of the matrix, before the first row. If "row" has +# the value "end", or if it is greater than or equal to the +# number of rows in the matrix, then the new row is appended to +# the matrix, behind the last row. The old row at that index and +# all rows with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# row Index of the row where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_row {name row {values {}}} { + # Allow both negative and too big indices. + set row [ChkRowIndexAll $name $row] + + variable ${name}::rows + + if {$row > $rows} { + # Same as 'addrow' + __add_row $name $values + return + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + variable ${name}::colw + + set firstrow $row + if {$firstrow < 0} { + set firstrow 0 + } + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all columns, move all rows + + # Move all data from the higher rows one up and then insert the + # new data into the freed space. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { + set data($c,$rn) $data($c,$r) + if {[info exists rowh($r)]} { + set rowh($rn) $rowh($r) + unset rowh($r) + } + } + set data($c,$firstrow) [lindex $values $c] + catch {unset colw($c)} + } + incr rows + return +} + +# ::struct::matrix::_link -- +# +# Links the matrix to the specified array variable. This means +# that the contents of all cells in the matrix is stored in the +# array too, with all changes to the matrix propagated there +# too. The contents of the cell "(column,row)" is stored in the +# array using the key "column,row". If the option "-transpose" +# is specified the key "row,column" will be used instead. It is +# possible to link the matrix to more than one array. Note that +# the link is bidirectional, i.e. changes to the array are +# mirrored in the matrix too. +# +# Arguments: +# name Name of the matrix object. +# option Either empty of '-transpose'. +# avar Name of the variable to link to +# +# Results: +# None + +proc ::struct::matrix::_link {name args} { + switch -exact -- [llength $args] { + 0 { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + 1 { + set transpose 0 + set variable [lindex $args 0] + } + 2 { + foreach {t variable} $args break + if {[string compare $t -transpose]} { + return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" + } + set transpose 1 + } + default { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + } + + variable ${name}::link + + if {[info exists link($variable)]} { + return -code error "$name link: Variable \"$variable\" already linked to matrix" + } + + # Ok, a new variable we are linked to. Record this information, + # dump our current contents into the array, at last generate the + # traces actually performing the link. + + set link($variable) $transpose + + upvar #0 $variable array + variable ${name}::data + + foreach key [array names data] { + foreach {c r} [split $key ,] break + if {$transpose} { + set array($r,$c) $data($key) + } else { + set array($c,$r) $data($key) + } + } + + trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] + trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] + return +} + +# ::struct::matrix::_links -- +# +# Retrieves the names of all array variable the matrix is +# officialy linked to. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# List of variables the matrix is linked to. + +proc ::struct::matrix::_links {name} { + variable ${name}::link + return [array names link] +} + +# ::struct::matrix::_rowheight -- +# +# Returns the height of the specified row in lines. This is the +# highest number of lines spanned by a cell over all cells in +# the row. +# +# Arguments: +# name Name of the matrix +# row Index of the row queried for its height +# +# Results: +# The height of the specified row in lines. + +proc ::struct::matrix::_rowheight {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::rowh + + if {![info exists rowh($row)]} { + variable ${name}::columns + variable ${name}::data + + set height 1 + for {set c 0} {$c < $columns} {incr c} { + set cheight [llength [split $data($c,$row) \n]] + if {$cheight > $height} { + set height $cheight + } + } + + set rowh($row) $height + } + return $rowh($row) +} + +# ::struct::matrix::_rows -- +# +# Returns the number of rows currently managed by the matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of rows in the matrix. + +proc ::struct::matrix::_rows {name} { + variable ${name}::rows + return $rows +} + +# ::struct::matrix::__set_cell -- +# +# Sets the value in the cell identified by row and column index +# to the data in the third argument. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to set. +# row Row index of the cell to set. +# value THe new value of the cell. +# +# Results: +# None. + +proc ::struct::matrix::__set_cell {name column row value} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + + if {![string compare $value $data($column,$row)]} { + # No change, ignore call! + return + } + + set data($column,$row) $value + + if {$value != {}} { + variable ${name}::colw + variable ${name}::rowh + catch {unset colw($column)} + catch {unset rowh($row)} + } + return +} + +# ::struct::matrix::__set_column -- +# +# Sets the values in the cells identified by the column index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in row 0 and then upward. If there +# are less values in the list than there are rows the remaining +# rows are set to the empty string. If there are more values in +# the list than there are rows the superfluous elements are +# ignored. The matrix is not extended by this operation. +# +# Arguments: +# name Name of the matrix. +# column Index of the column to set. +# values Values to set into the column. +# +# Results: +# None. + +proc ::struct::matrix::__set_column {name column values} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the column in the width cache. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($column,$r) $v + incr r + } + catch {unset colw($column)} + return +} + +# ::struct::matrix::__set_rect -- +# +# Takes a list of lists of cell values and writes them into the +# submatrix whose top-left cell is specified by the two +# indices. If the sublists of the outerlist are not of equal +# length the shorter sublists will be filled with empty strings +# to the length of the longest sublist. If the submatrix +# specified by the top-left cell and the number of rows and +# columns in the "values" extends beyond the matrix we are +# modifying the over-extending parts of the values are ignored, +# i.e. essentially cut off. This subcommand expects its input in +# the format as returned by "getrect". +# +# Arguments: +# name Name of the matrix object. +# column Column index of the topleft cell to set. +# row Row index of the topleft cell to set. +# values Values to set. +# +# Results: +# None. + +proc ::struct::matrix::__set_rect {name column row values} { + # Allow negative indices! + set column [ChkColumnIndexNeg $name $column] + set row [ChkRowIndexNeg $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {$row < 0} { + # Remove rows from the head of values to restrict it to the + # overlapping area. + + set values [lrange $values [expr {0 - $row}] end] + set row 0 + } + + # Restrict it at the end too. + if {($row + [llength $values]) > $rows} { + set values [lrange $values 0 [expr {$rows - $row - 1}]] + } + + # Same for columns, but store it in some vars as this is required + # in a loop. + set firstcol 0 + if {$column < 0} { + set firstcol [expr {0 - $column}] + set column 0 + } + + # Now pan through values and area and copy the external data into + # the matrix. + + set r $row + foreach line $values { + set line [lrange $line $firstcol end] + + set l [expr {$column + [llength $line]}] + if {$l > $columns} { + set line [lrange $line 0 [expr {$columns - $column - 1}]] + } elseif {$l < [expr {$columns - $firstcol}]} { + # We have to take the offset into the line into account + # or we add fillers we don't need, overwriting part of the + # data array we shouldn't. + + for {} {$l < [expr {$columns - $firstcol}]} {incr l} { + lappend line {} + } + } + + set c $column + foreach cell $line { + if {$cell != {}} { + catch {unset rowh($r)} + catch {unset colw($c)} + } + set data($c,$r) $cell + incr c + } + incr r + } + return +} + +# ::struct::matrix::__set_row -- +# +# Sets the values in the cells identified by the row index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in column 0 and then upward. If +# there are less values in the list than there are columns the +# remaining columns are set to the empty string. If there are +# more values in the list than there are columns the superfluous +# elements are ignored. The matrix is not extended by this +# operation. +# +# Arguments: +# name Name of the matrix. +# row Index of the row to set. +# values Values to set into the row. +# +# Results: +# None. + +proc ::struct::matrix::__set_row {name row values} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the row in the height cache. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$row) $v + incr c + } + catch {unset rowh($row)} + return +} + +# ::struct::matrix::__swap_columns -- +# +# Swaps the contents of the two specified columns. +# +# Arguments: +# name Name of the matrix. +# column_a Index of the first column to swap +# column_b Index of the second column to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_columns {name column_a column_b} { + set column_a [ChkColumnIndex $name $column_a] + set column_b [ChkColumnIndex $name $column_b] + return [SwapColumns $name $column_a $column_b] +} + +proc ::struct::matrix::SwapColumns {name column_a column_b} { + variable ${name}::data + variable ${name}::rows + variable ${name}::colw + + # Note: This operation does not influence the height cache for all + # rows and the width cache only insofar as its contents has to be + # swapped too for the two columns we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set r 0} {$r < $rows} {incr r} { + set tmp $data($column_a,$r) + set data($column_a,$r) $data($column_b,$r) + set data($column_b,$r) $tmp + } + + set cwa [info exists colw($column_a)] + set cwb [info exists colw($column_b)] + + if {$cwa && $cwb} { + set tmp $colw($column_a) + set colw($column_a) $colw($column_b) + set colw($column_b) $tmp + } elseif {$cwa} { + # Move contents, don't swap. + set colw($column_b) $colw($column_a) + unset colw($column_a) + } elseif {$cwb} { + # Move contents, don't swap. + set colw($column_a) $colw($column_b) + unset colw($column_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::__swap_rows -- +# +# Swaps the contents of the two specified rows. +# +# Arguments: +# name Name of the matrix. +# row_a Index of the first row to swap +# row_b Index of the second row to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_rows {name row_a row_b} { + set row_a [ChkRowIndex $name $row_a] + set row_b [ChkRowIndex $name $row_b] + return [SwapRows $name $row_a $row_b] +} + +proc ::struct::matrix::SwapRows {name row_a row_b} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + + # Note: This operation does not influence the width cache for all + # columns and the height cache only insofar as its contents has to be + # swapped too for the two rows we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set c 0} {$c < $columns} {incr c} { + set tmp $data($c,$row_a) + set data($c,$row_a) $data($c,$row_b) + set data($c,$row_b) $tmp + } + + set rha [info exists rowh($row_a)] + set rhb [info exists rowh($row_b)] + + if {$rha && $rhb} { + set tmp $rowh($row_a) + set rowh($row_a) $rowh($row_b) + set rowh($row_b) $tmp + } elseif {$rha} { + # Move contents, don't swap. + set rowh($row_b) $rowh($row_a) + unset rowh($row_a) + } elseif {$rhb} { + # Move contents, don't swap. + set rowh($row_a) $rowh($row_b) + unset rowh($row_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::_unlink -- +# +# Removes the link between the matrix and the specified +# arrayvariable, if there is one. +# +# Arguments: +# name Name of the matrix. +# avar Name of the linked array. +# +# Results: +# None. + +proc ::struct::matrix::_unlink {name avar} { + + variable ${name}::link + + if {![info exists link($avar)]} { + # Ignore unlinking of unkown variables. + return + } + + # Delete the traces first, then remove the link management + # information from the object. + + upvar #0 $avar array + variable ${name}::data + + trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] + trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] + + unset link($avar) + return +} + +# ::struct::matrix::ChkColumnIndex -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndex {name column} { + variable ${name}::columns + + switch -regex -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "bad column index $column, column does not exist" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndex -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndex {name row} { + variable ${name}::rows + + switch -regex -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {($rr < 0) || ($rr >= $rows)} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + if {$rows <= 0} { + return -code error "bad row index $row, row does not exist" + } + return [expr {$rows - 1}] + } + {[0-9]+} { + if {($row < 0) || ($row >= $rows)} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexNeg -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexNeg {name column} { + variable ${name}::columns + + switch -regex -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {$cc >= $columns} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + return [expr {$columns - 1}] + } + {[0-9]+} { + if {$column >= $columns} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexNeg -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexNeg {name row} { + variable ${name}::rows + + switch -regex -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {$rr >= $rows} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + return [expr {$rows - 1}] + } + {[0-9]+} { + if {$row >= $rows} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexAll -- +# +# Helper to transform column indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexAll {name column} { + variable ${name}::columns + + switch -regex -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + return $cc + } + end { + return $columns + } + {[0-9]+} { + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexAll -- +# +# Helper to transform row indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexAll {name row} { + variable ${name}::rows + + switch -regex -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + return $rr + } + end { + return $rows + } + {[0-9]+} { + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::MatTraceIn -- +# +# Helper propagating changes made to an array +# into the matrix the array is linked to. +# +# Arguments: +# avar Name of the array which was changed. +# name Matrix to write the changes to. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceIn {avar name var idx op} { + # Propagate changes in the linked array back into the matrix. + + variable ${name}::lock + if {$lock} {return} + + # We have to cover two possibilities when encountering an "unset" operation ... + # 1. The external array was destroyed: perform automatic unlink. + # 2. An individual element was unset: Set the corresponding cell to the empty string. + # See SF Tcllib Bug #532791. + + if {(![string compare $op u]) && ($idx == {})} { + # Possibility 1: Array was destroyed + $name unlink $avar + return + } + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + # Use standard method to propagate the change. + # => Get automatically index checks, cache updates, ... + + if {![string compare $op u]} { + # Unset possibility 2: Element was unset. + # Note: Setting the cell to the empty string will + # invoke MatTraceOut for this array and thus try + # to recreate the destroyed element of the array. + # We don't want this. But we do want to propagate + # the change to other arrays, as "unset". To do + # all of this we use another state variable to + # signal this situation. + + variable ${name}::unset + set unset $avar + + $name set cell $c $r "" + + set unset {} + return + } + + $name set cell $c $r $array($idx) + return +} + +# ::struct::matrix::MatTraceOut -- +# +# Helper propagating changes made to the matrix into the linked arrays. +# +# Arguments: +# avar Name of the array to write the changes to. +# name Matrix which was changed. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceOut {avar name var idx op} { + # Propagate changes in the matrix data array into the linked array. + + variable ${name}::unset + + if {![string compare $avar $unset]} { + # Do not change the variable currently unsetting + # one of its elements. + return + } + + variable ${name}::lock + set lock 1 ; # Disable MatTraceIn [#532783] + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + if {$unset != {}} { + # We are currently propagating the unset of an + # element in a different linked array to this + # array. We make sure that this is an unset too. + + unset array($c,$r) + } else { + set array($c,$r) $data($idx) + } + set lock 0 + return +} + +# ::struct::matrix::SortMaxHeapify -- +# +# Helper for the 'sort' method. Performs the central algorithm +# which converts the matrix into a heap, easily sortable. +# +# Arguments: +# name Matrix object which is sorted. +# i Index of the row/column currently being sorted. +# key Index of the column/row to sort the rows/columns by. +# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). +# heapSize Number of rows/columns to sort. +# rev Boolean flag, set if sorting is done revers (-decreasing). +# +# Sideeffects: +# Transforms the matrix into a heap of rows/columns, +# swapping them around. +# +# Results: +# None. + +proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { + # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 + switch $rowCol { + r { set A [GetColumn $name $key] } + c { set A [GetRow $name $key] } + } + # Weird expressions below for clarity, as CLRS uses A[1...n] + # format and TCL uses A[0...n-1] + set left [expr {int(2*($i+1) -1)}] + set right [expr {int(2*($i+1)+1 -1)}] + + # left, right are tested as < rather than <= because they are + # in A[0...n-1] + if { + $left < $heapSize && + ( !$rev && [lindex $A $left] > [lindex $A $i] || + $rev && [lindex $A $left] < [lindex $A $i] ) + } { + set largest $left + } else { + set largest $i + } + + if { + $right < $heapSize && + ( !$rev && [lindex $A $right] > [lindex $A $largest] || + $rev && [lindex $A $right] < [lindex $A $largest] ) + } { + set largest $right + } + + if { $largest != $i } { + switch $rowCol { + r { SwapRows $name $i $largest } + c { SwapColumns $name $i $largest } + } + SortMaxHeapify $name $largest $key $rowCol $heapSize $rev + } + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'matrix::matrix' into the general structure namespace. + namespace import -force matrix::matrix + namespace export matrix +} +package provide struct::matrix 1.2.1 diff --git a/tcllib/modules/struct/matrix1.test b/tcllib/modules/struct/matrix1.test new file mode 100644 index 0000000..a7b5806 --- /dev/null +++ b/tcllib/modules/struct/matrix1.test @@ -0,0 +1,1895 @@ +# -*- tcl -*- +# matrix.test: tests for the matrix structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2001 by Andreas Kupries <a.kupries@westend.com> +# All rights reserved. +# +# RCS: @(#) $Id: matrix1.test,v 1.8 2006/10/09 21:41:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + useLocalFile matrix.testsupport +} +testing { + useLocal matrix1.tcl struct::matrix +} + +# ------------------------------------------------------------------------- + +namespace import struct::matrix + +#---------------------------------------------------------------------- +# Serialized matrix for some tests. + +set matdata {{2 0 f j} {c g b a} {a 02 01 3}} + +#---------------------------------------------------------------------- + +test matrix1-0.1 {matrix errors} { + matrix mymatrix + catch {matrix mymatrix} msg + mymatrix destroy + set msg +} "command \"::mymatrix\" already exists, unable to create matrix" + +test matrix1-0.2 {matrix errors} { + matrix mymatrix + catch {mymatrix} msg + mymatrix destroy + set msg +} "wrong # args: should be \"::mymatrix option ?arg arg ...?\"" + +test matrix1-0.3 {matrix errors} { + matrix mymatrix + catch {mymatrix foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be add, cells, cellsize, columns, columnwidth, delete, destroy, format, get, insert, link, links, rowheight, rows, search, set, sort, swap, or unlink" + +test matrix1-0.4 {matrix errors} { + matrix mymatrix + catch {mymatrix add foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, columns, row, or rows" + +test matrix1-0.5 {matrix errors} { + matrix mymatrix + catch {mymatrix delete foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, or row" + +test matrix1-0.6 {matrix errors} { + matrix mymatrix + catch {mymatrix get foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be cell, column, rect, or row" + +test matrix1-0.7 {matrix errors} { + matrix mymatrix + catch {mymatrix set foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be cell, column, rect, or row" + +test matrix1-0.8 {matrix errors} { + matrix mymatrix + catch {mymatrix format foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be 2chan, or 2string" + +test matrix1-0.9 {matrix errors} { + matrix mymatrix + catch {mymatrix swap foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be columns, or rows" + +test matrix1-0.10 {matrix errors} { + catch {matrix set} msg + set msg +} "command \"::set\" already exists, unable to create matrix" + +test matrix1-0.11 {matrix errors} { + matrix mymatrix + catch {mymatrix set cell 0 0 foo} msg + mymatrix destroy + set msg +} {bad column index 0, column does not exist} + +test matrix1-0.12 {matrix errors} { + matrix mymatrix + mymatrix add column + catch {mymatrix set cell 0 0 foo} msg + mymatrix destroy + set msg +} {bad row index 0, row does not exist} + +test matrix1-0.13 {matrix errors} { + matrix mymatrix + catch {mymatrix insert foo} msg + mymatrix destroy + set msg +} "bad option \"foo\": must be column, or row" + +test matrix1-1.0 {create} { + set name [matrix] + set result [list $name [string equal [info commands $name] "$name"]] + $name destroy + set result +} [list ::matrix1 1] + + +test matrix1-1.1 {columns, rows & cells} { + matrix mymatrix + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {0 0 0} + +test matrix1-1.2 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {0 1 0} + +test matrix1-1.3 {columns, rows & cells} { + matrix mymatrix + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {1 0 0} + +test matrix1-1.4 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {1 1 1} + +test matrix1-1.5 {columns, rows & cells} { + matrix mymatrix + mymatrix add column + mymatrix add row + mymatrix add column + mymatrix add row + set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]] + mymatrix destroy + set result +} {2 2 4} + +test matrix1-2.0 {add error} { + matrix mymatrix + catch {mymatrix add} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix add option ?arg arg ...?"} + +test matrix1-2.1 {add column, add row} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2} {3 4}} + +test matrix1-2.2 {add column, add row} { + matrix mymatrix + mymatrix add column + mymatrix add row + mymatrix add column + mymatrix add row + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {}} {{} {}}} + +test matrix1-2.3 {add columns, add rows} { + matrix mymatrix + mymatrix add columns 4 + mymatrix add rows 4 + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} + +test matrix1-2.4 {add columns, add rows} { + matrix mymatrix + mymatrix add rows 4 + mymatrix add columns 4 + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}} + +test matrix1-2.5 {add columns, add rows} { + matrix mymatrix + catch {mymatrix add columns 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix1-2.6 {add columns, add rows} { + matrix mymatrix + catch {mymatrix add rows 0} result + mymatrix destroy + set result +} {A value of n <= 0 is not allowed} + +test matrix1-2.7 {add column, add row, cut off} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2 5 6 7} + mymatrix add row {3 4 8 9 10} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2} {3 4}} + + + +test matrix1-3.1 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + set result [list [mymatrix cellsize 0 0] [mymatrix columnwidth 1] [mymatrix rowheight 1]] + mymatrix destroy + set result +} {1 2 2} + +test matrix1-3.2 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize -1 -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-3.3 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 5 -1} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-3.4 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 0 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-3.5 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix cellsize 0 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-3.6 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix rowheight -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-3.7 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix rowheight 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-3.8 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix columnwidth -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-3.9 {sizes, widths, heights} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {23} + mymatrix add row [list "4\n5" 6] + catch {mymatrix columnwidth 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-4.0 {delete error} { + matrix mymatrix + catch {mymatrix delete} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix delete option ?arg arg ...?"} + +test matrix1-4.1 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2a} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\na"] + + set resa [list [mymatrix columnwidth 0]] + lappend resa [mymatrix columnwidth 1] + lappend resa [mymatrix columnwidth 2] + + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column 1 + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row 1 + lappend result [mymatrix get rect 0 0 end end] + + lappend resa [mymatrix columnwidth 0] + lappend resa [mymatrix columnwidth 1] + + mymatrix destroy + lappend result $resa + set result +} {{{1 2a 5} {3 4 6} {7 8 {9 +a}}} {{1 5} {3 6} {7 {9 +a}}} {{1 5} {7 {9 +a}}} {1 2 1 1 1}} + +test matrix1-4.1a {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2a} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\na"] + + set resb [list [mymatrix rowheight 0]] + lappend resb [mymatrix rowheight 1] + lappend resb [mymatrix rowheight 2] + + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete row 1 + mymatrix delete column 1 + lappend result [mymatrix get rect 0 0 end end] + + lappend resb [mymatrix rowheight 0] + lappend resb [mymatrix rowheight 1] + + mymatrix destroy + lappend result $resb + set result +} {{{1 2a 5} {3 4 6} {7 8 {9 +a}}} {{1 5} {7 {9 +a}}} {1 1 2 1 2}} + +test matrix1-4.2 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column 0 + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row 0 + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{1 2 5} {3 4 6} {7 8 9}} {{2 5} {4 6} {8 9}} {{4 6} {8 9}}} + +test matrix1-4.3 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [list [mymatrix get rect 0 0 end end]] + mymatrix delete column end + lappend result [mymatrix get rect 0 0 end end] + mymatrix delete row end + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{{1 2 5} {3 4 6} {7 8 9}} {{1 2} {3 4} {7 8}} {{1 2} {3 4}}} + +test matrix1-4.4 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete column -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-4.5 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete column 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-4.6 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete row -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-4.7 {deletion of rows and columns} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix delete row 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-5.0 {format error} { + matrix mymatrix + catch {mymatrix format} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix format option ?arg arg ...?"} + +test matrix1-5.1 {formatting} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix format 2string tclformat] + mymatrix destroy + set result +} "# ::mymatrix 3 x 3 +matrix ::mymatrix +::mymatrix add rows 3 +::mymatrix add columns 3 +::mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" + +test matrix1-5.2 {internal format} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix format 2string] + mymatrix destroy + set result +} "1 2 5\n3 4 6\n7 8 9" + +test matrix1-5.3 {internal format} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3a 4} + mymatrix add column {5 6} + mymatrix add row [list 7 8 "9\nb"] + set result [mymatrix format 2string] + mymatrix destroy + set result +} "1 2 5\n3a 4 6\n7 8 9\n b" + +if {![catch {package require memchan}]} { + # We have memory channels and can therefore test + # 'format2channel-via' too. + + test matrix1-5.4 {formatting} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + set chan [memchan] + mymatrix format 2chan tclformat $chan + mymatrix destroy + + seek $chan 0 + set result [read $chan] + close $chan + set result + } "# mymatrix 3 x 3 +matrix mymatrix +mymatrix add rows 3 +mymatrix add columns 3 +mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}" +} + +test matrix1-6.0 {set/get error} { + matrix mymatrix + catch {mymatrix set} msga + catch {mymatrix get} msgb + mymatrix destroy + list $msga $msgb +} {{wrong # args: should be "::mymatrix set option ?arg arg ...?"} {wrong # args: should be "::mymatrix get option ?arg arg ...?"}} + +test matrix1-6.1 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get cell 0 2] + mymatrix destroy + set result +} 7 + +test matrix1-6.2 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get column 1] + mymatrix destroy + set result +} {2 4 8} + +test matrix1-6.3 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get row 2] + mymatrix destroy + set result +} {7 8 9} + +test matrix1-6.4 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + set result [mymatrix get rect 1 1 end end] + mymatrix destroy + set result +} {{4 6} {8 9}} + +test matrix1-6.5 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set cell 0 2 foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {foo 8 9}} + +test matrix1-6.6 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b c} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 c 9}} + +test matrix1-6.7 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz nex} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz nex}} + +test matrix1-6.8 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect 1 1 {{c d} {e f}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 c d} {7 e f}} + +test matrix1-6.9 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 {} 9}} + +test matrix1-6.10 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set column 1 {a b c d e f} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 5} {3 b 6} {7 c 9}} + +test matrix1-6.11 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz {}}} + +test matrix1-6.12 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set row 2 {bar buz nex floz} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {bar buz nex}} + +test matrix1-6.13 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect 1 1 {{c d e} {f g h} {i j k}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 c d} {7 f g}} + +test matrix1-6.14 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix set rect -1 -1 {{c d e} {f g h} {i j k}} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{g h 5} {j k 6} {7 8 9}} + +test matrix1-6.15 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell -1 2} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-6.16 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 5 2} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.17 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 0 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-6.18 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get cell 0 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-6.19 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get column -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-6.20 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get column 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.21 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get row -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-6.22 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get row 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-6.23 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect -1 1 end end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-6.24 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 5 1 end end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.25 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 -1 end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-6.26 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 5 end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.27 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 -1 end end} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-6.28 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 5 end end} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-6.29 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 end -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-6.30 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect 1 1 end 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-6.31 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set column -1 {a b c}} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-6.32 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set column 5 {a b c}} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.33 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set row -1 {a b c}} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-6.34 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set row 5 {a b c}} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-6.35 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set rect 5 1 {{a b} {c d}}} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-6.36 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix set rect 1 5 {{a b} {c d}}} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + + +test matrix1-6.43 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix get rect end end 1 1} result + mymatrix destroy + set result +} {Invalid cell indices, wrong ordering} + +test matrix1-6.44 {set and get in all forms} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix set cell 0 0 foo + set result [list [mymatrix get rect 0 0 end end]] + mymatrix set cell 0 0 foo + lappend result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {foo foo} + + + + +test matrix1-7.0 {swap error} { + matrix mymatrix + catch {mymatrix swap} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix swap option ?arg arg ...?"} + +test matrix1-7.1 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix swap columns 1 end + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 5 2} {3 6 4} {7 9 8}} + +test matrix1-7.2 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix swap rows 1 end + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {7 8 9} {3 4 6}} + +test matrix1-7.3 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns -1 end} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-7.4 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 5 end} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-7.5 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 1 -1} result + mymatrix destroy + set result +} {bad column index -1, column does not exist} + +test matrix1-7.6 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap columns 1 5} result + mymatrix destroy + set result +} {bad column index 5, column does not exist} + +test matrix1-7.7 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows -1 end} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-7.8 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 5 end} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-7.9 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 1 -1} result + mymatrix destroy + set result +} {bad row index -1, row does not exist} + +test matrix1-7.10 {swapping} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + catch {mymatrix swap rows 1 5} result + mymatrix destroy + set result +} {bad row index 5, row does not exist} + +test matrix1-8.0 {insert error} { + matrix mymatrix + catch {mymatrix insert} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix insert option ?arg arg ...?"} + +test matrix1-8.1 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 0 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} + +test matrix1-8.2 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 a 2 5} {3 b 4 6} {7 c 8 9}} + +test matrix1-8.3 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column end {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} + +test matrix1-8.4 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column 3 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5 a} {3 4 6 b} {7 8 9 c}} + +test matrix1-8.5 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert column -1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a 1 2 5} {b 3 4 6} {c 7 8 9}} + + +test matrix1-8.6 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 0 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a b c} {1 2 5} {3 4 6} {7 8 9}} + +test matrix1-8.7 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {a b c} {3 4 6} {7 8 9}} + +test matrix1-8.8 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row end {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {7 8 9} {a b c}} + +test matrix1-8.9 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row 3 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {3 4 6} {7 8 9} {a b c}} + +test matrix1-8.10 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + + mymatrix insert row -1 {a b c} + + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{a b c} {1 2 5} {3 4 6} {7 8 9}} + +test matrix1-8.11 {insertion} { + matrix mymatrix + mymatrix add column + mymatrix insert row 1 {1} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {1} + +test matrix1-8.12 {insertion} { + matrix mymatrix + mymatrix add row + mymatrix insert column 1 {1} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {1} + +test matrix1-9.0 {link errors} { + matrix mymatrix + catch {mymatrix link} msg + mymatrix destroy + set msg +} {::mymatrix: wrong # args: link ?-transpose? arrayvariable} + +test matrix1-9.1 {link errors} { + matrix mymatrix + catch {mymatrix link 1 2 3} msg + mymatrix destroy + set msg +} {::mymatrix: wrong # args: link ?-transpose? arrayvariable} + +test matrix1-9.2 {link errors} { + matrix mymatrix + catch {mymatrix link foo 2} msg + mymatrix destroy + set msg +} {::mymatrix: illegal syntax: link ?-transpose? arrayvariable} + +test matrix1-9.3 {link errors} { + matrix mymatrix + mymatrix link foo + catch {mymatrix link foo} msg + mymatrix destroy + set msg +} {::mymatrix link: Variable "foo" already linked to matrix} + +test matrix1-9.4 {linking, initial transfer} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set result [dictsort [array get a]] + mymatrix destroy + set result +} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9} + +test matrix1-9.5 {linking, initial transfer} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link -transpose a + set result [dictsort [array get a]] + mymatrix destroy + set result +} {0,0 1 0,1 2 0,2 5 1,0 3 1,1 4 1,2 6 2,0 7 2,1 8 2,2 9} + + +test matrix1-9.6 {linking, trace array -> matrix} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set a(1,0) foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 foo 5} {3 4 6} {7 8 9}} + +test matrix1-9.7 {linking, trace array -> matrix} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link -transpose a + set a(1,0) foo + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 5} {foo 4 6} {7 8 9}} + +test matrix1-9.8 {linking, trace and unlink} { + catch {unset a} + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set a(1,0) foo + set result [list [mymatrix get rect 0 0 end end]] + mymatrix unlink a + set a(1,0) 2 + lappend result [dictsort [array get a]] + mymatrix destroy + set result +} {{{1 foo 5} {3 4 6} {7 8 9}} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9}} + +test matrix1-9.9 {linking} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + catch {set a(1,5) foo} result + mymatrix destroy + set result +} {can't set "a(1,5)": bad row index 5, row does not exist} + +test matrix1-9.10 {unlink unknown} { + matrix mymatrix + set result [list [mymatrix links]] + mymatrix unlink foo + lappend result [mymatrix links] + mymatrix destroy + set result +} {{} {}} + +test matrix1-9.11 {auto unlink} { + matrix mymatrix + mymatrix add column + mymatrix add row {1} + mymatrix add column {2} + mymatrix add row {3 4} + mymatrix add column {5 6} + mymatrix add row {7 8 9} + mymatrix link a + set result [list [mymatrix links]] + unset a + lappend result [mymatrix links] + mymatrix destroy + set result +} {a {}} + +test matrix1-9.12 {unset in linked array} { + matrix mymatrix + mymatrix add columns 3 + mymatrix add row {1 2 3} + mymatrix add row {a b c} + + catch {unset a} + mymatrix link a + + set result [list] + lappend result [dictsort [array get a]] + unset a(0,0) + lappend result [mymatrix get rect 0 0 end end] + + mymatrix destroy + set result +} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {{{} 2 3} {a b c}}} + +test matrix1-9.12a {unset in linked array} { + matrix mymatrix + mymatrix add columns 3 + mymatrix add row {1 2 3} + mymatrix add row {a b c} + + catch {unset a} + mymatrix link a + catch {unset b} + mymatrix link b + + set result [list] + lappend result [dictsort [array get a]] + unset a(0,0) + lappend result [dictsort [array get b]] + + mymatrix destroy + set result +} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {0,1 a 1,0 2 1,1 b 2,0 3 2,1 c}} + +test matrix1-9.13 {operation on linked matrix} { + catch {unset a} + matrix mymatrix + mymatrix add columns 4 + mymatrix add row {1 2 3} + mymatrix link a + mymatrix add row {a b c d} + set result [mymatrix get rect 0 0 end end] + mymatrix destroy + set result +} {{1 2 3 {}} {a b c d}} + +test matrix1-10.1 {search errors} { + matrix mymatrix + catch {mymatrix search} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix1-10.2 {search errors} { + matrix mymatrix + catch {mymatrix search 1} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix1-10.3 {search errors} { + matrix mymatrix + catch {mymatrix search 1 2 3 4 5} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix1-10.4 {search errors} { + matrix mymatrix + catch {mymatrix search 1 2 3 4 5 6 7 8} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"} + +test matrix1-10.5 {search errors} { + matrix mymatrix + catch {mymatrix search -foo 2 3 4} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -nocase, -exact, -glob, or -regexp} + +test matrix1-10.6 {search errors} { + matrix mymatrix + catch {mymatrix search -exact foo 3 4} msg + mymatrix destroy + set msg +} {invalid range spec "foo": should be all, column, row, or rect} + +test matrix1-10.7 {search errors} { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + catch {mymatrix search -exact rect 4 0 2 1 foo} msg + mymatrix destroy + set msg +} {Invalid cell indices, wrong ordering} + +test matrix1-10.8 {search errors} { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + catch {mymatrix search -exact rect 2 1 4 0 foo} msg + mymatrix destroy + set msg +} {Invalid cell indices, wrong ordering} + + +test matrix1-10.9 "searching, default" { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + set result [mymatrix search row 2 b] + mymatrix destroy + set result +} {{1 2}} + +foreach {n mode range pattern result} { + 10 -exact {all} {ab} {{0 3}} + 11 -glob {all} {a*} {{0 2} {0 3}} + 12 -regexp {all} {b.} {{1 3}} + 13 -exact {row 2} {b} {{1 2}} + 14 -glob {row 3} {b*} {{1 3}} + 15 -regexp {row 4} {d} {{0 4} {1 4}} + 16 -exact {column 2} {c} {{2 2}} + 17 -glob {column 0} {a*} {{0 2} {0 3}} + 18 -regexp {column 1} {b.*} {{1 2} {1 3}} + 19 -exact {rect 1 1 3 3} {c} {{2 2}} + 20 -glob {rect 1 1 3 3} {b*} {{1 2} {1 3}} + 21 -regexp {rect 1 1 3 3} {b.*} {{1 2} {1 3}} +} { + test matrix1-10.$n "searching ($mode $range $pattern)" { + matrix mymatrix + mymatrix add columns 5 + mymatrix add row {1 2 3 4 5} + mymatrix add row {6 7 8 9 0} + mymatrix add row {a b c d e} + mymatrix add row {ab ba f g h} + mymatrix add row {cd 4d x y z} + set result [eval mymatrix search $mode $range $pattern] + mymatrix destroy + set result + } $result ; # {} +} + + +test matrix1-11.0 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort} msg + mymatrix destroy + set msg +} [tcltest::wrongNumArgs {::struct::matrix::_sort} {name cmd args} 1] + + +test matrix1-11.1 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort} msg + mymatrix destroy + set msg +} [tcltest::wrongNumArgs {::struct::matrix::_sort} {name cmd args} 1] + +test matrix1-11.2 {sorting matrices: bad method} { + matrix mymatrix + catch {mymatrix sort foo} msg + mymatrix destroy + set msg +} {bad option "foo": must be columns, or rows} + +test matrix1-11.3 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort rows} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix sort option ?arg arg ...?"} + +test matrix1-11.4 {sorting matrices: to many arguments} { + matrix mymatrix + catch {mymatrix sort rows foo bar} msg + mymatrix destroy + set msg +} {invalid option "foo": should be -increasing, or -decreasing} + +test matrix1-11.5 {sorting matrices: bad option} { + matrix mymatrix + catch {mymatrix sort rows -foo bar} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -increasing, or -decreasing} + +test matrix1-11.6 {sorting matrices: not enough arguments} { + matrix mymatrix + catch {mymatrix sort columns} msg + mymatrix destroy + set msg +} {wrong # args: should be "::mymatrix sort option ?arg arg ...?"} + +test matrix1-11.7 {sorting matrices: to many arguments} { + matrix mymatrix + catch {mymatrix sort columns foo bar} msg + mymatrix destroy + set msg +} {invalid option "foo": should be -increasing, or -decreasing} + +test matrix1-11.8 {sorting matrices: bad option} { + matrix mymatrix + catch {mymatrix sort columns -foo bar} msg + mymatrix destroy + set msg +} {invalid option "-foo": should be -increasing, or -decreasing} + +test matrix1-11.9 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows -1} msg + mymatrix destroy + set msg +} {bad column index -1, column does not exist} + +test matrix1-11.10 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows 4} msg + mymatrix destroy + set msg +} {bad column index 4, column does not exist} + +test matrix1-11.11 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort rows foo} msg + mymatrix destroy + set msg +} {bad column index "foo", syntax error} + +test matrix1-11.12 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns -1} msg + mymatrix destroy + set msg +} {bad row index -1, row does not exist} + +test matrix1-11.13 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns 3} msg + mymatrix destroy + set msg +} {bad row index 3, row does not exist} + +test matrix1-11.14 {sorting matrices: bad index} { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + catch {mymatrix sort columns foo} msg + mymatrix destroy + set msg +} {bad row index "foo", syntax error} + + +foreach {n cmd res resd} { + 1 {rows 0} {{2 0 f j} {a 02 01 3} {c g b a}} {{c g b a} {a 02 01 3} {2 0 f j}} + 2 {rows 1} {{2 0 f j} {a 02 01 3} {c g b a}} {{c g b a} {a 02 01 3} {2 0 f j}} + 3 {rows 2} {{a 02 01 3} {c g b a} {2 0 f j}} {{2 0 f j} {c g b a} {a 02 01 3}} + 4 {rows 3} {{a 02 01 3} {c g b a} {2 0 f j}} {{2 0 f j} {c g b a} {a 02 01 3}} + 5 {columns 0} {{0 2 f j} {g c b a} {02 a 01 3}} {{j f 2 0} {a b c g} {3 01 a 02}} + 6 {columns 1} {{j f 2 0} {a b c g} {3 01 a 02}} {{0 2 f j} {g c b a} {02 a 01 3}} + 7 {columns 2} {{f 0 j 2} {b g a c} {01 02 3 a}} {{2 j 0 f} {c a g b} {a 3 02 01}} +} { + test matrix1-12.$n "sorting matrices: $cmd" { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + mymatrix set rect 0 0 $matdata + eval [list mymatrix sort] $cmd + set result [mymatrix get rect 0 0 3 2] + mymatrix destroy + set result + } $res + + test matrix1-13.$n "sorting matrices: $cmd, -decreasing" { + matrix mymatrix + mymatrix add rows 3 + mymatrix add columns 4 + mymatrix set rect 0 0 $matdata + eval [linsert [linsert $cmd 1 -decreasing] 0 mymatrix sort] + set result [mymatrix get rect 0 0 3 2] + mymatrix destroy + set result + } $resd +} + + +# Future tests: query rowheight, column width before and after delete +# row/column to ascertain that the cached values are correctly +# shifted. + +# Test 'format 2chan', have to redirect a channel for this. + +# Future: Tests involving cached information (row heights, col widths) +# should use special commands to peek at the cache only, without +# recalculation. + +testsuiteCleanup + diff --git a/tcllib/modules/struct/pkgIndex.tcl b/tcllib/modules/struct/pkgIndex.tcl new file mode 100644 index 0000000..89c473f --- /dev/null +++ b/tcllib/modules/struct/pkgIndex.tcl @@ -0,0 +1,23 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] +package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] + +package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] +package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] +package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] +package ifneeded struct::matrix 2.0.3 [list source [file join $dir matrix.tcl]] +package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] +package ifneeded struct::record 1.2.1 [list source [file join $dir record.tcl]] +package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] +package ifneeded struct::disjointset 1.0 [list source [file join $dir disjointset.tcl]] +package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] +package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.tcl]] + +package ifneeded struct::graph 1.2.1 [list source [file join $dir graph1.tcl]] +package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.tcl]] +package ifneeded struct::matrix 1.2.1 [list source [file join $dir matrix1.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded struct::list 1.8.3 [list source [file join $dir list.tcl]] +package ifneeded struct::graph 2.4 [list source [file join $dir graph.tcl]] +package ifneeded struct::graph::op 0.11.3 [list source [file join $dir graphops.tcl]] diff --git a/tcllib/modules/struct/pool.html b/tcllib/modules/struct/pool.html new file mode 100644 index 0000000..9b198f2 --- /dev/null +++ b/tcllib/modules/struct/pool.html @@ -0,0 +1,1151 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> +<html xmlns:o="urn:schemas-microsoft-com:office:office" +xmlns:w="urn:schemas-microsoft-com:office:word" +xmlns="http://www.w3.org/TR/REC-html40"> + +<head> +<meta http-equiv=Content-Type content="text/html; charset=windows-1252"> +<meta name=ProgId content=Word.Document> +<meta name=Generator content="Microsoft Word 9"> +<meta name=Originator content="Microsoft Word 9"> +<link rel=File-List href="./pool_bestanden/filelist.xml"> +<!--[if gte mso 9]><xml> + <o:DocumentProperties> + <o:LastAuthor>Erik</o:LastAuthor> + <o:Revision>97</o:Revision> + <o:TotalTime>516</o:TotalTime> + <o:LastPrinted>2002-05-15T11:24:00Z</o:LastPrinted> + <o:Created>2002-04-16T19:32:00Z</o:Created> + <o:LastSaved>2002-05-15T11:27:00Z</o:LastSaved> + <o:Pages>6</o:Pages> + <o:Words>1767</o:Words> + <o:Characters>10077</o:Characters> + <o:Company>None</o:Company> + <o:Lines>83</o:Lines> + <o:Paragraphs>20</o:Paragraphs> + <o:CharactersWithSpaces>12375</o:CharactersWithSpaces> + <o:Version>9.2812</o:Version> + </o:DocumentProperties> +</xml><![endif]--><!--[if gte mso 9]><xml> + <w:WordDocument> + <w:View>Normal</w:View> + <w:HyphenationZone>21</w:HyphenationZone> + </w:WordDocument> +</xml><![endif]--> +<style> +<!-- + /* Font Definitions */ +@font-face + {font-family:Tahoma; + panose-1:2 11 6 4 3 5 4 4 2 4; + mso-font-charset:0; + mso-generic-font-family:swiss; + mso-font-pitch:variable; + mso-font-signature:553679495 -2147483648 8 0 66047 0;} + /* Style Definitions */ +p.MsoNormal, li.MsoNormal, div.MsoNormal + {mso-style-parent:""; + margin:0in; + margin-bottom:.0001pt; + mso-pagination:widow-orphan; + font-size:12.0pt; + font-family:"Times New Roman"; + mso-fareast-font-family:"Times New Roman";} +p.MsoDocumentMap, li.MsoDocumentMap, div.MsoDocumentMap + {margin:0in; + margin-bottom:.0001pt; + mso-pagination:widow-orphan; + background:navy; + font-size:12.0pt; + font-family:Tahoma; + mso-fareast-font-family:"Times New Roman";} +p.MsoPlainText, li.MsoPlainText, div.MsoPlainText + {margin:0in; + margin-bottom:.0001pt; + mso-pagination:widow-orphan; + font-size:10.0pt; + font-family:"Courier New"; + mso-fareast-font-family:"Times New Roman";} +@page Section1 + {size:8.5in 11.0in; + margin:.8in .8in .7in .7in; + mso-header-margin:.2in; + mso-footer-margin:.2in; + mso-paper-source:0;} +div.Section1 + {page:Section1;} + /* List Definitions */ +@list l0 + {mso-list-id:491943773; + mso-list-type:hybrid; + mso-list-template-ids:389161538 700215070 68354051 68354053 68354049 68354051 68354053 68354049 68354051 68354053;} +@list l0:level1 + {mso-level-start-at:2; + mso-level-number-format:bullet; + mso-level-text:-; + mso-level-tab-stop:53.4pt; + mso-level-number-position:left; + margin-left:53.4pt; + text-indent:-.25in; + font-family:"Times New Roman"; + mso-fareast-font-family:"Times New Roman";} +@list l1 + {mso-list-id:2044330862; + mso-list-type:hybrid; + mso-list-template-ids:1794557052 1241923622 68354073 68354075 68354063 68354073 68354075 68354063 68354073 68354075;} +@list l1:level1 + {mso-level-tab-stop:106.15pt; + mso-level-number-position:left; + margin-left:106.15pt; + text-indent:-35.35pt;} +ol + {margin-bottom:0in;} +ul + {margin-bottom:0in;} +--> +</style> +<meta name=CVS content="$Id: pool.html,v 1.2 2004/01/15 06:36:14 andreas_kupries Exp $"> +<meta name=CVS content="$Id: pool.html,v 1.2 2004/01/15 06:36:14 andreas_kupries Exp $"> +<meta name=CVS content="\$Id: pool.html,v 1.2 2004/01/15 06:36:14 andreas_kupries Exp $"> +</head> + +<body lang=NL style='tab-interval:35.4pt'> + +<div class=Section1> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText align=center style='text-align:center;mso-outline-level: +1'><b><span style='font-size:16.0pt;font-family:"Times New Roman"'>POOL 0.1<o:p></o:p></span></b></p> + +<p class=MsoPlainText align=center style='text-align:center'><span +style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText align=center style='text-align:center;mso-outline-level: +1'><span style='font-size:11.0pt;font-family:"Times New Roman"'>Author: Erik +Leunissen<o:p></o:p></span></p> + +<p class=MsoPlainText><span style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>NAME<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>pool +– Managing a pool of discrete items.<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>SYNOPSIS<o:p></o:p></span></b></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><span style='mso-tab-count:1'> </span><b>pool +</b><i>?poolName? ?maxsize?</i><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>DESCRIPTION</span></b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:11.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +<i>pool</i> command creates a new instance of a pool data structure. The command +takes the name of the new pool as its first argument. If no name is supplied, +then the new pool will be named pool<X>, where X is a positive integer. +The optional second argument <i>maxsize</i> is a positive integer indicating +the maximum size of the pool; this is the maximum number of items the pool may +hold.</span><span lang=EN-GB style='mso-ansi-language:EN-GB'><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>POOLS AND ALLOCATION<o:p></o:p></span></b></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size: +11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +purpose of the <i>pool</i> command and the pool object command that it +generates, is to manage pools of discrete items.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Examples +of a pool of discrete items are:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>the seats in a cinema, theatre, +train etc.. for which visitors/travellers can<span style="mso-spacerun: yes"> +</span>make a reservation;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>the dynamic IP-addresses that an ISP +can dole out<span style="mso-spacerun: yes"> </span>to subscribers;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>a car rental's collection of cars, +which can be rented by customers;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>the class rooms in a school +building, which need to be scheduled;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>the database connections available +to client-threads in a web-server application;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list: +l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span +style='font:7.0pt "Times New Roman"'> +</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'>the books in a library that +customers can borrow;<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in'><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>etc ...<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +common denominator in the examples is that there is a more or less fixed number +of items (seats, IP-addresses, cars, ...) that are supposed to be allocated on +a more or less regular basis. An item can be allocated only once at a time. An +item that is allocated, must be released before it can be re-allocated. While +several items in a pool are being allocated and released continuously, the +total number of items in the pool remains constant.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Keeping +track of which items are allocated, and by whom, is the purpose of the <i>pool</i> +command and its subordinates.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Pool parlance<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If +we say that an item is allocated, it means that the item is <i>busy</i>, <i>owned</i> +or <i>occupied</i>; it is not available anymore. If an item is free, it is +available. <i>Deallocating</i> an item is equivalent to <i>setting free</i> or <i>releasing</i> +an item. The person or entity to which the item has been allotted is said to <i>own</i> +the item.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size: +11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>ITEMS<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Discrete items<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +<i>pool</i> command is designed for <b>discrete items only</b>. Note that there +are pools where allocation occurs on a non-discrete basis, for example computer +memory. There are also pools from which the shares that are doled out are not +expected to be returned, for example a charity fund or a pan of soup from which +you may receive a portion. Finally, there are even pools from which nothing is +ever allocated or returned, like a swimming pool or a cesspool.<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Unique item names<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>A pool cannot manage duplicate item names. Therefore, items in a pool +must have unique names.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><b><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span><o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Item equivalence<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>From +the point of view of the manager of a pool, items are equivalent. The manager +of a pool is indifferent about which entity/person occupies a given item. +However, clients may have preferences for a particular item, based on some item +property they know.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Preferences<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>A +future owner may have a preference for a particular item. Preference based +allocation is supported (see the <b>–prefer</b> option to the <i>request</i> +subcommand). A preference for a particular item is most likely to result from +variability among features associated with the items. Note that the pool +commands themselves are not designed to manage such item properties. If item +properties play a role in an application, they should be<span +style="mso-spacerun: yes"> </span>managed separately. <o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>POOL OBJECT COMMAND<o:p></o:p></span></b></p> + +<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size: +14.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +<i>pool</i> command creates a new Tcl command whose name is <i>poolName</i> . +This pool object command is used to manipulate or query the pool object. The +general syntax of a pool object command is:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span +style='mso-tab-count:1'> </span><i>poolName</i> <b>subcommand</b> <i>?arg +arg …?</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +following subcommands and corresponding arguments are available:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>add</b> <i>itemName1 ?itemName2 itemName3 ...?</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This +command adds the items on the command line to the pool. If duplicate item names +occur on the command line, an error is raised. If one or more of the items +already exist in the pool, this also is considered an error.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span +style='mso-tab-count:1'> </span><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>clear</b> <i>?-force?</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Removes +all items from the pool. If there are any allocated items at the time when the +command is invoked, an error is raised. This behaviour may be modified through +the <i>-force</i> argument. If it is supplied on the command line, the pool +will be cleared regardless the allocation state of its items.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>destroy</b> <i>?-force?<o:p></o:p></i></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Destroys +the pool data structure, all associated variables and the associated pool +object command. By default, the command checks whether any items are still +allocated and raises an error if such is the case. This behaviour may be +modified through the argument -<i>force</i>. If it is supplied on the command +line, the pool data structure will be destroyed regardless allocation state of +its items. <o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<span lang=EN-GB style='font-size:10.0pt;font-family:"Courier New";mso-fareast-font-family: +"Times New Roman";mso-ansi-language:EN-GB;mso-fareast-language:NL;mso-bidi-language: +AR-SA'><br clear=all style='page-break-before:always'> +</span> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>info</b> <i>type ?arg?<o:p></o:p></i></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:.5in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Returns +various information about the pool for further programmatic use. The type +argument indicates the type of information requested. Only the <i>allocID</i> +type uses an additional argument.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:.5in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>allocID </span></b><i><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>itemName<o:p></o:p></span></i></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>returns the allocID of the item whose name is <i>itemName.</i> +Free items have an allocation ID -1.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>allitems<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><span style='mso-tab-count:1'> </span></span></b><span +lang=EN-GB style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>returns a list of all items in the pool.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>allocstate<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>Returns a list of key-value pairs, where the keys are +the items and the values are the corresponding allocation ID's. Free +items have an allocation ID -1.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>cursize<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>returns the current pool size, i.e. the + number of items in the pool.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>freeitems</span></b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.5in;margin-bottom: +0in;margin-left:107.4pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>returns +a list of items that currently are not allocated.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>maxsize<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>returns the maximum size of the pool.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom: +0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>maxsize</b> <i>?maxsize?<o:p></o:p></i></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>Sets or queries the maximum size of the pool, +depending on whether the <i>maxsize</i> argument is supplied. If the optional +argument <i>maxsize</i> is supplied, the maximum size of the pool will<span +style="mso-spacerun: yes"> </span>be set to that value. If no argument <i>maxsize</i> +is supplied, the current maximum size of the pool is returned. In this variant, +the command is an alias for: </span><span lang=EN-GB style='font-size:10.5pt; +mso-bidi-font-size:10.0pt;mso-ansi-language:EN-GB'>poolName info maxsize</span><span +lang=EN-GB style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>The <i>maxsize</i> argument needs to be a positive +integer.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><span style="mso-spacerun: yes"> </span><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>release</b> <i>itemName<o:p></o:p></i></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>Releases the item whose name is <i>itemName</i> that +was allocated previously. An error is raised if the item was not allocated at +the time when the command was issued.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'><span style="mso-spacerun: yes"> </span><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>remove</b> <i>itemName ?-force?</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Removes +the item whose name is <i>itemName</i><span style="mso-spacerun: yes"> +</span>from the pool. If the item was allocated at the time when the command +was invoked, an error is raised. This behaviour may be modified through the +optional argument <i>-force</i>. If it is supplied on the command line, the +item will be removed regardless its allocation state.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<span lang=EN-GB style='font-size:10.0pt;font-family:"Courier New";mso-fareast-font-family: +"Times New Roman";mso-ansi-language:EN-GB;mso-fareast-language:NL;mso-bidi-language: +AR-SA'><br clear=all style='page-break-before:always'> +</span> + +<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <b>request</b> <i>itemVar ?options?</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Handles +a request for an item, taking into account a possible preference for a +particular item.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>There +are two possible outcomes depending on the availability of items:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:1.25in;text-indent:-19.2pt;mso-list: +l1 level1 lfo4'><![if !supportLists]><span lang=EN-GB style='font-size:11.0pt; +font-family:"Times New Roman";mso-ansi-language:EN-GB'>1.<span +style='font:7.0pt "Times New Roman"'> </span></span><![endif]><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>The request is honoured, an item is allocated and the variable whose +name is passed with the argument <i>itemVar</i> will be set to the name of the +item that was allocated. The command returns 1.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:1.25in;text-indent:-19.2pt;mso-list: +l1 level1 lfo4'><![if !supportLists]><span lang=EN-GB style='font-size:11.0pt; +font-family:"Times New Roman";mso-ansi-language:EN-GB'>2.<span +style='font:7.0pt "Times New Roman"'> </span></span><![endif]><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>The request is denied. No item is allocated. The variable whose name is <i>itemVar</i> +is not set. Attempts to read <i>itemVar</i><span style="mso-spacerun: yes"> +</span>may raise an error if the variable was not defined before issuing the +request. The command returns 0.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +return values from this command are meant to be inspected. The examples below +show how to do this. Failure to check the return value may result in erroneous +behaviour.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If +no preference for a particular item is supplied through the option <b>–prefer</b> +(see below), then all requests are honoured as long as items are available.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The +following options are supported:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><b><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-allocID</span></b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'> <i>allocID</i><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If +the request is honoured, an item will be allocated to the entity identified by <i>allocID</i>. +If the allocation state of an item is queried, it is this allocation ID that +will be returned. If the option <b>–allocID</b> is not supplied, the item will +be allocated to<span style="mso-spacerun: yes"> </span><i>dummyID</i>. +Allocation ID’s may be anything except the value -1, which is reserved for free +items.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:70.8pt'><b><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-prefer +</span></b><i><span lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>preferredItem</span></i><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This +option modifies the allocation strategy as follows:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If +the item whose name is <i>preferredItem</i> is not allocated at the time when +the command is invoked, the request is honoured (return value is 1). If the item +was allocated at the time when the command was invoked, the request is denied +(return value is 0).<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB +style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman"; +mso-ansi-language:EN-GB'>EXAMPLES<o:p></o:p></span></b></p> + +<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size: +14.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Two +examples are provided. The first one mimics a step by step interactive tclsh session, +where each step is explained. The second example shows the usage in a server +application that talks to a back-end application.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Example 1<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This +example presents an interactive tclsh session which considers the case of a Car +rental's collection of cars. Ten steps explain its usage in chronological +order, from the creation of the pool, via the most important stages in the +usage of a pool, to the final destruction.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:63.0pt;margin-bottom: +0in;margin-left:81.0pt;margin-bottom:.0001pt'><span lang=EN-GB +style='mso-bidi-font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Note aside:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-top:0in;margin-right:63.0pt;margin-bottom: +0in;margin-left:81.0pt;margin-bottom:.0001pt'><span lang=EN-GB +style='mso-bidi-font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>In this example, brand names are used to label the various items. +However, a brand name could be regarded as a property of an item. Because the <i>pool</i> +command is not designed to manage properties of items, they need to be managed +separately. In the latter case the items should be labelled with more neutral +names such as: car1, car2, car3 , etc ... and a separate database or array +should hold the brand names associated with the car labels.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>1. +Load the package into an interpreter<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +package require pool<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language: +EN-GB'>0.1<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>2. +Create a pool object called `CarPool' with a maximum size of 55 items (cars):<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +pool CarPool 55<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language: +EN-GB'>CarPool<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>4. +Add items to the pool:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span +style='mso-tab-count:1'> </span><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>5. +Somebody crashed the Toyota? Remove it from the pool as follows:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +CarPool remove Toyota<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>6. +Acquired a new car for the pool? Add it as follows:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +CarPool add Nissan<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>7. +Check whether the pool was adjusted correctly:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>% CarPool info allitems<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language: +EN-GB'>Trabant Chrysler1 Chrysler2 Volkswagen Nissan<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Suspend +interactive session temporarily, and show the programmatic use of the <b>request</b> +subcommand:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># +Mrs. Swift needs a car. She doesn't have a preference for a<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># +particular car. We'll issue a request on her behalf as follows:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if { +[CarPool request car -allocID "Mrs. Swift"] }<span +style="mso-spacerun: yes"> </span>{<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt;mso-outline-level: +1'><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt; +mso-ansi-language:EN-GB'># request was honoured, process the variable `car’<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>puts "$car has been allocated to [CarPool info allocID $car]."<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>} else {<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'># request was denied<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style='mso-tab-count:1'> </span>puts "No car available."<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>(note how the <b>if</b> command uses the value returned by the request +subcommand.)<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># +Suppose mr. Wiggly has a preference for the Trabant:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if { +[CarPool request car -allocID "Mr. Wiggly" –prefer Trabant] }<span +style="mso-spacerun: yes"> </span>{<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt;mso-outline-level: +1'><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt; +mso-ansi-language:EN-GB'># request was honoured, process the variable `car’<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>puts "$car has been allocated to [CarPool info allocID $car]."<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>} else {<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'># request was denied<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style='mso-tab-count:1'> </span>puts "The Trabant was not +available."<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Resume +interactive session:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>8. +When the car is returned then you can render it available by:<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +CarPool release Trabant<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>9. +When done, you delete the pool.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'>% CarPool destroy<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:#FF6600;mso-ansi-language: +EN-GB'>Couldn't destroy `CarPool' because some items are still allocated.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Oops, +… forgot that Mrs. Swift still occupies a car.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>10. +We force the destruction of the pool as follows: <o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>% +CarPool destroy -force<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span +lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language: +EN-GB'>Example 2<o:p></o:p></span></b></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This +example describes the case from which the author’s need for pool management +originated. It is an example of a server application that receives requests +from client applications. The client requests are dispatched onto a back-end +application before being returned to the client application. In many cases +there are a few equivalent instances of back-end applications to which a client +request may be passed along. The file descriptors that identify the channels to +these back-end instances make up a pool of connections. A particular connection +may be allocated to just one client request at a time.<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># Create +the pool of connections (pipes)<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>set +maxpipes 10<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>pool +Pipes $maxpipes<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>for +{set i 0} {$i < $maxpipes} {incr i} {<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size: +11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'> </span><span +style="mso-spacerun: yes"> </span>set fd {open “|backendApplication” w+}<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size: +11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'> </span><span +style="mso-spacerun: yes"> </span>Pipes add $fd<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size: +11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'> </span>}<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># A +client request comes in. The request is identified as `clientX’.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'># Dispatch it onto an instance of a back-end application<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if { +[Pipes request fd –allocID clientX] } {<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'><span style="mso-spacerun: yes"> </span># a connection was allocated<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span># communicate to the back-end application +via the variable `fd’<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span>puts $fd “someInstruction”<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span># ...... etc.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>} +else {<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span +lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language: +EN-GB'><span style="mso-spacerun: yes"> </span># all connections are +currently occupied<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span># store the client request in a queue for +later processing,<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span +style="mso-spacerun: yes"> </span># or return a “Server busy” message to the +client.<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +<p class=MsoPlainText style='mso-outline-level:1'><span lang=EN-GB +style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'># +</span><span lang=EN-GB style='font-family:"Times New Roman";mso-ansi-language: +EN-GB'>CVS: $Id: pool.html,v 1.2 2004/01/15 06:36:14 andreas_kupries Exp $<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'># EOF pool.html<o:p></o:p></span></p> + +<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family: +"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]> <![endif]><o:p></o:p></span></p> + +</div> + +</body> + +</html> diff --git a/tcllib/modules/struct/pool.man b/tcllib/modules/struct/pool.man new file mode 100644 index 0000000..afe8e24 --- /dev/null +++ b/tcllib/modules/struct/pool.man @@ -0,0 +1,443 @@ +[comment {-*- tcl -*-}] +[vset VERSION 1.2.3] +[manpage_begin struct::pool n [vset VERSION]] +[keywords {discrete items}] +[keywords finite] +[keywords pool] +[keywords struct] +[copyright {2002, Erik Leunissen <e.leunissen@hccnet.nl>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate pool objects (of discrete items)}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::pool [opt [vset VERSION]]] +[description] +[para] + +This package provides pool objects which can be used to manage +finite collections of discrete items. + +[list_begin definitions] + +[call [cmd ::struct::pool] [opt [arg poolName]] [opt [arg maxsize]]] + +Creates a new pool object. If no [arg poolName] is supplied, then the +new pool will be named pool[var X], where X is a positive integer. +The optional second argument [arg maxsize] has to be a positive +integer indicating the maximum size of the pool; this is the maximum +number of items the pool may hold. The default for this value is +[const 10]. + +[para] + +The pool object has an associated global Tcl command whose name is +[arg poolName]. This command may be used to invoke various +configuration operations on the report. It has the following general +form: + +[list_begin definitions] +[call [cmd poolName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. See section [sectref {POOL OBJECT COMMAND}] for a detailed +list of options and their behaviour. + +[list_end] +[list_end] + +[para] + +[section {POOLS AND ALLOCATION}] + +The purpose of the pool command and the pool object command that it +generates, is to manage pools of discrete items. + +Examples of a pool of discrete items are: + +[list_begin itemized] + +[item] +the seats in a cinema, theatre, train etc.. for which visitors/travelers can make a reservation; +[item] +the dynamic IP-addresses that an ISP can dole out to subscribers; +[item] +a car rental's collection of cars, which can be rented by customers; +[item] +the class rooms in a school building, which need to be scheduled; +[item] +the database connections available to client-threads in a web-server application; +[item] +the books in a library that customers can borrow; +[item] +etc ... + +[list_end] +[para] + +The common denominator in the examples is that there is a more or less +fixed number of items (seats, IP-addresses, cars, ...) that are +supposed to be allocated on a more or less regular basis. An item can +be allocated only once at a time. An item that is allocated, must be +released before it can be re-allocated. While several items in a pool +are being allocated and released continuously, the total number of +items in the pool remains constant. + +[para] + +Keeping track of which items are allocated, and by whom, is the +purpose of the pool command and its subordinates. + +[para] + +[emph {Pool parlance}]: If we say that an item is + +[term allocated], it means that the item is [term busy], + +[term owned] or [term occupied]; it is not available anymore. If +an item is [term free], it is [term available]. Deallocating an +item is equivalent to setting free or releasing an item. The person or +entity to which the item has been allotted is said to own the item. + +[section ITEMS] + +[emph {Discrete items}] +[para] + +The [cmd pool] command is designed for + +[emph {discrete items only}]. Note that there are pools where +allocation occurs on a non-discrete basis, for example computer +memory. There are also pools from which the shares that are doled out +are not expected to be returned, for example a charity fund or a pan +of soup from which you may receive a portion. Finally, there are even +pools from which nothing is ever allocated or returned, like a +swimming pool or a cesspool. + +[para] +[emph {Unique item names}] +[para] + +A pool cannot manage duplicate item names. Therefore, items in a pool +must have unique names. + +[para] +[emph {Item equivalence}] +[para] + +From the point of view of the manager of a pool, items are +equivalent. The manager of a pool is indifferent about which +entity/person occupies a given item. However, clients may have +preferences for a particular item, based on some item property they +know. + +[para] +[emph Preferences] +[para] + +A future owner may have a preference for a particular item. Preference +based allocation is supported (see the [option -prefer] option to the +request subcommand). A preference for a particular item is most likely +to result from variability among features associated with the +items. Note that the pool commands themselves are not designed to +manage such item properties. If item properties play a role in an +application, they should be managed separately. + +[section {POOL OBJECT COMMAND}] + +The following subcommands and corresponding arguments are available to +any pool object command. + +[list_begin definitions] + +[call [arg poolName] [method add] [arg itemName1] [opt [arg {itemName2 itemName3 ...}]]] + +This command adds the items on the command line to the pool. If +duplicate item names occur on the command line, an error is raised. If +one or more of the items already exist in the pool, this also is +considered an error. + +[call [arg poolName] [method clear] [opt [option -force]]] + +Removes all items from the pool. If there are any allocated items at +the time when the command is invoked, an error is raised. This +behaviour may be modified through the [option -force] argument. If it +is supplied on the command line, the pool will be cleared regardless +the allocation state of its items. + +[call [arg poolName] [method destroy] [opt [option -force]]] + +Destroys the pool data structure, all associated variables and the +associated pool object command. By default, the command checks whether +any items are still allocated and raises an error if such is the +case. This behaviour may be modified through the argument + +[option -force]. If it is supplied on the command line, the pool data +structure will be destroyed regardless allocation state of its items. + +[call [arg poolName] [method info] [arg type] [opt [arg arg]]] + +Returns various information about the pool for further programmatic +use. The [arg type] argument indicates the type of information +requested. Only the type [const allocID] uses an additional argument. + +[list_begin definitions] + +[def "[const allocID] [arg itemName]"] + +returns the allocID of the item whose name is [arg itemName]. Free +items have an allocation id of [const -1]. + +[def [const allitems]] + +returns a list of all items in the pool. + +[def [const allocstate]] + +Returns a list of key-value pairs, where the keys are the items and +the values are the corresponding allocation id's. Free items have an +allocation id of [const -1]. + +[def [const cursize]] + +returns the current pool size, i.e. the number of items in the pool. + +[def [const freeitems]] + +returns a list of items that currently are not allocated. + +[def [const maxsize]] + +returns the maximum size of the pool. + +[list_end] +[para] + +[call [arg poolName] [method maxsize] [opt [arg maxsize]]] + +Sets or queries the maximum size of the pool, depending on whether the +[arg maxsize] argument is supplied or not. If [arg maxsize] is +supplied, the maximum size of the pool will be set to that value. If +no argument is supplied, the current maximum size of the pool is +returned. In this variant, the command is an alias for: + +[para] +[cmd {poolName info maxsize}]. +[para] + +The [arg maxsize] argument has to be a positive integer. + +[call [arg poolName] [method release] [arg itemName]] + +Releases the item whose name is [arg itemName] that was allocated +previously. An error is raised if the item was not allocated at the +time when the command was issued. + +[call [arg poolName] [method remove] [arg itemName] [opt [option -force]]] + +Removes the item whose name is [arg itemName] from the pool. If the +item was allocated at the time when the command was invoked, an error +is raised. This behaviour may be modified through the optional +argument [option -force]. If it is supplied on the command line, the +item will be removed regardless its allocation state. + +[call [arg poolName] [method request] itemVar [opt options]] + +Handles a request for an item, taking into account a possible +preference for a particular item. There are two possible outcomes +depending on the availability of items: + +[list_begin enumerated] + +[enum] + +The request is honoured, an item is allocated and the variable whose +name is passed with the argument [arg itemVar] will be set to the name +of the item that was allocated. The command returns 1. + +[enum] + +The request is denied. No item is allocated. The variable whose name +is itemVar is not set. Attempts to read [arg itemVar] may raise an +error if the variable was not defined before issuing the request. The +command returns 0. + +[list_end] +[para] + +The return values from this command are meant to be inspected. The +examples below show how to do this. Failure to check the return value +may result in erroneous behaviour. If no preference for a particular +item is supplied through the option [option -prefer] (see below), then +all requests are honoured as long as items are available. + +[para] +The following options are supported: + +[list_begin definitions] + +[def "[option -allocID] [arg allocID]"] + +If the request is honoured, an item will be allocated to the entity +identified by allocID. If the allocation state of an item is queried, +it is this allocation ID that will be returned. If the option + +[option -allocID] is not supplied, the item will be given to and owned +by [const dummyID]. Allocation id's may be anything except the value +-1, which is reserved for free items. + +[def "[option -prefer] [arg preferredItem]"] + +This option modifies the allocation strategy as follows: If the item +whose name is [arg preferredItem] is not allocated at the time when +the command is invoked, the request is honoured (return value is +1). If the item was allocated at the time when the command was +invoked, the request is denied (return value is 0). + +[list_end] +[list_end] + +[section EXAMPLES] + +Two examples are provided. The first one mimics a step by step +interactive tclsh session, where each step is explained. The second +example shows the usage in a server application that talks to a +back-end application. + +[para] +[emph {Example 1}] +[para] + +This example presents an interactive tclsh session which considers the +case of a Car rental's collection of cars. Ten steps explain its usage +in chronological order, from the creation of the pool, via the most +important stages in the usage of a pool, to the final destruction. + +[para] +[emph {Note aside:}] +[para] + +In this example, brand names are used to label the various +items. However, a brand name could be regarded as a property of an +item. Because the pool command is not designed to manage properties of +items, they need to be managed separately. In the latter case the +items should be labeled with more neutral names such as: car1, car2, +car3 , etc ... and a separate database or array should hold the brand +names associated with the car labels. + +[para] +[example { + 1. Load the package into an interpreter + % package require pool + 0.1 + + 2. Create a pool object called `CarPool' with a maximum size of 55 items (cars): + % pool CarPool 55 + CarPool + + 4. Add items to the pool: + % CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen + + 5. Somebody crashed the Toyota. Remove it from the pool as follows: + % CarPool remove Toyota + + 6. Acquired a new car for the pool. Add it as follows: + % CarPool add Nissan + + 7. Check whether the pool was adjusted correctly: + % CarPool info allitems + Trabant Chrysler1 Chrysler2 Volkswagen Nissan +}] + +[para] + +Suspend the interactive session temporarily, and show the programmatic +use of the request subcommand: + +[para] +[example { + # Mrs. Swift needs a car. She doesn't have a preference for a + # particular car. We'll issue a request on her behalf as follows: + if { [CarPool request car -allocID "Mrs. Swift"] } { + # request was honoured, process the variable `car' + puts "$car has been allocated to [CarPool info allocID $car]." + } else { + # request was denied + puts "No car available." + } +}] +[para] + +Note how the [cmd if] command uses the value returned by the +[method request] subcommand. + +[para] +[example { + # Suppose Mr. Wiggly has a preference for the Trabant: + if { [CarPool request car -allocID "Mr. Wiggly" -prefer Trabant] } { + # request was honoured, process the variable `car' + puts "$car has been allocated to [CarPool info allocID $car]." + } else { + # request was denied + puts "The Trabant was not available." + } +}] +[para] + +Resume the interactive session: + +[para] +[example { + 8. When the car is returned then you can render it available by: + % CarPool release Trabant + + 9. When done, you delete the pool. + % CarPool destroy + Couldn't destroy `CarPool' because some items are still allocated. + + Oops, forgot that Mrs. Swift still occupies a car. + + 10. We force the destruction of the pool as follows: + % CarPool destroy -force +}] + +[para] +[emph {Example 2}] +[para] + +This example describes the case from which the author's need for pool +management originated. It is an example of a server application that +receives requests from client applications. The client requests are +dispatched onto a back-end application before being returned to the +client application. In many cases there are a few equivalent instances +of back-end applications to which a client request may be passed +along. The file descriptors that identify the channels to these +back-end instances make up a pool of connections. A particular +connection may be allocated to just one client request at a time. + +[para] +[example { + # Create the pool of connections (pipes) + set maxpipes 10 + pool Pipes $maxpipes + for {set i 0} {$i < $maxpipes} {incr i} { + set fd [open "|backendApplication" w+] + Pipes add $fd + } + + # A client request comes in. The request is identified as `clientX'. + # Dispatch it onto an instance of a back-end application + if { [Pipes request fd -allocID clientX] } { + # a connection was allocated + # communicate to the back-end application via the variable `fd' + puts $fd "someInstruction" + # ...... etc. + } else { + # all connections are currently occupied + # store the client request in a queue for later processing, + # or return a 'Server busy' message to the client. + } +}] + +[vset CATEGORY {struct :: pool}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/pool.tcl b/tcllib/modules/struct/pool.tcl new file mode 100644 index 0000000..e2557ce --- /dev/null +++ b/tcllib/modules/struct/pool.tcl @@ -0,0 +1,715 @@ +################################################################################ +# pool.tcl +# +# +# Author: Erik Leunissen +# +# +# Acknowledgement: +# The author is grateful for the advice provided by +# Andreas Kupries during the development of this code. +# +################################################################################ + +package require cmdline + +namespace eval ::struct {} +namespace eval ::struct::pool { + + # a list of all current pool names + variable pools {} + + # counter is used to give a unique name to a pool if + # no name was supplied, e.g. pool1, pool2 etc. + variable counter 0 + + # `commands' is the list of subcommands recognized by a pool-object command + variable commands {add clear destroy info maxsize release remove request} + + # All errors with corresponding (unformatted) messages. + # The format strings will be replaced by the appropriate + # values when an error occurs. + variable Errors + array set Errors { + BAD_SUBCMD {Bad subcommand "%s": must be %s} + DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} + DUPLICATE_POOLNAME {The pool `%s' already exists.} + EXCEED_MAXSIZE "This command would increase the total number of items\ + \nbeyond the maximum size of the pool. No items registered." + FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." + INVALID_POOLSIZE {The pool currently holds %s items.\ + Can't set maxsize to a value less than that.} + ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} + ITEM_NOT_IN_POOL {`%s' is not a member of %s.} + ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} + ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} + NONINT_REQSIZE {The second argument must be a positive integer value} + SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} + UNKNOWN_ARG {Unknown argument `%s'} + UNKNOWN_POOL {Nothing known about `%s'.} + VARNAME_EXISTS {A variable `::struct::pool::%s' already exists.} + WRONG_INFO_TYPE "Expected second argument to be one of:\ + \n allitems, allocstate, cursize, freeitems, maxsize,\ + \nbut received: `%s'." + WRONG_NARGS "wrong#args" + } + + namespace export pool +} + +# A small helper routine to generate structured errors + +if {[package vsatisfies [package present Tcl] 8.5]} { + # Tcl 8.5+, have expansion operator and syntax. And option -level. + proc ::struct::pool::Error {error args} { + variable Errors + return -code error -level 1 \ + -errorcode [list STRUCT POOL $error {*}$args] \ + [format $Errors($error) {*}$args] + } +} else { + # Tcl 8.4. No expansion operator available. Nor -level. + # Construct the pieces explicitly, via linsert/eval hop&dance. + proc ::struct::pool::Error {error args} { + variable Errors + lappend code STRUCT POOL $error + eval [linsert $args 0 lappend code] + set msg [eval [linsert $args 0 format $Errors($error)]] + return -code error -errorcode $code $msg + } +} + +# A small helper routine to check list membership +proc ::struct::pool::lmember {list element} { + if { [lsearch -exact $list $element] >= 0 } { + return 1 + } else { + return 0 + } +} + +# General note +# ============ +# +# All procedures below use the following method to reference +# a particular pool-object: +# +# variable $poolname +# upvar #0 ::struct::pool::$poolname pool +# upvar #0 ::struct::pool::Allocstate_$poolname state +# +# Therefore, the names `pool' and `state' refer to a particular +# instance of a pool. +# +# In the comments to the code below, the words `pool' and `state' +# also refer to a particular pool. +# + +# ::struct::pool::create +# +# Creates a new instance of a pool (a pool-object). +# ::struct::pool::pool (see right below) is an alias to this procedure. +# +# +# Arguments: +# poolname: name of the pool-object +# maxsize: the maximum number of elements that the pool is allowed +# consist of. +# +# +# Results: +# the name of the newly created pool +# +# +# Side effects: +# - Registers the pool-name in the variable `pools'. +# +# - Creates the pool array which holds general state about the pool. +# The following elements are initialized: +# pool(freeitems): a list of non-allocated items +# pool(cursize): the current number of elements in the pool +# pool(maxsize): the maximum allowable number of pool elements +# Additional state may be hung off this array as long as the three +# elements above are not corrupted. +# +# - Creates a separate array `state' that will hold allocation state +# of the pool elements. +# +# - Creates an object-procedure that has the same name as the pool. +# +proc ::struct::pool::create { {poolname ""} {maxsize 10} } { + variable pools + variable counter + + # check maxsize argument + if { ![string equal $maxsize 10] } { + if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { + Error NONINT_REQSIZE + } + } + + # create a name if no name was supplied + if { [string length $poolname]==0 } { + incr counter + set poolname pool$counter + set incrcnt 1 + } + + # check whether there exists a pool named $poolname + if { [lmember $pools $poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error DUPLICATE_POOLNAME $poolname + } + + # check whether the namespace variable exists + if { [::info exists ::struct::pool::$poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error VARNAME_EXISTS $poolname + } + + variable $poolname + + # register + lappend pools $poolname + + # create and initialize the new pool data structure + upvar #0 ::struct::pool::$poolname pool + set pool(freeitems) {} + set pool(maxsize) $maxsize + set pool(cursize) 0 + + # the array that holds allocation state + upvar #0 ::struct::pool::Allocstate_$poolname state + array set state {} + + # create a pool-object command and map it to the pool commands + interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname + return $poolname +} + +# +# This alias provides compatibility with the implementation of the +# other data structures (stack, queue etc...) in the tcllib::struct package. +# +proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { + ::struct::pool::create $poolname $maxsize +} + + +# ::struct::pool::poolCmd +# +# This proc constitutes a level of indirection between the pool-object +# subcommand and the pool commands (below); it's sole function is to pass +# the command along to one of the pool commands, and receive any results. +# +# Arguments: +# poolname: name of the pool-object +# subcmd: the subcommand, which identifies the pool-command to +# which calls will be passed. +# args: any arguments. They will be inspected by the pool-command +# to which this call will be passed along. +# +# Results: +# Whatever result the pool command returns, is once more returned. +# +# Side effects: +# Dispatches the call onto a specific pool command and receives any results. +# +proc ::struct::pool::poolCmd {poolname subcmd args} { + # check the subcmd argument + if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { + set optlist [join $::struct::pool::commands ", "] + set optlist [linsert $optlist "end-1" "or"] + Error BAD_SUBCMD $subcmd $optlist + } + + # pass the call to the pool command indicated by the subcmd argument, + # and return the result from that command. + return [eval [linsert $args 0 ::struct::pool::$subcmd $poolname]] +} + + +# ::struct::pool::destroy +# +# Destroys a pool-object, its associated variables and "object-command" +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', the pool-object will be destroyed +# regardless the allocation state of its objects. +# +# Results: +# none +# +# Side effects: +# - unregisters the pool name in the variable `pools'. +# - unsets `pool' and `state' (poolname specific variables) +# - destroys the "object-procedure" that was associated with the pool. +# +proc ::struct::pool::destroy {poolname {forceArg ""}} { + variable pools + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + set index [lsearch -exact $pools $poolname] + if {$index == -1 } { + Error UNKNOWN_POOL $poolname + } + + if { !$force } { + # check for any lingering allocated items + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE destroy $poolname + } + } + + rename ::$poolname {} + unset ::struct::pool::$poolname + catch {unset ::struct::pool::Allocstate_$poolname} + set pools [lreplace $pools $index $index] + + return +} + + +# ::struct::pool::add +# +# Add items to the pool +# +# Arguments: +# poolname: name of the pool-object +# args: the items to add +# +# Results: +# none +# +# Side effects: +# sets the initial allocation state of the added items to -1 (free) +# +proc ::struct::pool::add {poolname args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # argument check + if { [llength $args] == 0 } { + Error WRONG_NARGS + } + + # will this operation exceed the size limit of the pool? + if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { + Error EXCEED_MAXSIZE + } + + + # check for duplicate items on the command line + set N [llength $args] + if { $N > 1} { + for {set i 0} {$i<=$N} {incr i} { + foreach item [lrange $args [expr {$i+1}] end] { + if { [string equal [lindex $args $i] $item]} { + Error DUPLICATE_ITEM_IN_ARGS $item + } + } + } + } + + # check whether the items exist yet in the pool + foreach item $args { + if { [lmember [array names state] $item] } { + Error ITEM_ALREADY_IN_POOL $item + } + } + + # add items to the pool, and initialize their allocation state + foreach item $args { + lappend pool(freeitems) $item + set state($item) -1 + incr pool(cursize) + } + return +} + + + +# ::struct::pool::clear +# +# Removes all items from the pool and clears corresponding +# allocation state. +# +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', all items are removed +# regardless their allocation state. +# +# Results: +# none +# +# Side effects: +# see description above +# +proc ::struct::pool::clear {poolname {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # check whether some items are still allocated + if { !$force } { + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE clear $poolname + } + } + + # clear the pool, clean up state and adjust the pool size + set pool(freeitems) {} + array unset state + array set state {} + set pool(cursize) 0 + return +} + + + +# ::struct::pool::info +# +# Returns information about the pool in data structures that allow +# further programmatic use. +# +# Arguments: +# poolname: name of the pool-object +# type: the type of info requested +# +# +# Results: +# The info requested +# +# +# Side effects: +# none +# +proc ::struct::pool::info {poolname type args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check the number of arguments + if { [string equal $type allocID] } { + if { [llength $args]!=1 } { + Error WRONG_NARGS + } + } elseif { [llength $args] > 0 } { + Error WRONG_NARGS + } + + switch $type { + allitems { + return [array names state] + } + allocstate { + return [array get state] + } + allocID { + set item [lindex $args 0] + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + return $state($item) + } + cursize { + return $pool(cursize) + } + freeitems { + return $pool(freeitems) + } + maxsize { + return $pool(maxsize) + } + default { + Error WRONG_INFO_TYPE $type + } + } +} + + +# ::struct::pool::maxsize +# +# Returns the current or sets a new maximum size of the pool. +# As far as querying only is concerned, this is an alias for +# `::struct::pool::info maxsize'. +# +# +# Arguments: +# poolname: name of the pool-object +# reqsize: if supplied, it is the requested size of the pool, i.e. +# the maximum number of elements in the pool. +# +# +# Results: +# The current/new maximum size of the pool. +# +# +# Side effects: +# Sets pool(maxsize) if a new size is supplied. +# +proc ::struct::pool::maxsize {poolname {reqsize ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + if { [string length $reqsize] } { + if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { + if { $pool(cursize) <= $reqsize } { + set pool(maxsize) $reqsize + } else { + Error INVALID_POOLSIZE $pool(cursize) + } + } else { + Error NONINT_REQSIZE + } + } + return $pool(maxsize) +} + + +# ::struct::pool::release +# +# Deallocates an item +# +# +# Arguments: +# poolname: name of the pool-object +# item: name of the item to be released +# +# +# Results: +# none +# +# Side effects: +# - sets the item's allocation state to free (-1) +# - appends item to the list of free items +# +proc ::struct::pool::release {poolname item} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + # check whether item was allocated + if { $state($item) == -1 } { + Error ITEM_NOT_ALLOCATED $item + } else { + + # set item free and return it to the pool of free items + set state($item) -1 + lappend pool(freeitems) $item + + } + return +} + +# ::struct::pool::remove +# +# Removes an item from the pool +# +# +# Arguments: +# poolname: name of the pool-object +# item: the item to be removed +# forceArg: if set to `-force', the item is removed +# regardless its allocation state. +# +# Results: +# none +# +# Side effects: +# - cleans up allocation state related to the item +# +proc ::struct::pool::remove {poolname item {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + set index [lsearch $pool(freeitems) $item] + if { $index >= 0} { + + # actual removal + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + + } elseif { !$force } { + Error ITEM_STILL_ALLOCATED $item + } + + # clean up state and adjust the pool size + unset state($item) + incr pool(cursize) -1 + return +} + + + +# ::struct::pool::request +# +# Handles requests for an item, taking into account a preference +# for a particular item if supplied. +# +# +# Arguments: +# poolname: name of the pool-object +# +# itemvar: variable to which the item-name will be assigned +# if the request is honored. +# +# args: an optional sequence of key-value pairs, indicating the +# following options: +# -prefer: the preferred item to allocate. +# -allocID: An ID for the entity to which the item will be +# allocated. This facilitates reverse lookups. +# +# Results: +# +# 1 if the request was honored; an item is allocated +# 0 if the request couldn't be honored; no item is allocated +# +# The user is strongly advised to check the return values +# when calling this procedure. +# +# +# Side effects: +# +# if the request is honored: +# - sets allocation state to $allocID (or dummyID if it was not supplied) +# if allocation was succesful. Allocation state is maintained in the +# namespace variable state (see: `General note' above) +# - sets the variable passed via `itemvar' to the allocated item. +# +# if the request is denied, no side effects occur. +# +proc ::struct::pool::request {poolname itemvar args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check args + set nargs [llength $args] + if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { + if { ![string equal $args -?] && ![string equal $args -help]} { + Error WRONG_NARGS + } + } elseif { $nargs } { + foreach {name value} $args { + if { ![string match -* $name] } { + Error UNKNOWN_ARG $name + } + } + } + + set allocated 0 + + # are there any items available? + if { [llength $pool(freeitems)] > 0} { + + # process command options + set options [cmdline::getoptions args { \ + {prefer.arg {} {The preference for a particular item}} \ + {allocID.arg {} {An ID for the entity to which the item will be allocated} } \ + } \ + "usage: $poolname request itemvar ?options?:"] + foreach {key value} $options { + set $key $value + } + + if { $allocID == -1 } { + Error FORBIDDEN_ALLOCID + } + + # let `item' point to a variable two levels up the call stack + upvar 2 $itemvar item + + # check whether a preference was supplied + if { [string length $prefer] } { + if {![lmember [array names state] $prefer]} { + Error ITEM_NOT_IN_POOL $prefer $poolname + } + if { $state($prefer) == -1 } { + set index [lsearch $pool(freeitems) $prefer] + set item $prefer + } else { + return 0 + } + } else { + set index 0 + set item [lindex $pool(freeitems) 0] + } + + # do the actual allocation + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + if { [string length $allocID] } { + set state($item) $allocID + } else { + set state($item) dummyID + } + set allocated 1 + } + return $allocated +} + + +# EOF pool.tcl + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'pool::pool' into the general structure namespace. + namespace import -force pool::pool + namespace export pool +} +package provide struct::pool 1.2.3 diff --git a/tcllib/modules/struct/pool.test b/tcllib/modules/struct/pool.test new file mode 100644 index 0000000..8a171f8 --- /dev/null +++ b/tcllib/modules/struct/pool.test @@ -0,0 +1,202 @@ +# -*- tcl -*- +# pool.test: tests for the pool package. + +# Copyright (c) 2006,2015 Andreas Kupries +# All rights reserved. +# +# RCS: @(#) $Id: pool.test,v 1.4 2006/10/09 21:41:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal pool.tcl struct::pool +} + +# ------------------------------------------------------------------------- + +namespace import struct::pool + +#---------------------------------------------------------------------- + +test pool-0.1 {pool errors, DUPLICATE_POOLNAME} { + pool mypool + catch {pool mypool} msg + mypool destroy + set msg +} "The pool `mypool' already exists." + +test pool-0.2 {pool errors, VARNAME_EXISTS} { + set ::struct::pool::existvar 1 + catch {struct::pool::create existvar} errmsg + unset ::struct::pool::existvar + set errmsg +} {A variable `::struct::pool::existvar' already exists.} + +test pool-0.3 {pool errors, NONINT_REQSIZE} { + catch {pool mypool noninteger} errmsg + set errmsg +} {The second argument must be a positive integer value} + +test pool-0.4 {pool errors, NONINT_REQSIZE} { + pool mypool + catch {mypool maxsize noninteger} errmsg + mypool destroy + set errmsg +} {The second argument must be a positive integer value} + +test pool-0.5 {pool errors, UNKNOWN_POOL} { + catch {struct::pool::destroy NonExistentPool} errmsg + set errmsg +} {Nothing known about `NonExistentPool'.} + +test pool-0.6 {pool errors, BAD_SUBCMD} { + pool mypool + catch {mypool badsubcommand whateverargs} errmsg + mypool destroy + set errmsg +} {Bad subcommand "badsubcommand": must be add, clear, destroy, info, maxsize, release, remove, or request} + +test pool-0.7 {pool errors, SOME_ITEMS_NOT_FREE} { + pool mypool + mypool add foo + mypool request item + catch {mypool clear} errmsg + mypool release $item + mypool destroy + set errmsg +} {Couldn't clear `mypool' because some items are still allocated.} + +test pool-0.8 {pool errors, SOME_ITEMS_NOT_FREE} { + pool mypool + mypool add foo + mypool request item + catch {mypool destroy} errmsg + mypool release $item + mypool destroy + set errmsg +} {Couldn't destroy `mypool' because some items are still allocated.} + +test pool-0.9 {pool errors, DUPLICATE_ITEM_IN_ARGS} { + pool mypool + catch {mypool add foo foo} errmsg + mypool destroy + set errmsg +} {Duplicate item `foo' in arguments.} + +test pool-0.10 {pool errors, FORBIDDEN_ALLOCID} { + pool mypool + mypool add foo + catch {mypool request item -allocID -1} errmsg + mypool destroy + set errmsg +} {The value -1 is not allowed as an allocID.} + +test pool-0.11 {pool errors, ITEM_ALREADY_IN_POOL} { + pool mypool + mypool add foo + catch {mypool add foo} errmsg + mypool destroy + set errmsg +} {`foo' already is a member of the pool. No items registered.} + +test pool-0.12 {pool errors, ITEM_STILL_ALLOCATED} { + pool mypool + mypool add foo bar + mypool request item -prefer foo + catch {mypool remove foo} errmsg + mypool release $item + mypool destroy + set errmsg +} {Can't remove `foo' because it is still allocated.} + +test pool-0.13 {pool errors, ITEM_NOT_ALLOCATED} { + pool mypool + mypool add foo + catch {mypool release foo} errmsg + mypool destroy + set errmsg +} {Can't release `foo' because it isn't allocated.} + +test pool-0.14 {pool errors, EXCEED_MAXSIZE} { + pool mypool + mypool maxsize 8 + catch {mypool add 1 2 3 4 5 6 7 8 9} errmsg + mypool destroy + set errmsg +} {This command would increase the total number of items +beyond the maximum size of the pool. No items registered.} + +test pool-0.15 {pool errors, WRONG_INFO_TYPE} { + pool mypool + catch {mypool info wronginfotype} errmsg + mypool destroy + set errmsg +} {Expected second argument to be one of: + allitems, allocstate, cursize, freeitems, maxsize, +but received: `wronginfotype'.} + + +test pool-0.16 {pool errors, INVALID_POOLSIZE} { + pool mypool + mypool maxsize 8 + mypool add 1 2 3 4 5 6 7 8 + catch {mypool maxsize 7} errmsg + mypool destroy + set errmsg +} {The pool currently holds 8 items. Can't set maxsize to a value less than that.} + + +foreach {n cmd} { + 1 {mypool info allocID foo} + 2 {mypool request item -prefer foo} + 3 {mypool release foo} + 4 {mypool remove foo} +} { + test pool-0.17.$n {pool errors, ITEM_NOT_IN_POOL} { + pool mypool + mypool add bar + catch $cmd errmsg + mypool destroy + set errmsg + } {`foo' is not a member of mypool.} +} + +foreach {n cmd} { + 1 {mypool clear unknownarg} + 2 {mypool request item unknownarg foo} + 3 {mypool destroy unknownarg} + 4 {mypool remove foo unknownarg} +} { + test pool-0.18.$n {pool errors, UNKNOWN_ARG} { + pool mypool + mypool add bar + catch $cmd errmsg + mypool destroy + set errmsg + } {Unknown argument `unknownarg'} +} + +foreach {n cmd} { + 1 {mypool add} + 2 {mypool info cursize oneargtomany} + 3 {mypool info allocID} + 4 {mypool info allocID bar oneargtomany} + 5 {mypool request item bar -prefer me} +} { + test pool-0.19.$n {pool errors, WRONG_ARGS} { + pool mypool + mypool add bar + catch $cmd errmsg + mypool destroy + set errmsg + } "wrong\#args" +} + +testsuiteCleanup diff --git a/tcllib/modules/struct/prioqueue.man b/tcllib/modules/struct/prioqueue.man new file mode 100644 index 0000000..3a3cf20 --- /dev/null +++ b/tcllib/modules/struct/prioqueue.man @@ -0,0 +1,111 @@ +[manpage_begin struct::prioqueue n 1.4] +[keywords {ordered list}] +[keywords prioqueue] +[keywords {priority queue}] +[moddesc {Tcl Data Structures}] +[copyright {2003 Michael Schlenker <mic42@users.sourceforge.net>}] +[titledesc {Create and manipulate prioqueue objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::prioqueue [opt 1.4]] +[description] + +This package implements a simple priority queue using nested tcl lists. + +[para] + +The command [cmd ::struct::prioqueue] creates a new priority queue +with default priority key type [arg -integer]. This means that keys +given to the [method put] subcommand must have this type. + +[para] + +This also sets the priority ordering. For key types [arg -ascii] and +[arg -dictionary] the data is sorted in ascending order (as with +[cmd lsort] [arg -increasing]), thereas for [arg -integer] and +[arg -real] the data is sorted in descending order (as with +[cmd lsort] [arg -decreasing]). + +[para] + +Prioqueue names are unrestricted, but may be recognized as options if +no priority type is given. + +[list_begin definitions] + +[call [cmd ::struct::prioqueue] [opt [option {-ascii|-dictionary|-integer|-real}]] [opt [arg prioqueueName]] ] + +The [cmd ::struct::prioqueue] command creates a new prioqueue object +with an associated global Tcl command whose name is + +[emph prioqueueName]. This command may be used to invoke various +operations on the prioqueue. It has the following general form: + +[call [arg prioqueueName] [cmd option] [opt [arg {arg arg ...}]]] + +[cmd option] and the [arg arg]s determine the exact behavior of the +command. The following commands are possible for prioqueue objects: + +[call [arg prioqueueName] [cmd clear]] + +Remove all items from the prioqueue. + +[call [arg prioqueueName] [cmd remove] [arg item]] + +Remove the selected item from this priority queue. + +[call [arg prioqueueName] [cmd destroy]] + +Destroy the prioqueue, including its storage space and associated +command. + +[call [arg prioqueueName] [cmd get] [opt [arg count]]] + +Return the front [arg count] items of the prioqueue (but not their +priorities) and remove them from the prioqueue. + +If [arg count] is not specified, it defaults to 1. If [arg count] is +1, the result is a simple string; otherwise, it is a list. If +specified, [arg count] must be greater than or equal to 1. If there +are no or too few items in the prioqueue, this command will throw an +error. + +[call [arg prioqueueName] [cmd peek] [opt [arg count]]] + +Return the front [arg count] items of the prioqueue (but not their +priorities), without removing them from the prioqueue. + +If [arg count] is not specified, it defaults to 1. If [arg count] is +1, the result is a simple string; otherwise, it is a list. If +specified, [arg count] must be greater than or equal to 1. If there +are no or too few items in the queue, this command will throw an +error. + +[call [arg prioqueueName] [cmd peekpriority] [opt [arg count]]] + +Return the front [arg count] items priority keys, without removing +them from the prioqueue. + +If [arg count] is not specified, it defaults to 1. If [arg count] is +1, the result is a simple string; otherwise, it is a list. If +specified, [arg count] must be greater than or equal to 1. If there +are no or too few items in the queue, this command will throw an +error. + +[call [arg prioqueueName] [cmd put] [arg {item prio}] [opt [arg {item prio ...}]]] + +Put the [arg item] or items specified into the prioqueue. [arg prio] +must be a valid priority key for this type of prioqueue, otherwise an +error is thrown and no item is added. Items are inserted at their +priority ranking. Items with equal priority are added in the order +they were added. + +[call [arg prioqueueName] [cmd size]] + +Return the number of items in the prioqueue. + +[list_end] + +[vset CATEGORY {struct :: prioqueue}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/prioqueue.tcl b/tcllib/modules/struct/prioqueue.tcl new file mode 100644 index 0000000..44f657d --- /dev/null +++ b/tcllib/modules/struct/prioqueue.tcl @@ -0,0 +1,535 @@ +# prioqueue.tcl -- +# +# Priority Queue implementation for Tcl. +# +# adapted from queue.tcl +# Copyright (c) 2002,2003 Michael Schlenker +# Copyright (c) 2008 Alejandro Paz <vidriloco@gmail.com> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: prioqueue.tcl,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::struct {} + +namespace eval ::struct::prioqueue { + # The queues array holds all of the queues you've made + variable queues + + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # commands is the list of subcommands recognized by the queue + variable commands [list \ + "clear" \ + "destroy" \ + "get" \ + "peek" \ + "put" \ + "remove" \ + "size" \ + "peekpriority" \ + ] + + variable sortopt [list \ + "-integer" \ + "-real" \ + "-ascii" \ + "-dictionary" \ + ] + + # this is a simple design decision, that integer and real + # are sorted decreasing (-1), and -ascii and -dictionary are sorted -increasing (1) + # the values here map to the sortopt list + # could be changed to something configurable. + variable sortdir [list \ + "-1" \ + "-1" \ + "1" \ + "1" \ + ] + + + + # Only export one command, the one used to instantiate a new queue + namespace export prioqueue + + proc K {x y} {set x} ;# DKF's K combinator +} + +# ::struct::prioqueue::prioqueue -- +# +# Create a new prioqueue with a given name; if no name is given, use +# prioqueueX, where X is a number. +# +# Arguments: +# sorting sorting option for lsort to use, no -command option +# defaults to integer +# name name of the queue; if null, generate one. +# names may not begin with - +# +# +# Results: +# name name of the queue created + +proc ::struct::prioqueue::prioqueue {args} { + variable queues + variable counter + variable queues_sorting + variable sortopt + + # check args + if {[llength $args] > 2} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" + } + if {[llength $args] == 0} { + # defaulting to integer priorities + set sorting -integer + } else { + if {[llength $args] == 1} { + if {[string match "-*" [lindex $args 0]]==1} { + set sorting [lindex $args 0] + } else { + set sorting -integer + set name [lindex $args 0] + } + } else { + if {[llength $args] == 2} { + foreach {sorting name} $args {break} + } + } + } + # check option (like lsort sorting options without -command) + if {[lsearch $sortopt $sorting] == -1} { + # if sortoption is unknown, but name is a sortoption we give a better error message + if {[info exists name] && [lsearch $sortopt $name]!=-1} { + error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" + } + error "unknown sort option \"$sorting\"" + } + # create name if not given + if {![info exists name]} { + incr counter + set name "prioqueue${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create prioqueue" + } + + # Initialize the queue as empty + set queues($name) [list ] + switch -exact -- $sorting { + -integer { set queues_sorting($name) 0} + -real { set queues_sorting($name) 1} + -ascii { set queues_sorting($name) 2} + -dictionary { set queues_sorting($name) 3} + } + + # Create the command to manipulate the queue + interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::prioqueue::QueueProc -- +# +# Command that processes all queue object commands. +# +# Arguments: +# name name of the queue object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::prioqueue::QueueProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [string equal [info commands ::struct::prioqueue::_$cmd] ""] } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + return [eval [linsert $args 0 ::struct::prioqueue::_$cmd $name]] +} + +# ::struct::prioqueue::_clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::prioqueue::_clear {name} { + variable queues + set queues($name) [list] + return +} + +# ::struct::prioqueue::_destroy -- +# +# Destroy a queue object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::prioqueue::_destroy {name} { + variable queues + variable queues_sorting + unset queues($name) + unset queues_sorting($name) + interp alias {} ::$name {} + return +} + +# ::struct::prioqueue::_get -- +# +# Get an item from a queue. +# +# Arguments: +# name name of the queue object. +# count number of items to get; defaults to 1 +# +# Results: +# item first count items from the queue; if there are not enough +# items in the queue, throws an error. +# + +proc ::struct::prioqueue::_get {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't listified + set item [lindex [lindex $queues($name) 0] 1] + set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0] + return $item + } + + # Otherwise, return a list of items + incr count -1 + set items [lrange $queues($name) 0 $count] + foreach item $items { + lappend result [lindex $item 1] + } + set items "" + + set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count] + return $result +} + +# ::struct::prioqueue::_peek -- +# +# Retrive the value of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fufill the request, throws an error. + +proc ::struct::prioqueue::_peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + return [lindex [lindex $queues($name) 0] 1] + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + foreach item [lrange $queues($name) 0 $index] { + lappend result [lindex $item 1] + } + return $result +} + +# ::struct::prioqueue::_peekpriority -- +# +# Retrive the priority of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fufill the request, throws an error. + +proc ::struct::prioqueue::_peekpriority {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + return [lindex [lindex $queues($name) 0] 0] + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + foreach item [lrange $queues($name) 0 $index] { + lappend result [lindex $item 0] + } + return $result +} + + +# ::struct::prioqueue::_put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args list of the form "item1 prio1 item2 prio2 item3 prio3" +# +# Results: +# None. + +proc ::struct::prioqueue::_put {name args} { + variable queues + variable queues_sorting + variable sortopt + variable sortdir + + if { [llength $args] == 0 || [llength $args] % 2} { + error "wrong # args: should be \"$name put item prio ?item prio ...?\"" + } + + # check for prio type before adding + switch -exact -- $queues_sorting($name) { + 0 { + foreach {item prio} $args { + if {![string is integer -strict $prio]} { + error "priority \"$prio\" is not an integer type value" + } + } + } + 1 { + foreach {item prio} $args { + if {![string is double -strict $prio]} { + error "priority \"$prio\" is not a real type value" + } + } + } + default { + #no restrictions for -ascii and -dictionary + } + } + + # sort by priorities + set opt [lindex $sortopt $queues_sorting($name)] + set dir [lindex $sortdir $queues_sorting($name)] + + # add only if check has passed + foreach {item prio} $args { + set new [list $prio $item] + set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir] + } + return +} + +# ::struct::prioqueue::_remove -- +# +# Delete an item together with it's related priority value from the queue. +# +# Arguments: +# name name of the queue object +# item item to be removed +# +# Results: +# None. + +if {[package vcompare [package present Tcl] 8.5] < 0} { + # 8.4-: We have -index option for lsearch, so we use glob to allow + # us to create a pattern which can ignore the priority value. We + # quote everything in the item to prevent it from being + # glob-matched, exact matching is required. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set itemrep "* \\[join [split $item {}] "\\"]" + set foundat [lsearch -glob $queuelist $itemrep] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + return + } +} else { + # 8.5+: We have the -index option, allowing us to exactly address + # the column used to search. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set foundat [lsearch -index 1 -exact $queuelist $item] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + return + } +} + +# ::struct::prioqueue::_size -- +# +# Return the number of objects on a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# count number of items on the queue. + +proc ::struct::prioqueue::_size {name} { + variable queues + return [llength $queues($name)] +} + +# ::struct::prioqueue::__linsertsorted +# +# Helper proc for inserting into a sorted list. +# +# + +proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} { + + set cmpcmd __elementcompare${sortopt} + set pos -1 + set newPrio [lindex $newElement 0] + + # do a binary search + set lower -1 + set upper [llength $list] + set bound [expr {$upper+1}] + set pivot 0 + + if {$upper > 0} { + while {$lower +1 != $upper } { + + # get the pivot element + set pivot [expr {($lower + $upper) / 2}] + set element [lindex $list $pivot] + set prio [lindex $element 0] + + # check + set test [$cmpcmd $prio $newPrio $sortdir] + if {$test == 0} { + set pos $pivot + set upper $pivot + # now break as we need the last item + break + } elseif {$test > 0 } { + # search lower section + set upper $pivot + set bound $upper + set pos -1 + } else { + # search upper section + set lower $pivot + set pos $bound + } + } + + + if {$pos == -1} { + # we do an insert before the pivot element + set pos $pivot + } + + # loop to the last matching element to + # keep a stable insertion order + while {[$cmpcmd $prio $newPrio $sortdir]==0} { + incr pos + if {$pos > [llength $list]} {break} + set element [lindex $list $pos] + set prio [lindex $element 0] + } + + } else { + set pos 0 + } + + # do the insert without copying + linsert [K $list [set list ""]] $pos $newElement +} + +# ::struct::prioqueue::__elementcompare +# +# Compare helpers with the sort options. +# +# + +proc ::struct::prioqueue::__elementcompare-integer {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-real {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-ascii {prio newPrio sortdir} { + return [expr {[string compare $prio $newPrio]*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-dictionary {prio newPrio sortdir} { + # need to use lsort to access -dictionary sorting + set tlist [lsort -increasing -dictionary [list $prio $newPrio]] + set e1 [string equal [lindex $tlist 0] $prio] + set e2 [string equal [lindex $tlist 1] $prio] + return [expr {$e1 > $e2 ? -1*$sortdir : ($e1 != $e2)*$sortdir}] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'prioqueue::prioqueue' into the general structure namespace. + namespace import -force prioqueue::prioqueue + namespace export prioqueue +} + +package provide struct::prioqueue 1.4 diff --git a/tcllib/modules/struct/prioqueue.test b/tcllib/modules/struct/prioqueue.test new file mode 100644 index 0000000..30359ea --- /dev/null +++ b/tcllib/modules/struct/prioqueue.test @@ -0,0 +1,511 @@ +# -*- tcl -*- +# prioqueue.test: tests for the prioqueue package. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2002 Michael Schlenker +# All rights reserved. +# +# RCS: @(#) $Id: prioqueue.test,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal prioqueue.tcl struct::prioqueue +} + +# ------------------------------------------------------------------------- + +namespace import -force struct::prioqueue + +#---------------------------------------------------------------------- + +test prioqueue-0.1 {prioqueue errors} { + prioqueue -integer myprioqueue + catch {prioqueue myprioqueue} msg + myprioqueue destroy + set msg +} "command \"myprioqueue\" already exists, unable to create prioqueue" +test prioqueue-0.2 {prioqueue errors} { + prioqueue myprioqueue + catch {myprioqueue} msg + myprioqueue destroy + set msg +} "wrong # args: should be \"myprioqueue option ?arg arg ...?\"" +test prioqueue-0.3 {prioqueue errors} { + prioqueue myprioqueue + catch {myprioqueue foo} msg + myprioqueue destroy + set msg +} "bad option \"foo\": must be clear, destroy, get, peek, put, remove, size, or peekpriority" +test prioqueue-0.4 {prioqueue errors} { + catch {prioqueue set} msg + set msg +} "command \"set\" already exists, unable to create prioqueue" + +test prioqueue-0.5 {prioqueue errors} { + catch {prioqueue -foo myprioqueue} msg + set msg +} "unknown sort option \"-foo\"" + +test prioqueue-0.6 {prioqueue errors} { + catch {prioqueue -foo} msg + set msg +} "unknown sort option \"-foo\"" + +test prioqueue-0.7 {prioqueue errors} { + catch {prioqueue -integer myprioqueue foo} msg + set msg +} "wrong # args: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\"" + +test prioqueue-0.8 {prioqueue errors} { + catch {prioqueue myprioqueue -integer} msg + set msg +} "wrong argument position: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\"" + +test prioqueue-1.1 {prioqueue creation} { + set foo [prioqueue myprioqueue] + set cmd [info commands ::myprioqueue] + set size [myprioqueue size] + myprioqueue destroy + list $foo $cmd $size +} {myprioqueue ::myprioqueue 0} + +test prioqueue-1.2 {prioqueue creation} { + set foo [prioqueue] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {prioqueue1 ::prioqueue1 0} + +test prioqueue-1.3 {prioqueue creation} { + set foo [prioqueue -ascii] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {prioqueue2 ::prioqueue2 0} + +test prioqueue-1.5 {prioqueue creation} { + set foo [prioqueue -dictionary] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {prioqueue3 ::prioqueue3 0} + +test prioqueue-1.6 {prioqueue creation} { + set foo [prioqueue -integer] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {prioqueue4 ::prioqueue4 0} + +test prioqueue-1.7 {prioqueue creation} { + set foo [prioqueue -real] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {prioqueue5 ::prioqueue5 0} + + +test prioqueue-2.1 {prioqueue destroy} { + prioqueue myprioqueue + myprioqueue destroy + info commands ::myprioqueue +} {} + +test prioqueue-3.2 {size operation} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 + set size [myprioqueue size] + myprioqueue destroy + set size +} 7 +test prioqueue-3.3 {size operation} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 + myprioqueue get 3 + set size [myprioqueue size] + myprioqueue destroy + set size +} 4 +test prioqueue-3.4 {size operation} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 + myprioqueue get 3 + myprioqueue peek 3 + set size [myprioqueue size] + myprioqueue destroy + set size +} 4 + +test prioqueue-4.1 {put operation} { + prioqueue myprioqueue + catch {myprioqueue put} msg + myprioqueue destroy + set msg +} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\"" + +test prioqueue-4.1a {put operation} { + prioqueue myprioqueue + catch {myprioqueue put a} msg + myprioqueue destroy + set msg +} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\"" + +test prioqueue-4.2 {put operation, singleton items} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a b c" + +test prioqueue-4.3 {put operation, singleton items} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 2 + myprioqueue put c 3 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "c b a" + +test prioqueue-4.4 {put operation, singleton items} { + prioqueue myprioqueue + myprioqueue put a 3 + myprioqueue put b 2 + myprioqueue put c 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a b c" + +test prioqueue-4.5 {put operation, singleton items} { + prioqueue myprioqueue + myprioqueue put a 3 + myprioqueue put b 1 + myprioqueue put c 2 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a c b" + +test prioqueue-4.6 {put operation, singleton items} { + prioqueue -ascii myprioqueue + myprioqueue put a a + myprioqueue put b b + myprioqueue put c c + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a b c" + +test prioqueue-4.7 {put operation, singleton items} { + prioqueue -dictionary myprioqueue + myprioqueue put a a + myprioqueue put b b + myprioqueue put c c + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a b c" + +test prioqueue-4.8 {put operation, singleton items} { + prioqueue -real myprioqueue + myprioqueue put a 1.0 + myprioqueue put b 2.0 + myprioqueue put c 3.0 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "c b a" + +test prioqueue-4.9 {put operation, multiple items} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 c 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} "a b c" + +test prioqueue-4.10 {put operation, spaces in items} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 "foo bar" 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} [list a b "foo bar"] + +test prioqueue-4.11 {put operation, bad chars in items} { + prioqueue myprioqueue + myprioqueue put a 1 b 1 \{ 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} [list a b \{] + +test prioqueue-4.12 {put operation, bad priorities} { + prioqueue myprioqueue + catch {myprioqueue put a a} msg + myprioqueue destroy + set msg +} {priority "a" is not an integer type value} + +test prioqueue-4.13 {put operation, bad priorities} { + prioqueue myprioqueue + catch {myprioqueue put a 1.01} msg + myprioqueue destroy + set msg +} {priority "1.01" is not an integer type value} + +test prioqueue-4.14 {put operation, bad priorities} { + prioqueue -real myprioqueue + catch {myprioqueue put a 1a} msg + myprioqueue destroy + set msg +} {priority "1a" is not a real type value} + +test prioqueue-4.15 {put operation, bad priorities} { + prioqueue -real myprioqueue + catch {myprioqueue put a a} msg + myprioqueue destroy + set msg +} {priority "a" is not a real type value} + +test prioqueue-4.16 {put operation, checking priorities} { + prioqueue -ascii myprioqueue + catch {myprioqueue put a 1.0} msg + myprioqueue destroy + set msg +} {} + +test prioqueue-4.17 {put operation, checking priorities} { + prioqueue -dictionary myprioqueue + catch {myprioqueue put a "1.0 +1"} msg + myprioqueue destroy + set msg +} {} + + +test prioqueue-5.1 {get operation} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]] + myprioqueue destroy + set result +} [list a b c] + +test prioqueue-5.2 {get operation, multiple items} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [myprioqueue get 3] + myprioqueue destroy + set result +} [list a b c] + +test prioqueue-6.1 {peek operation} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [list [myprioqueue peek] [myprioqueue peek] [myprioqueue peek]] + myprioqueue destroy + set result +} [list a a a] + +test prioqueue-6.2 {peek operation} { + prioqueue myprioqueue + catch {myprioqueue peek 0} msg + myprioqueue destroy + set msg +} {invalid item count 0} + +test prioqueue-6.3 {peek operation} { + prioqueue myprioqueue + catch {myprioqueue peek -1} msg + myprioqueue destroy + set msg +} {invalid item count -1} + +test prioqueue-6.4 {peek operation} { + prioqueue myprioqueue + catch {myprioqueue peek} msg + myprioqueue destroy + set msg +} {insufficient items in prioqueue to fill request} + +test prioqueue-6.5 {peek operation} { + prioqueue myprioqueue + myprioqueue put a 1 + catch {myprioqueue peek 2} msg + myprioqueue destroy + set msg +} {insufficient items in prioqueue to fill request} + +test prioqueue-6.6 {get operation, multiple items} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [list [myprioqueue peek 3] [myprioqueue get 3]] + myprioqueue destroy + set result +} [list [list a b c] [list a b c]] + +test prioqueue-6.7 {get operation} { + prioqueue myprioqueue + catch {myprioqueue get 0} msg + myprioqueue destroy + set msg +} {invalid item count 0} + +test prioqueue-6.8 {get operation} { + prioqueue myprioqueue + catch {myprioqueue get -1} msg + myprioqueue destroy + set msg +} {invalid item count -1} + +test prioqueue-6.9 {get operation} { + prioqueue myprioqueue + catch {myprioqueue get} msg + myprioqueue destroy + set msg +} {insufficient items in prioqueue to fill request} + +test prioqueue-6.10 {get operation} { + prioqueue myprioqueue + myprioqueue put a 1 + catch {myprioqueue get 2} msg + myprioqueue destroy + set msg +} {insufficient items in prioqueue to fill request} + +test prioqueue-7.1 {clear operation} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 1 + myprioqueue put c 1 + set result [list [myprioqueue peek 3]] + myprioqueue clear + lappend result [myprioqueue size] + myprioqueue destroy + set result +} [list [list a b c] 0] + +test prioqueue-8.1 {peekpriority operation} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 2 + myprioqueue put c 3 + set result [list [myprioqueue peekpriority] [myprioqueue peekpriority] [myprioqueue peekpriority]] + myprioqueue destroy + set result +} [list 3 3 3] + +test prioqueue-8.2 {peekpriority operation, multiple items} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 2 + myprioqueue put c 3 + set result [myprioqueue peekpriority 3] + myprioqueue destroy + set result +} [list 3 2 1] + + +test prioqueue-9.1 {stable ordering if inserting} { + prioqueue myprioqueue + myprioqueue put a 1 + myprioqueue put b 2 + myprioqueue put c 1 + set result [myprioqueue peek 3] + myprioqueue destroy + set result +} [list b a c ] + +test prioqueue-9.2 {stable ordering if inserting} { + prioqueue -real myprioqueue + myprioqueue put a 1.0 + myprioqueue put b 2.0 + myprioqueue put c 1.0 + set result [myprioqueue peek 3] + myprioqueue destroy + set result +} [list b a c ] + +test prioqueue-9.3 {stable ordering if inserting} { + prioqueue -dictionary myprioqueue + myprioqueue put a a + myprioqueue put b b + myprioqueue put c a + set result [myprioqueue peek 3] + myprioqueue destroy + set result +} [list a c b] + +test prioqueue-9.4 {stable ordering if inserting} { + prioqueue -ascii myprioqueue + myprioqueue put a a + myprioqueue put b b + myprioqueue put c a + set result [myprioqueue peek 3] + myprioqueue destroy + set result +} [list a c b] + +test prioqueue-10.1 {test inserting} { + prioqueue -integer myprioqueue + myprioqueue put 1 1 + myprioqueue put 2 5 + myprioqueue put 3 7 + myprioqueue put 4 6 + myprioqueue put 5 0 + set result [myprioqueue get 5] + myprioqueue destroy + set result +} [list 3 4 2 1 5] + +test prioqueue-10.2 {test deleting} { + prioqueue -integer myprioqueue + myprioqueue put 1 1 + myprioqueue put 2 2 + myprioqueue put 3 3 + myprioqueue put 4 4 + set sizep [myprioqueue size] + myprioqueue remove 2 + set sizen [myprioqueue size] + set result1 [expr {$sizep > $sizen}] + set result2 0 + while {[myprioqueue size] > 0} { + set last [myprioqueue get] + if {$last == 2} { + set result2 1 + } + } + myprioqueue destroy + set result "$result1 $result2" +} {1 0} + +testsuiteCleanup diff --git a/tcllib/modules/struct/queue.bench b/tcllib/modules/struct/queue.bench new file mode 100644 index 0000000..7a39cc0 --- /dev/null +++ b/tcllib/modules/struct/queue.bench @@ -0,0 +1,232 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'struct::queue' +# data structure to allow developers to monitor package performance. +# +# (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.4 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package present Tcl] 8.4]} { + bench_puts "Need Tcl 8.4+, found Tcl [package present Tcl]" + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package require Tcl 8.4 + +package forget struct::list +package forget struct::queue + +set self [file join [pwd] [file dirname [info script]]] +set mod [file dirname $self] +set index [file join [file dirname $self] tcllibc pkgIndex.tcl] + +if 1 { + if {[file exists $index]} { + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + package require tcllibc + } +} + +source [file join $mod cmdline cmdline.tcl] +source [file join $self list.tcl] +source [file join $self queue.tcl] + + +# ### ### ### ######### ######### ######### ########################### + +proc makeNcmd {n} { + return [linsert [struct::list iota $n] 0 s put] +} + +proc makeN {n} { + struct::queue s + if {$n > 0} { eval [makeNcmd $n] } + return +} + +# ### ### ### ######### ######### ######### ########################### +## Get all the possible implementations + +struct::queue::SwitchTo {} +foreach e [struct::queue::KnownImplementations] { + ::struct::queue::LoadAccelerator $e +} + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +# We have only 6 queue operations +# +# * clear - Remove all elements from the queue. +# * get - Destructively retrieve N elements, N > 0 +# * peek - Retrieve N elements, keep on queue, N > 0 +# * put - Add N elements to the queue, N > 0 +# * size - Query the size of the queue. +# * unget - Add N elements to _front_ of the queue, N > 0 + +# note on peek, get: +# - current testing is fine for single queue area. +# - split return/append => should check performance of peek crossing boundaries +# - split unget/return/append ? ditto, now possibly crossing 2 boundaries. + +# peek/put: +# - Time to retrieve/remove 1/10/100/1000 elements incrementally from a queue. +# - Time to retrieve/remove ............. elements at once from a queue. +# - Queue sizes 10/100/1000/1000 and pop only elements less than size. +# Expected: Amortized linear time in number of retrieved/removed elements. + +foreach queueimpl [struct::queue::Implementations] { + struct::queue::SwitchTo $queueimpl + + bench_puts {=== get/peek =========} + + foreach base {10 100 1000 10000} { + foreach remove {1 10 100 1000 10000} { + if {$remove > $base} continue + + bench -desc "queue get once $base/$remove queue($queueimpl)" -ipre { + makeN $base + } -body { + s get $remove + } -ipost { + s destroy + } + + bench -desc "queue get incr $base/$remove queue($queueimpl)" -pre { + set cmd {} + foreach x [struct::list iota $remove] { + lappend cmd [list s get] + } + proc foo {} [join $cmd \n] + catch {foo} ;# compile + } -ipre { + makeN $base + } -body { + foo + } -ipost { + s destroy + } -post { + rename foo {} + } + + bench -desc "queue peek $base/$remove queue($queueimpl)" -ipre { + makeN $base + } -body { + s peek $remove + } -ipost { + s destroy + } + } + } + + # put: + # - Time to add 1/10/100/1000 elements incrementally to an empty queue + # - Time to add ............. elements at once to an empty queue. + # - As above, to a queue containing 1/10/100/1000 elements already. + # Expected: Amortized linear time in number of elements added. + + bench_puts {=== put/unget =========} + + foreach base {0 1 10 100 1000} { + foreach add {1 10 100 1000} { + + bench -desc "queue put once $base/$add queue($queueimpl)" -ipre { + makeN $base + set cmd [makeNcmd $add] + } -body { + eval $cmd + } -ipost { + s destroy + } + + bench -desc "queue put incr $base/$add queue($queueimpl)" -pre { + set cmd {} + foreach x [struct::list iota $add] { + lappend cmd [list s put $x] + } + proc foo {} [join $cmd \n] + catch {foo} ;# compile + } -ipre { + makeN $base + } -body { + foo + } -ipost { + s destroy + } -post { + rename foo {} + } + + bench -desc "queue unget incr $base/$add queue($queueimpl)" -pre { + set cmd {} + foreach x [struct::list iota $add] { + lappend cmd [list s unget $x] + } + proc foo {} [join $cmd \n] + catch {foo} ;# compile + } -ipre { + makeN $base + } -body { + foo + } -ipost { + s destroy + } -post { + rename foo {} + } + } + } + + # size + # - Time to query size of queue containing 0/1/10/100/1000/10000 elements. + # Expected: Constant time. + + bench_puts {=== size =========} + + foreach n {0 1 10 100 1000 10000} { + bench -desc "queue size $n queue($queueimpl)" -pre { + makeN $n + } -body { + s size + } -post { + s destroy + } + } + + # clear + # - Time to clear a queue containing 0/1/10/100/1000/10000 elements. + # Expected: Constant to linear time in number of elements to clear. + + bench_puts {=== clear =========} + + foreach n {0 1 10 100 1000 10000} { + bench -desc "queue clear $n queue($queueimpl)" -ipre { + makeN $n + } -body { + s clear + } -ipost { + s destroy + } + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete + +return + +# ### ### ### ######### ######### ######### ########################### +## Notes ... + +# Notes on optimizations we can do. +# +# Tcl - Cache structural data - depth, ancestors ... +# C - Cache results, like child lists (Tcl_Obj's!) +# Maybe use Tcl_Obj/List for child arrays instead +# of N* ? Effect on modification performance ? diff --git a/tcllib/modules/struct/queue.man b/tcllib/modules/struct/queue.man new file mode 100644 index 0000000..af788a5 --- /dev/null +++ b/tcllib/modules/struct/queue.man @@ -0,0 +1,96 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::queue n 1.4.5] +[keywords graph] +[keywords list] +[keywords matrix] +[keywords pool] +[keywords prioqueue] +[keywords record] +[keywords set] +[keywords skiplist] +[keywords stack] +[keywords tree] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate queue objects}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::queue [opt 1.4.5]] +[description] + +The [namespace ::struct] namespace contains a commands for processing +finite queues. + +[para] + +It exports a single command, [cmd ::struct::queue]. All functionality +provided here can be reached through a subcommand of this command. + +[para] + +[emph Note:] As of version 1.4.1 of this package a critcl based C +implementation is available. This implementation however requires Tcl +8.4 to run. + +[para] + +The [cmd ::struct::queue] command creates a new queue object with an +associated global Tcl command whose name is [emph queueName]. This +command may be used to invoke various operations on the queue. It has +the following general form: + +[list_begin definitions] + +[call [arg queueName] [cmd option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. The following commands are possible for queue objects: + +[call [arg queueName] [cmd clear]] + +Remove all items from the queue. + +[call [arg queueName] [cmd destroy]] + +Destroy the queue, including its storage space and associated command. + +[call [arg queueName] [cmd get] [opt "[arg count]"]] + +Return the front [arg count] items of the queue and remove them from +the queue. If [arg count] is not specified, it defaults to 1. If +[arg count] is 1, the result is a simple string; otherwise, it is a +list. If specified, [arg count] must be greater than or equal to 1. + +If there are not enough items in the queue to fulfull the request, +this command will throw an error. + +[call [arg queueName] [cmd peek] [opt "[arg count]"]] + +Return the front [arg count] items of the queue, without removing them +from the queue. If [arg count] is not specified, it defaults to 1. +If [arg count] is 1, the result is a simple string; otherwise, it is a +list. If specified, [arg count] must be greater than or equal to 1. + +If there are not enough items in the queue to fulfull the request, +this command will throw an error. + +[call [arg queueName] [cmd put] [arg item] [opt "[arg "item ..."]"]] + +Put the [arg item] or items specified into the queue. If more than +one [arg item] is given, they will be added in the order they are +listed. + +[call [arg queueName] [cmd unget] [arg item]] + +Put the [arg item] into the queue, at the front, i.e. before any other +items already in the queue. This makes this operation the complement +to the method [method get]. + +[call [arg queueName] [cmd size]] + +Return the number of items in the queue. + +[list_end] + +[vset CATEGORY {struct :: queue}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/queue.tcl b/tcllib/modules/struct/queue.tcl new file mode 100644 index 0000000..7f5dcd9 --- /dev/null +++ b/tcllib/modules/struct/queue.tcl @@ -0,0 +1,187 @@ +# queue.tcl -- +# +# Implementation of a queue data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue.tcl,v 1.16 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: queue_c.tcl + +package require Tcl 8.4 +namespace eval ::struct::queue {} + +# ### ### ### ######### ######### ######### +## Management of queue implementations. + +# ::struct::queue::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::queue::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of queue requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::queue_critcl]] + } + tcl { + variable selfdir + if { + [package vsatisfies [package provide Tcl] 8.5] && + ![catch {package require TclOO 0.6.1-}] + } { + source [file join $selfdir queue_oo.tcl] + } else { + source [file join $selfdir queue_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::queue::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::queue::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::queue ::struct::queue_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::queue_$key ::struct::queue + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::queue::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::queue::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::queue::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::queue::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::queue::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::queue { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::queue { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export queue +} + +package provide struct::queue 1.4.5 diff --git a/tcllib/modules/struct/queue.test b/tcllib/modules/struct/queue.test new file mode 100644 index 0000000..139b75d --- /dev/null +++ b/tcllib/modules/struct/queue.test @@ -0,0 +1,107 @@ +# -*- tcl -*- +# queue.test: tests for the queue package. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 Andreas Kupries +# All rights reserved. +# +# RCS: @(#) $Id: queue.test,v 1.18 2010/03/24 06:13:00 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useAccel [useTcllibC] struct/queue.tcl struct::queue + TestAccelInit struct::queue +} + +#---------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in queue.testsuite) can expect from the environment. + +TestAccelDo struct::queue impl { + namespace import -force struct::queue + + switch -exact -- $impl { + critcl { + set MY myqueue + + proc tmWrong {m loarg n {xarg {}}} { + return [tcltest::wrongNumArgs "myqueue $m" $loarg $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + return [tcltest::tooManyArgs "myqueue $m" $loarg] + } + + proc tmTake {tcl c} { return $c } + } + tcl { + set MY ::myqueue + + if {[package vsatisfies [package provide Tcl] 8.5]} { + if {[catch {package present TclOO}]} { + # Without TclOO + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "I $m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "I $m" "name$xarg"] + } + } else { + # OO implementation. + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "myqueue $m" "$loarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "myqueue $m" "$loarg"] + } + } + } else { + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "::struct::queue::I::$m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "::struct::queue::I::$m" "name$xarg"] + } + } + + proc tmTake {tcl c} { return $tcl } + } + } + + source [localPath queue.testsuite] +} + +#---------------------------------------------------------------------- +TestAccelExit struct::queue +testsuiteCleanup diff --git a/tcllib/modules/struct/queue.testsuite b/tcllib/modules/struct/queue.testsuite new file mode 100644 index 0000000..086f50b --- /dev/null +++ b/tcllib/modules/struct/queue.testsuite @@ -0,0 +1,372 @@ +# -*- tcl -*- +# queue.test: tests for the queue package. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: queue.testsuite,v 1.3 2010/05/25 19:26:18 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint queue_critcl [string equal $impl critcl] +::tcltest::testConstraint queue_oo [expr {![catch {package present TclOO}] && [string equal $impl tcl]}] + +#---------------------------------------------------------------------- + +test queue-${impl}-0.1.0 {queue errors} !queue_oo { + queue myqueue + catch {queue myqueue} msg + myqueue destroy + set msg +} {command "::myqueue" already exists, unable to create queue} + +test queue-${impl}-0.1.1 {queue errors} queue_oo { + queue myqueue + catch {queue myqueue} msg + myqueue destroy + set msg +} {can't create object "myqueue": command already exists with that name} + +test queue-${impl}-0.2 {queue errors} badTest { + queue myqueue + catch {myqueue} msg + myqueue destroy + set msg +} "wrong # args: should be \"$MY option ?arg arg ...?\"" + +test queue-${impl}-0.3.0 {queue errors} tcl8.4minus { + queue myqueue + catch {myqueue foo} msg + myqueue destroy + set msg +} {bad option "foo": must be clear, destroy, get, peek, put, size, or unget} + +test queue-${impl}-0.3.1.0 {queue errors} {tcl8.5plus !queue_oo} { + queue myqueue + catch {myqueue foo} msg + myqueue destroy + set msg +} [tmTake \ + {unknown or ambiguous subcommand "foo": must be clear, destroy, get, peek, put, size, or unget} \ + {bad option "foo": must be clear, destroy, get, peek, put, size, or unget} \ + ] + +test queue-${impl}-0.3.1.1 {queue errors} {tcl8.5plus queue_oo} { + queue myqueue + catch {myqueue foo} msg + myqueue destroy + set msg +} [tmTake \ + {unknown method "foo": must be clear, destroy, get, peek, put, size or unget} \ + {bad option "foo": must be clear, destroy, get, peek, put, size, or unget} \ + ] + +test queue-${impl}-0.4.0 {queue errors} !queue_oo { + catch {queue set} msg + set msg +} {command "::set" already exists, unable to create queue} + +test queue-${impl}-0.4.1 {queue errors} queue_oo { + catch {queue set} msg + set msg +} {can't create object "set": command already exists with that name} + +#---------------------------------------------------------------------- + +test queue-${impl}-1.1 {queue creation} { + set foo [queue myqueue] + set cmd [info commands ::myqueue] + set size [myqueue size] + myqueue destroy + list $foo $cmd $size +} {::myqueue ::myqueue 0} + +test queue-${impl}-1.2.0 {queue creation} !queue_oo { + set foo [queue] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {::queue1 ::queue1 0} + +test queue-${impl}-1.2.1 {queue creation} queue_oo { + set foo [queue] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size + string match [list ::oo::Obj* ::oo::Obj* 0] [list $foo $cmd $size] +} 1 + +#---------------------------------------------------------------------- + +test queue-${impl}-2.1 {queue destroy} { + queue myqueue + myqueue destroy + info commands ::myqueue +} {} + +#---------------------------------------------------------------------- + +test queue-${impl}-3.2 {size operation} { + queue myqueue + myqueue put a b c d e f g + set size [myqueue size] + myqueue destroy + set size +} 7 +test queue-${impl}-3.3 {size operation} { + queue myqueue + myqueue put a b c d e f g + myqueue get 3 + set size [myqueue size] + myqueue destroy + set size +} 4 +test queue-${impl}-3.4 {size operation} { + queue myqueue + myqueue put a b c d e f g + myqueue get 3 + myqueue peek 3 + set size [myqueue size] + myqueue destroy + set size +} 4 + +#---------------------------------------------------------------------- + +test queue-${impl}-4.1 {put operation} { + queue myqueue + catch {myqueue put} msg + myqueue destroy + set msg +} "wrong # args: should be \"$MY put item ?item ...?\"" + +test queue-${impl}-4.2 {put operation, singleton items} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [list [myqueue get] [myqueue get] [myqueue get]] + myqueue destroy + set result +} {a b c} + +test queue-${impl}-4.3 {put operation, multiple items} { + queue myqueue + myqueue put a b c + set result [list [myqueue get] [myqueue get] [myqueue get]] + myqueue destroy + set result +} {a b c} + +test queue-${impl}-4.4 {put operation, spaces in items} { + queue myqueue + myqueue put a b "foo bar" + set result [list [myqueue get] [myqueue get] [myqueue get]] + myqueue destroy + set result +} {a b {foo bar}} + +test queue-${impl}-4.5 {put operation, bad chars in items} { + queue myqueue + myqueue put a b \{ + set result [list [myqueue get] [myqueue get] [myqueue get]] + myqueue destroy + set result +} [list a b \{] + +#---------------------------------------------------------------------- + +test queue-${impl}-5.1 {get operation} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [list [myqueue get] [myqueue get] [myqueue get]] + myqueue destroy + set result +} {a b c} + +test queue-${impl}-5.2 {get operation, multiple items} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [myqueue get 3] + myqueue destroy + set result +} {a b c} + +#---------------------------------------------------------------------- + +test queue-${impl}-6.1 {peek operation} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [list [myqueue peek] [myqueue peek] [myqueue peek]] + myqueue destroy + set result +} {a a a} + +test queue-${impl}-6.2 {peek operation} { + queue myqueue + catch {myqueue peek 0} msg + myqueue destroy + set msg +} {invalid item count 0} + +test queue-${impl}-6.3 {peek operation} { + queue myqueue + catch {myqueue peek -1} msg + myqueue destroy + set msg +} {invalid item count -1} + +test queue-${impl}-6.4 {peek operation} { + queue myqueue + catch {myqueue peek} msg + myqueue destroy + set msg +} {insufficient items in queue to fill request} + +test queue-${impl}-6.5 {peek operation} { + queue myqueue + myqueue put a + catch {myqueue peek 2} msg + myqueue destroy + set msg +} {insufficient items in queue to fill request} + +test queue-${impl}-6.6 {get operation, multiple items} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [list [myqueue peek 3] [myqueue get 3]] + myqueue destroy + set result +} {{a b c} {a b c}} + +test queue-${impl}-6.7 {get operation} { + queue myqueue + catch {myqueue get 0} msg + myqueue destroy + set msg +} {invalid item count 0} + +test queue-${impl}-6.8 {get operation} { + queue myqueue + catch {myqueue get -1} msg + myqueue destroy + set msg +} {invalid item count -1} + +test queue-${impl}-6.9 {get operation} { + queue myqueue + catch {myqueue get} msg + myqueue destroy + set msg +} {insufficient items in queue to fill request} + +test queue-${impl}-6.10 {get operation} { + queue myqueue + myqueue put a + catch {myqueue get 2} msg + myqueue destroy + set msg +} {insufficient items in queue to fill request} + +#---------------------------------------------------------------------- + +test queue-${impl}-7.1 {clear operation} { + queue myqueue + myqueue put a + myqueue put b + myqueue put c + set result [list [myqueue peek 3]] + myqueue clear + lappend result [myqueue size] + myqueue destroy + set result +} {{a b c} 0} + +#---------------------------------------------------------------------- + +test queue-${impl}-8.1 {unget operation, not enough arguments} { + queue myqueue + catch {myqueue unget} msg + myqueue destroy + set msg +} [tmWrong unget {item} 0] + +test queue-${impl}-8.2 {unget operation, too many arguments} { + queue myqueue + catch {myqueue unget a b} msg + myqueue destroy + set msg +} [tmTooMany unget {item}] + +test queue-${impl}-8.3 {unget, empty queue} { + queue myqueue + myqueue unget foo + set res [myqueue peek [myqueue size]] + myqueue destroy + set res +} {foo} + +test queue-${impl}-8.4 {unget, nonempty queue, at beginning of queue} { + queue myqueue + myqueue put a b c + myqueue unget foo + set res [myqueue peek [myqueue size]] + myqueue destroy + set res +} {foo a b c} + +test queue-${impl}-8.5 {unget, nonempty queue, middle of queue} { + queue myqueue + myqueue put a b c d e f + myqueue get 3 + myqueue unget foo + set res [myqueue peek [myqueue size]] + myqueue destroy + set res +} {foo d e f} + +#---------------------------------------------------------------------- + +test queue-${impl}-sf-3608240-a {} { + struct::queue qp + qp put 1 2 3 + set r {} + lappend r [qp peek [qp size]] + lappend r [qp get] + lappend r [qp peek [qp size]] + qp put 4 5 + lappend r [qp peek [qp size]] + qp destroy + set r +} {{1 2 3} 1 {2 3} {2 3 4 5}} +catch { unset r } + +test queue-${impl}-sf-3608240-b {} { + struct::queue qp + qp put 1 2 3 + set r {} + lappend r [qp peek [qp size]] + lappend r [qp get] + lappend r [qp peek [qp size]] + qp put 4 5 + lappend r [qp get [qp size]] + qp destroy + set r +} {{1 2 3} 1 {2 3} {2 3 4 5}} +catch { unset r } + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/queue/ds.h b/tcllib/modules/struct/queue/ds.h new file mode 100644 index 0000000..384a34e --- /dev/null +++ b/tcllib/modules/struct/queue/ds.h @@ -0,0 +1,35 @@ +/* struct::queue - critcl - layer 1 declarations + * (a) Data structures. + */ + +#ifndef _DS_H +#define _DS_H 1 + +#include "tcl.h" + +/* Forward declarations of references to queues. + */ + +typedef struct Q* QPtr; + +/* Queue structure + */ + +typedef struct Q { + Tcl_Command cmd; /* Token of the object command for + * the queue */ + Tcl_Obj* unget; /* List object unget elements */ + Tcl_Obj* queue; /* List object holding the main queue */ + Tcl_Obj* append; /* List object holding new elements */ + int at; /* Index of next element to return from the main queue */ +} Q; + +#endif /* _DS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/m.c b/tcllib/modules/struct/queue/m.c new file mode 100644 index 0000000..8e88039 --- /dev/null +++ b/tcllib/modules/struct/queue/m.c @@ -0,0 +1,502 @@ +/* struct::queue - critcl - layer 3 definitions. + * + * -> Method functions. + * Implementations for all queue methods. + */ + +#include "util.h" +#include "m.h" +#include "q.h" +#include "ms.h" + +static int qsize (Q* q, int* u, int* r, int* a); +static void qshift (Q* q); + +#undef QUEUE_DUMP +/*#define QUEUE_DUMP 1*/ + +#if QUEUE_DUMP +static void qdump (Q* q); +#else +#define qdump(q) /* Ignore */ +#endif + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * qum_CLEAR -- + * + * Removes all elements currently on the queue. I.e empties the queue. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +qum_CLEAR (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: queue clear + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + /* + * Delete and recreate the queue memory. A combination of delete/new, + * except the main structure is left unchanged + */ + + Tcl_DecrRefCount (q->unget); + Tcl_DecrRefCount (q->queue); + Tcl_DecrRefCount (q->append); + + q->at = 0; + q->unget = Tcl_NewListObj (0,NULL); + q->queue = Tcl_NewListObj (0,NULL); + q->append = Tcl_NewListObj (0,NULL); + + Tcl_IncrRefCount (q->unget); + Tcl_IncrRefCount (q->queue); + Tcl_IncrRefCount (q->append); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * qum_DESTROY -- + * + * Destroys the whole queue object. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Releases memory. + * + *--------------------------------------------------------------------------- + */ + +int +qum_DESTROY (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: queue destroy + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DeleteCommandFromToken(interp, q->cmd); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * qum_PEEK/GET -- + * + * (Non-)destructively retrieves one or more elements from the top of the + * queue. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +qum_PEEK (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int get) +{ + /* Syntax: queue peek|get ?n? + * [0] [1] [2] + */ + + int listc = 0; + Tcl_Obj** listv; + Tcl_Obj* r; + int n = 1; + int ungetc; + int queuec; + int appendc; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?n?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) { + return TCL_ERROR; + } else if (n < 1) { + Tcl_AppendResult (interp, "invalid item count ", + Tcl_GetString (objv[2]), + NULL); + return TCL_ERROR; + } + } + + if (n > qsize(q, &ungetc, &queuec, &appendc)) { + Tcl_AppendResult (interp, + "insufficient items in queue to fill request", + NULL); + return TCL_ERROR; + } + + /* 1. We have item on the unget stack + * a. Enough to satisfy request. + * b. Not enough. + * 2. We have items in the return buffer. + * a. Enough to satisfy request. + * b. Not enough. + * 3. We have items in the append buffer. + * a. Enough to satisfy request. + * b. Not enough. + * + * Case 3. can assume 2b, because an empty return buffer will be filled + * from the append buffer before looking at either. Case 3. cannot happen + * for n==1, the return buffer will contain at least one element. + * + * We distinguish between single and multi-element requests. + * + * XXX AK optimizations - If we can return everything from a single + * buffer, be it queue, or append, just return the buffer object, do not + * create something new. + */ + + if (n == 1) { + if (ungetc) { + /* Pull from unget stack */ + Tcl_ListObjGetElements (interp, q->unget, &listc, &listv); + r = listv [listc-1]; + Tcl_SetObjResult (interp, r); + if (get) { + /* XXX AK : Should maintain max size info, and proper index, for discard. */ + Tcl_ListObjReplace (interp, q->unget, listc-1, 1, 0, NULL); + } + } else { + qshift (q); + Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); + ASSERT_BOUNDS(q->at,listc); + r = listv [q->at]; + Tcl_SetObjResult (interp, r); + /* + * Note: Doing the SetObj now is important. It increments the + * refcount of 'r', allowing it to survive if the 'qshift' below + * kills the internal list (q->queue) holding it. + */ + if (get) { + q->at ++; + qshift (q); + } + } + } else { + /* + * Allocate buffer for result, then fill it using the various data + * sources. + */ + + int i = 0, j; + Tcl_Obj** resv = NALLOC(n,Tcl_Obj*); + + if (ungetc) { + Tcl_ListObjGetElements (interp, q->unget, &listc, &listv); + /* + * Note how we are iterating backward in listv. unget is managed + * as a stack, avoiding mem-copy operations and both push and pop. + */ + for (j = listc-1; + j >= 0 && i < n; + j--, i++) { + ASSERT_BOUNDS(i,n); + ASSERT_BOUNDS(j,listc); + resv[i] = listv[j]; + Tcl_IncrRefCount (resv[i]); + } + if (get) { + /* XXX AK : Should maintain max size info, and proper index, for discard. */ + Tcl_ListObjReplace (interp, q->unget, j, i, 0, NULL); + /* XXX CHECK index calcs. */ + } + } + if (i < n) { + qshift (q); + Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); + for (j = q->at; + j < listc && i < n; + j++, i++) { + ASSERT_BOUNDS(i,n); + ASSERT_BOUNDS(j,listc); + resv[i] = listv[j]; + Tcl_IncrRefCount (resv[i]); + } + + if (get) { + q->at = j; + qshift (q); + } else if (i < n) { + /* XX */ + Tcl_ListObjGetElements (interp, q->append, &listc, &listv); + for (j = 0; + j < listc && i < n; + j++, i++) { + ASSERT_BOUNDS(i,n); + ASSERT_BOUNDS(j,listc); + resv[i] = listv[j]; + Tcl_IncrRefCount (resv[i]); + } + } + } + + /* + * This can happend if and only if we have to pull data from append, + * and get is set. Without get XX would have run and filled the result + * to completion. + */ + + if (i < n) { + ASSERT(get,"Impossible 2nd return pull witohut get"); + qshift (q); + Tcl_ListObjGetElements (interp, q->queue, &listc, &listv); + for (j = q->at; + j < listc && i < n; + j++, i++) { + ASSERT_BOUNDS(i,n); + ASSERT_BOUNDS(j,listc); + resv[i] = listv[j]; + Tcl_IncrRefCount (resv[i]); + } + q->at = j; + qshift (q); + } + + r = Tcl_NewListObj (n, resv); + Tcl_SetObjResult (interp, r); + + for (i=0;i<n;i++) { + Tcl_DecrRefCount (resv[i]); + } + ckfree((char*)resv); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * qum_PUT -- + * + * Adds one or more elements to the queue. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +qum_PUT (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: queue push item... + * [0] [1] [2] + */ + + int i; + + if (objc < 3) { + Tcl_WrongNumArgs (interp, 2, objv, "item ?item ...?"); + return TCL_ERROR; + } + + for (i = 2; i < objc; i++) { + Tcl_ListObjAppendElement (interp, q->append, objv[i]); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * qum_UNGET -- + * + * Pushes an element back into the queue. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +qum_UNGET (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: queue unget item + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "item"); + return TCL_ERROR; + } + + if (q->at == 0) { + /* Need the unget stack */ + Tcl_ListObjAppendElement (interp, q->unget, objv[2]); + } else { + /* + * We have room in the return buffer, so splice directly instead of + * using the unget stack. + */ + + int queuec = 0; + Tcl_ListObjLength (NULL, q->queue, &queuec); + + q->at --; + ASSERT_BOUNDS(q->at,queuec); + Tcl_ListObjReplace (interp, q->queue, q->at, 1, 1, &objv[2]); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * qum_SIZE -- + * + * Returns the number of elements currently held by the queue. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +qum_SIZE (Q* q, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: queue size + * [0] [1] + */ + + if ((objc != 2)) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (qsize (q, NULL, NULL, NULL))); + return TCL_OK; +} + + +static int +qsize (Q* q, int* u, int* r, int* a) +{ + int ungetc = 0; + int queuec = 0; + int appendc = 0; + + Tcl_ListObjLength (NULL, q->unget, &ungetc); + Tcl_ListObjLength (NULL, q->queue, &queuec); + Tcl_ListObjLength (NULL, q->append, &appendc); + + if (u) *u = ungetc; + if (r) *r = queuec; + if (a) *a = appendc; + + return ungetc + queuec + appendc - q->at; +} + +static void +qshift (Q* q) +{ + int queuec = 0; + int appendc = 0; + + qdump (q); + + /* The queue is not done yet, no shift */ + Tcl_ListObjLength (NULL, q->queue, &queuec); + if (q->at < queuec) return; + + /* The queue is done, however there is nothing + * to shift into it, so we don't + */ + Tcl_ListObjLength (NULL, q->append, &appendc); + if (!appendc) return; + + q->at = 0; + Tcl_DecrRefCount (q->queue); + q->queue = q->append; + q->append = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (q->append); + + qdump (q); +} + +#ifdef QUEUE_DUMP +static void +qdump (Q* q) +{ + int k; + int listc = 0; + Tcl_Obj** listv; + + fprintf(stderr,"qdump (%p, @%d)\n", q, q->at);fflush(stderr); + + fprintf(stderr,"\tunget %p\n", q->unget);fflush(stderr); + Tcl_ListObjGetElements (NULL, q->unget, &listc, &listv); + for (k=0; k < listc; k++) { + fprintf(stderr,"\tunget %p [%d] = %p '%s' /%d\n", q->unget, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); + } + + fprintf(stderr,"\tqueue %p\n", q->queue);fflush(stderr); + Tcl_ListObjGetElements (NULL, q->queue, &listc, &listv); + for (k=0; k < listc; k++) { + fprintf(stderr,"\tqueue %p [%d] = %p '%s' /%d\n", q->queue, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); + } + + fprintf(stderr,"\tapp.. %p\n", q->append);fflush(stderr); + Tcl_ListObjGetElements (NULL, q->append, &listc, &listv); + for (k=0; k < listc; k++) { + fprintf(stderr,"\tapp.. %p [%d] = %p '%s' /%d\n", q->append, k, listv[k], Tcl_GetString(listv[k]), listv[k]->refCount);fflush(stderr); + } + + fprintf(stderr,"qdump/ ___________________\n");fflush(stderr); +} +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/m.h b/tcllib/modules/struct/queue/m.h new file mode 100644 index 0000000..827604e --- /dev/null +++ b/tcllib/modules/struct/queue/m.h @@ -0,0 +1,26 @@ +/* struct::queue - critcl - layer 3 declarations + * Method functions. + */ + +#ifndef _M_H +#define _M_H 1 + +#include "tcl.h" +#include <q.h> + +int qum_CLEAR (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int qum_DESTROY (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int qum_PEEK (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int get); +int qum_PUT (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int qum_UNGET (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int qum_SIZE (Q* qd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _M_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/ms.c b/tcllib/modules/struct/queue/ms.c new file mode 100644 index 0000000..cd08723 --- /dev/null +++ b/tcllib/modules/struct/queue/ms.c @@ -0,0 +1,76 @@ +/* struct::queue - critcl - layer 2 definitions + * + * -> Support for the queue methods in layer 3. + */ + +#include <ms.h> +#include <m.h> +#include <q.h> +#include <util.h> + +/* .................................................. */ +/* + *--------------------------------------------------------------------------- + * + * qums_objcmd -- + * + * Implementation of queue objects, the main dispatcher function. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the called methods. + * + *--------------------------------------------------------------------------- + */ + +int +qums_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + Q* q = (Q*) cd; + int m; + + static CONST char* methods [] = { + "clear", "destroy", "get", + "peek", "put", "size", + "unget", + NULL + }; + enum methods { + M_CLEAR, M_DESTROY, M_GET, + M_PEEK, M_PUT, M_SIZE, + M_UNGET + }; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case M_CLEAR: return qum_CLEAR (q, interp, objc, objv); + case M_DESTROY: return qum_DESTROY (q, interp, objc, objv); + case M_GET: return qum_PEEK (q, interp, objc, objv, 1 /* get */); + case M_PEEK: return qum_PEEK (q, interp, objc, objv, 0 /* peek */); + case M_PUT: return qum_PUT (q, interp, objc, objv); + case M_SIZE: return qum_SIZE (q, interp, objc, objv); + case M_UNGET: return qum_UNGET (q, interp, objc, objv); + } + /* Not coming to this place */ +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/ms.h b/tcllib/modules/struct/queue/ms.h new file mode 100644 index 0000000..c6c83a5 --- /dev/null +++ b/tcllib/modules/struct/queue/ms.h @@ -0,0 +1,20 @@ +/* struct::queue - critcl - layer 2 declarations + * Support for queue methods. + */ + +#ifndef _MS_H +#define _MS_H 1 + +#include "tcl.h" + +int qums_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _MS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/q.c b/tcllib/modules/struct/queue/q.c new file mode 100644 index 0000000..6fe8021 --- /dev/null +++ b/tcllib/modules/struct/queue/q.c @@ -0,0 +1,47 @@ +/* struct::queue - critcl - layer 1 definitions + * (c) Queue functions + */ + +#include <q.h> +#include <util.h> + +/* .................................................. */ + +Q* +qu_new (void) +{ + Q* q = ALLOC (Q); + + q->at = 0; + q->unget = Tcl_NewListObj (0,NULL); + q->queue = Tcl_NewListObj (0,NULL); + q->append = Tcl_NewListObj (0,NULL); + + Tcl_IncrRefCount (q->unget); + Tcl_IncrRefCount (q->queue); + Tcl_IncrRefCount (q->append); + + return q; +} + +void +qu_delete (Q* q) +{ + /* Delete a queue in toto. + */ + + Tcl_DecrRefCount (q->unget); + Tcl_DecrRefCount (q->queue); + Tcl_DecrRefCount (q->append); + ckfree ((char*) q); +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/q.h b/tcllib/modules/struct/queue/q.h new file mode 100644 index 0000000..d91e70c --- /dev/null +++ b/tcllib/modules/struct/queue/q.h @@ -0,0 +1,22 @@ +/* struct::queue - critcl - layer 1 declarations + * (c) Queue functions + */ + +#ifndef _Q_H +#define _Q_H 1 + +#include "tcl.h" +#include <ds.h> + +QPtr qu_new (void); +void qu_delete (QPtr q); + +#endif /* _Q_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue/util.h b/tcllib/modules/struct/queue/util.h new file mode 100644 index 0000000..f79a03c --- /dev/null +++ b/tcllib/modules/struct/queue/util.h @@ -0,0 +1,41 @@ +/* struct::queue - critcl - layer 0 declarations + * API general utilities + */ + +#ifndef _UTIL_H +#define _UTIL_H 1 + +#include <tcl.h> + +/* Allocation macros for common situations. + */ + +#define ALLOC(type) (type *) ckalloc (sizeof (type)) +#define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type)) + +/* Assertions in general, and asserting the proper range of an array index. + */ + +#undef QUEUE_DEBUG +#define QUEUE_DEBUG 1 + +#ifdef QUEUE_DEBUG +#define XSTR(x) #x +#define STR(x) XSTR(x) +#define RANGEOK(i,n) ((0 <= (i)) && (i < (n))) +#define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__));} +#define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " > " STR(n)) +#else +#define ASSERT(x,msg) +#define ASSERT_BOUNDS(i,n) +#endif + +#endif /* _UTIL_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/queue_c.tcl b/tcllib/modules/struct/queue_c.tcl new file mode 100644 index 0000000..f401407 --- /dev/null +++ b/tcllib/modules/struct/queue_c.tcl @@ -0,0 +1,151 @@ +# queuec.tcl -- +# +# Implementation of a queue data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_c.tcl,v 1.2 2011/04/21 17:51:55 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_queuec +package provide struct_queuec 1.3.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + critcl::cheaders queue/*.h + critcl::csources queue/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include <util.h> + #include <q.h> + #include <ms.h> + #include <m.h> + + /* .................................................. */ + /* Global queue management, per interp + */ + + typedef struct QDg { + long int counter; + char buf [50]; + } QDg; + + static void + QDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + QDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::queue/critcl" + + Tcl_InterpDeleteProc* proc = QDgrelease; + QDg* qdg; + + qdg = Tcl_GetAssocData (interp, KEY, &proc); + if (qdg == NULL) { + qdg = (QDg*) ckalloc (sizeof (QDg)); + qdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) qdg); + } + + qdg->counter ++; + sprintf (qdg->buf, "queue%d", qdg->counter); + return qdg->buf; + +#undef KEY + } + + static void + QDdeleteCmd (ClientData clientData) + { + /* Release the whole queue. */ + qu_delete ((Q*) clientData); + } + } + + # Main command, queue creation. + + critcl::ccommand queue_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + Q* qd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = QDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + qd = qu_new(); + qd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + qums_objcmd, (ClientData) qd, + QDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/tcllib/modules/struct/queue_oo.tcl b/tcllib/modules/struct/queue_oo.tcl new file mode 100644 index 0000000..e6e1fe7 --- /dev/null +++ b/tcllib/modules/struct/queue_oo.tcl @@ -0,0 +1,228 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_oo.tcl,v 1.2 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::queue::queue_oo} +catch {rename ::struct::queue::queue_oo {}} +oo::class create ::struct::queue::queue_oo { + + variable qat qret qadd + + # variable qat - Index in qret of next element to return + # variable qret - List of elements waiting for return + # variable qadd - List of elements added and not yet reached for return. + + constructor {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # clear -- + # + # Clear a queue. + # + # Results: + # None. + + method clear {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # get -- + # + # Get an item from a queue. + # + # Arguments: + # count number of items to get; defaults to 1 + # + # Results: + # item first count items from the queue; if there are not enough + # items in the queue, throws an error. + + method get {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $qret $qat] + incr qat + my Shift? + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $qret] - $qat)} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set max [expr {$qat + $count - 1 - [llength $qret]}] + set result [concat [lrange $qret $qat end] [lrange $qadd 0 $max]] + my Shift + set qat $max + } else { + # Request can be satisified from qret alone. + set max [expr {$qat + $count - 1}] + set result [lrange $qret $qat $max] + set qat $max + } + + incr qat + my Shift? + return $result + } + + # peek -- + # + # Retrieve the value of an item on the queue without removing it. + # + # Arguments: + # count number of items to peek; defaults to 1 + # + # Results: + # items top count items from the queue; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + variable queues + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $qret $qat] + } + + # Otherwise, return a list of items + + if {$count > [llength $qret] - $qat} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set over [expr {$qat + $count - 1 - [llength $qret]}] + return [concat [lrange $qret $qat end] [lrange $qadd 0 $over]] + } else { + # Request can be satisified from qret alone. + return [lrange $qret $qat [expr {$qat + $count - 1}]] + } + } + + # put -- + # + # Put an item into a queue. + # + # Arguments: + # args items to put. + # + # Results: + # None. + + method put {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] put item ?item ...?\"" + } + foreach item $args { + lappend qadd $item + } + return + } + + # unget -- + # + # Put an item into a queue. At the _front_! + # + # Arguments: + # item item to put at the front of the queue + # + # Results: + # None. + + method unget {item} { + if {![llength $qret]} { + set qret [list $item] + } elseif {$qat == 0} { + set qret [linsert [my K $qret [unset qret]] 0 $item] + } else { + # step back and modify return buffer + incr qat -1 + set qret [lreplace [my K $qret [unset qret]] $qat $qat $item] + } + return + } + + # size -- + # + # Return the number of objects on a queue. + # + # Results: + # count number of items on the queue. + + method size {} { + return [expr { + [llength $qret] + [llength $qadd] - $qat + }] + } + + # ### ### ### ######### ######### ######### + + method Shift? {} { + if {$qat < [llength $qret]} return + # inlined Shift + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method Shift {} { + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + + proc queue_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::queue::queue_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::queue::queue_oo new] + } + } +} diff --git a/tcllib/modules/struct/queue_tcl.tcl b/tcllib/modules/struct/queue_tcl.tcl new file mode 100644 index 0000000..78f93bd --- /dev/null +++ b/tcllib/modules/struct/queue_tcl.tcl @@ -0,0 +1,383 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_tcl.tcl,v 1.2 2010/03/24 06:13:00 andreas_kupries Exp $ + +namespace eval ::struct::queue { + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # Only export one command, the one used to instantiate a new queue + namespace export queue_tcl +} + +# ::struct::queue::queue_tcl -- +# +# Create a new queue with a given name; if no name is given, use +# queueX, where X is a number. +# +# Arguments: +# name name of the queue; if null, generate one. +# +# Results: +# name name of the queue created + +proc ::struct::queue::queue_tcl {args} { + variable I::qat + variable I::qret + variable I::qadd + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "queue${counter}" + } + 2 { + # Standard call. New empty queue. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"queue ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create queue" + } + + # Initialize the queue as empty + set qat($name) 0 + set qret($name) [list] + set qadd($name) [list] + + # Create the command to manipulate the queue + interp alias {} $name {} ::struct::queue::QueueProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::queue::QueueProc -- +# +# Command that processes all queue object commands. +# +# Arguments: +# name name of the queue object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +if {[package vsatisfies [package provide Tcl] 8.5]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::queue::QueueProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::queue::I { + namespace export clear destroy get peek \ + put unget size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::queue::QueueProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::queue::I::$cmd]] == 0 } { + set optlist [lsort [info commands ::struct::queue::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "Shift") || ($p eq "Shift?")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::queue::I::$cmd $name] + } +} + +namespace eval ::struct::queue::I { + # The arrays hold all of the queues which were made. + variable qat ; # Index in qret of next element to return + variable qret ; # List of elements waiting for return + variable qadd ; # List of elements added and not yet reached for return. +} + +# ::struct::queue::I::clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::I::clear {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) [list] + set qadd($name) [list] + return +} + +# ::struct::queue::I::destroy -- +# +# Destroy a queue object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::I::destroy {name} { + variable qat ; unset qat($name) + variable qret ; unset qret($name) + variable qadd ; unset qadd($name) + interp alias {} $name {} + return +} + +# ::struct::queue::I::get -- +# +# Get an item from a queue. +# +# Arguments: +# name name of the queue object. +# count number of items to get; defaults to 1 +# +# Results: +# item first count items from the queue; if there are not enough +# items in the queue, throws an error. + +proc ::struct::queue::I::get {name {count 1}} { + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $RET $AT] + incr AT + Shift? $name + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $RET] - $AT)} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set max [expr {$count - ([llength $RET] - $AT) - 1}] + set result [concat [lrange $RET $AT end] [lrange $ADD 0 $max]] + Shift $name + set AT $max + } else { + # Request can be satisified from RET alone. + set max [expr {$AT + $count - 1}] + set result [lrange $RET $AT $max] + set AT $max + } + + incr AT + Shift? $name + return $result +} + +# ::struct::queue::I::peek -- +# +# Retrieve the value of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fulfill the request, throws an error. + +proc ::struct::queue::I::peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $RET $AT] + } + + # Otherwise, return a list of items + + if {$count > [llength $RET] - $AT} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set over [expr {$count - ([llength $RET] - $AT) - 1}] + return [concat [lrange $RET $AT end] [lrange $ADD 0 $over]] + } else { + # Request can be satisified from RET alone. + return [lrange $RET $AT [expr {$AT + $count - 1}]] + } +} + +# ::struct::queue::I::put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args items to put. +# +# Results: +# None. + +proc ::struct::queue::I::put {name args} { + variable qadd + if { [llength $args] == 0 } { + error "wrong # args: should be \"$name put item ?item ...?\"" + } + foreach item $args { + lappend qadd($name) $item + } + return +} + +# ::struct::queue::I::unget -- +# +# Put an item into a queue. At the _front_! +# +# Arguments: +# name name of the queue object +# item item to put at the front of the queue +# +# Results: +# None. + +proc ::struct::queue::I::unget {name item} { + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + + if {![llength $RET]} { + set RET [list $item] + } elseif {$AT == 0} { + set RET [linsert [K $RET [unset RET]] 0 $item] + } else { + # step back and modify return buffer + incr AT -1 + set RET [lreplace [K $RET [unset RET]] $AT $AT $item] + } + return +} + +# ::struct::queue::I::size -- +# +# Return the number of objects on a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# count number of items on the queue. + +proc ::struct::queue::I::size {name} { + variable qat + variable qret + variable qadd + return [expr { + [llength $qret($name)] + [llength $qadd($name)] - $qat($name) + }] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::queue::I::Shift? {name} { + variable qat + variable qret + if {$qat($name) < [llength $qret($name)]} return + Shift $name + return +} + +proc ::struct::queue::I::Shift {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) $qadd($name) + set qadd($name) [list] + return +} + +proc ::struct::queue::I::K {x y} { set x } + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + namespace import -force queue::queue_tcl +} + diff --git a/tcllib/modules/struct/record.html b/tcllib/modules/struct/record.html new file mode 100644 index 0000000..4fe4d23 --- /dev/null +++ b/tcllib/modules/struct/record.html @@ -0,0 +1,436 @@ +<html><head><title>record - Tcl Data Structures </title></head> +<! -- Generated from record.man by tcllib/doctools/mpexpand with fmt.html --> +<! -- Copyright (c) 2002 schwarz --> +<! -- All rights reserved --> +<! -- CVS: $Id: record.html,v 1.2 2004/01/15 06:36:14 andreas_kupries Exp $ record.n --> + +<h1> record(n) 1.2.1 record "Tcl Data Structures"</h1> +<a name="name"><h2>NAME</h2> +<p> record - Define and create records (similar to 'C' structures) +<! -- -*- tcl -*- --> +<! -- Author: Brett Schwarz <brett_schwarz@yahoo.com> --> + + +<a name="synopsis"><h2>SYNOPSIS</h2> +package require <b>Tcl 8.2</b><br> +package require <b>struct ?1.2.1?</b><br> +<br><table border=1 width=100% cellspacing=0 cellpadding=0><tr bgcolor=lightyellow><td bgcolor=lightyellow><table 0 width=100% cellspacing=0 cellpadding=0><tr valign=top ><td ><b class='cmd'>record define</b> <i class='arg'>recordName</i> <i class='arg'>recordMembers</i> ?<i class='arg'>instanceName1 instanceName2 ...</i>?</td></tr> +<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>record</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>instances</i> <i class='arg'>recordName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>members</i> <i class='arg'>recordName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>values</i> <i class='arg'>instanceName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record exists</b> <i class='arg'>record</i> <i class='arg'>recordName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record exists</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record delete</b> <i class='arg'>record</i> <i class='arg'>recordName</i></td></tr> +<tr valign=top ><td ><b class='cmd'>record delete</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i></td></tr> +<tr valign=top ><td ><i class='arg'>recordName</i> <strong><i class='arg'>instanceName|#auto</i></strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?</td></tr> +<tr valign=top ><td ><i class='arg'>instanceName</i> <strong>cget</strong> ?<i class='arg'>-member1 -member2 ...</i>?</td></tr> +<tr valign=top ><td ><i class='arg'>instanceName</i> <strong>configure</strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?</td></tr> +</table></td></tr></table> +<a name="description"><h2>DESCRIPTION</h2> + +The <b class='cmd'>::struct::record</b> package provides a mechanism to group variables together +as one data structure, similar to a 'C' structure. The members of a +record can be variables or other records. However, a record can not contain circular +record, i.e. records that contain the same record as a +member. + +<p> +This package was structured so that it is very similar to how Tk objects work. Each record +definition creates a record object that encompasses that definition. Subsequently, that +record object can create instances of that record. These instances can then +be manipulated with the <strong>cget</strong> and <strong>configure</strong> methods. + +<p> +The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified. + +<dl> + +<dt><b class='cmd'>record define</b> <i class='arg'>recordName</i> <i class='arg'>recordMembers</i> ?<i class='arg'>instanceName1 instanceName2 ...</i>?<dd> + + +Defines a record. <i class='arg'>recordName</i> is the name of the record, and is also +used as an object command. This object command is used to create instances of the +record definition. <i class='arg'>recordMembers</i> are the members of +the record that make up the record definition. These are variables +and other record. If optional <i class='arg'>instanceName</i> args are given, then an instance +is generated after the definition is created for each <i class='arg'>instanceName</i>. + +<br><br> +<dt><b class='cmd'>record show</b> <i class='arg'>record</i><dd> + + +Returns a list of records that have been defined. + +<br><br> +<dt><b class='cmd'>record show</b> <i class='arg'>instances</i> <i class='arg'>recordName</i><dd> + + +Returns the instances that have been instantiated by +<i class='arg'>recordName</i>. + +<br><br> +<dt><b class='cmd'>record show</b> <i class='arg'>members</i> <i class='arg'>recordName</i><dd> + + +Returns the members that are defined for +record <i class='arg'>recordName</i>. It returns the same format as how the +records were defined. + +<br><br> +<dt><b class='cmd'>record show</b> <i class='arg'>values</i> <i class='arg'>instanceName</i><dd> + + +Returns a list of values that are set for the instance +<i class='arg'>instanceName</i>. The output is a list of key/value pairs. If there +are nested records, then the values of the nested records will +itself be a list. + +<br><br> +<dt><b class='cmd'>record exists</b> <i class='arg'>record</i> <i class='arg'>recordName</i><dd> + + +Tests for the existence of a <i class='arg'>record</i> with the +name <i class='arg'>recordName</i>. + +<br><br> +<dt><b class='cmd'>record exists</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i><dd> + + +Tests for the existence of a <i class='arg'>instance</i> with the +name <i class='arg'>instanceName</i>. + +<br><br> +<dt><b class='cmd'>record delete</b> <i class='arg'>record</i> <i class='arg'>recordName</i><dd> + + +Deletes <i class='arg'>recordName</i>, and all instances of <i class='arg'>recordName</i>. It will return +an error if the record does not exist. + +<br><br> +<dt><b class='cmd'>record delete</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i><dd> + + +Deletes <i class='arg'>instance</i> with the name of <i class='arg'>instanceName</i>. It +will return an error if the instance does not exist. + +</dl> +<p> + +<a name="recordmembers"><h2>RECORD MEMBERS</h2> + +Record members can either be variables, or other records, However, the same +record can not be nested witin itself (circular). To define a nested record, +you need to specify the <strong>record</strong> keyword, along the with name of the record, and the name of the instance of that nested +record. For example, it would look like this: + +<p> +<p><table><tr><td bgcolor=black> </td><td><pre class='sample'> +# this is the nested record +record define mynestedrecord { + nest1 + nest2 +} + +# This is the main record +record define myrecord { + mem1 + mem2 + {record mynestedrecord mem3} +} + +</pre></td></tr></table></p> + +You can also assign default or initial values to the members of a record, +by enclosing the member entry in braces: + +<p> +<p><table><tr><td bgcolor=black> </td><td><pre class='sample'> + +record define myrecord { + mem1 + {mem2 5} +} + +</pre></td></tr></table></p> + +All instances created from this record definition, will initially have 5 as +the value for <i class='arg'>mem2</i>. If no default is given, then the value will be the empty string. + +<p> +<strong>Getting Values</strong> +<p> + +To get a value of a member, there are several ways to do this. + +<ol> + +<li> +To get a member value, then use the instance built-in <strong>cget</strong> method: +<br><br> + <i class='arg'>instanceName</i> <strong>cget</strong> -mem1 + +<br><br> +<li> +To get multiple member values, you can specify them all in one command: +<br><br> + <i class='arg'>instanceName</i> <strong>cget</strong> -mem1 -mem2 + +<br><br> +<li> +To get a list of the key/value of all of the members, there are 3 ways: +<br><br> + - <i class='arg'>instanceName</i> <strong>cget</strong> +<br><br> + - <i class='arg'>instanceName</i> <strong>configure</strong> +<br><br> + - <i class='arg'>instanceName</i> + +<br><br> +<li> +To get a value of a nested member, then use the dot notation: +<br><br> + <i class='arg'>instanceName</i> <strong>cget</strong> -mem3.nest1 + +</ol> + +<p> +<strong>Setting Values</strong> +<p> + +To set a value of a member, there are several ways to do this. + +<ol> + +<li> +To set a member value, then use the instance built-in <strong>configure</strong> method: +<br><br> + <i class='arg'>instanceName</i> <strong>configure</strong> -mem1 val1 + +<br><br> +<li> +To set multiple member values, you can specify them all in one command: +<br><br> + <i class='arg'>instanceName</i> <strong>configure</strong> -mem1 va1 -mem2 val2 + +<br><br> +<li> +To set a value of a nested member, then use the dot notation: +<br><br> + <i class='arg'>instanceName</i> <strong>configure</strong> -mem3.nest1 value + +</ol> + +<p> +<strong>Alias access</strong> +<p> + +In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, +there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still +exists. It might prove to be helpful to some. + +<p> +Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that +member. An example will illustrate the point, using the above defined records: + +<p> +<p><table><tr><td bgcolor=black> </td><td><pre class='sample'> +# Create an instance first +% myrecord inst1 +::inst1 +% # To get a member of an instance, just use the +% # alias (it behaves like a Tcl command): +% inst1.mem1 +% +% # To set a member via the alias, just include +% # a value (optionally the equal sign - syntactic sugar) +% inst1.mem1 = 5 +5 +% inst1.mem1 +5 +% # For nested records, just continue with the +% # dot notation (note no equal sign) +% inst1.mem3.nest1 10 +10 +% inst1.mem3.nest1 +10 +% # just the instance by itself gives all +% # member/values pairs for that instance +% inst1 +-mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}} +% # and to get all members within the nested record +% inst1.mem3 +-nest1 10 -nest2 {} +% + +</pre></td></tr></table></p> + +<a name="recordcommand"><h2>RECORD COMMAND</h2> + +The following subcommands and corresponding arguments are available to any +record command: + +<dl> + +<dt><i class='arg'>recordName</i> <strong><i class='arg'>instanceName|#auto</i></strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?<dd> + + +Using the <i class='arg'>recordName</i> object command that was created from the record definition, +instances of the record definition can be created. Once a instance is +created, then it inherits the members of the record definition, very +similar to how objects work. During instance generation, an object command for the instance +is created as well, using <i class='arg'>instanceName</i>. This object command is used +to access the data members of the instance. During the instantiation, values for +that instance can be given, <strong>but</strong> all values must be given, and be given +in key/value pairs. Nested records, need to be in list format. + +<br><br> +Optionally, <i class='arg'>#auto</i> can be used in place of <i class='arg'>instanceName</i>. When #auto is used, +then a instance name will automatically be generated, of the form recordName<integer>, where +<integer> is a unique integer (starting at 0) that is generated. + +</dl> +<p> + +<a name="instancecommand"><h2>INSTANCE COMMAND</h2> + +The following subcommands and corresponding arguments are available to +any record instance command: + +<dl> + +<dt><i class='arg'>instanceName</i> <strong>cget</strong> ?<i class='arg'>-member1 -member2 ...</i>?<dd> + + +Each instance has the sub command <strong>cget</strong> associated with it. This +is very similar to how Tk widget's cget command works. It queries +the values of the member for that particular instance. If +no arguments are given, then a key/value list is returned. + +<br><br> +<dt><i class='arg'>instanceName</i> <strong>configure</strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?<dd> + + +Each instance has the sub command <strong>configure</strong> associated with it. This +is very similar to how Tk widget's configure command works. It sets +the values of the particular member for that particular instance. If +no arguments are given, then a key/value list is returned. + +</dl> + +<a name="examples"><h2>EXAMPLES</h2> + +Two examples are provided to give an good illustration on how to use +this package. + +<p> +<strong>Example 1</strong> +<p> + +Probably the most obvious example would be to hold contact information, +such as addresses, phone numbers, comments, etc. Since a person can have +multiple phone numbers, multiple email addresses, etc, we will use nested +records to define these. So, the first thing we do is define the nested +records: + +<p> +<p><table><tr><td bgcolor=black> </td><td><pre class='sample'> + +## +## This is an interactive example, to see what is +## returned by each command as well. +## + +% namespace import ::struct::record::* + +% # define a nested record. Notice that country has default 'USA'. +% record define locations { + street + street2 + city + state + zipcode + {country USA} + phone +} +::locations +% # Define the main record. Notice that it uses the location record twice. +% record define contacts { + first + middle + last + {record locations home} + {record locations work} +} +::contacts +% # Create an instance for the contacts record. +% contacts cont1 +::cont1 +% # Display some introspection values +% record show records +::contacts ::locations +% # +% record show values cont1 +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # +% record show instances contacts +::cont1 +% # +% cont1 config +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # +% cont1 cget +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # copy one record to another record +% record define contacts2 [record show members contacts] +::contacts2 +% record show members contacts2 +first middle last {record locations home} {record locations work} +% record show members contacts +first middle last {record locations home} {record locations work} +% +</pre></td></tr></table></p> + +<p> +<strong>Example 1</strong> +<p> + +This next example just illustrates a simple linked list +<p> +<p><table><tr><td bgcolor=black> </td><td><pre class='sample'> + +% # define a very simple record for linked list +% record define llist { + value + next +} +::llist +% llist lstart +::lstart +% lstart config -value 1 -next [llist #auto] +% [lstart cget -next] config -value 2 -next [llist #auto] +% [[lstart cget -next] cget -next] config -value 3 -next "end" +% set next lstart +lstart +% while 1 { +lappend values [$next cget -value] +set next [$next cget -next] +if {[string match "end" $next]} {break} +} +% puts "$values" +1 2 3 +% # cleanup linked list +% # We could just use delete record llist also +% foreach I [record show instances llist] { +record delete instance $I +} +% record show instances llist +% + +</pre></td></tr></table></p> + +<p> + +<a name="keywords"><h2>KEYWORDS</h2> +struct, record, data structures +</body></html> diff --git a/tcllib/modules/struct/record.man b/tcllib/modules/struct/record.man new file mode 100644 index 0000000..cb576e1 --- /dev/null +++ b/tcllib/modules/struct/record.man @@ -0,0 +1,393 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::record n 1.2.1] +[keywords {data structures}] +[keywords record] +[keywords struct] +[copyright {2002, Brett Schwarz <brett_schwarz@yahoo.com>}] +[moddesc {Tcl Data Structures}] +[titledesc {Define and create records (similar to 'C' structures)}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::record [opt 1.2.1]] +[description] + +The [cmd ::struct::record] package provides a mechanism to group variables together +as one data structure, similar to a 'C' structure. The members of a +record can be variables or other records. However, a record can not contain circular +record, i.e. records that contain the same record as a +member. + +[para] +This package was structured so that it is very similar to how Tk objects work. Each record +definition creates a record object that encompasses that definition. Subsequently, that +record object can create instances of that record. These instances can then +be manipulated with the [method cget] and [method configure] methods. + +[para] +The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified. + +[list_begin definitions] + +[call [cmd {record define}] [arg recordName] [arg recordMembers] [opt [arg "instanceName1 instanceName2 ..."]]] + +Defines a record. [arg recordName] is the name of the record, and is also +used as an object command. This object command is used to create instances of the +record definition. [arg recordMembers] are the members of +the record that make up the record definition. These are variables +and other record. If optional [arg instanceName] args are given, then an instance +is generated after the definition is created for each [arg instanceName]. + +[call [cmd {record show}] [arg record]] + +Returns a list of records that have been defined. + +[call [cmd {record show}] [arg instances] [arg recordName]] + +Returns the instances that have been instantiated by +[arg recordName]. + +[call [cmd {record show}] [arg members] [arg recordName]] + +Returns the members that are defined for +record [arg recordName]. It returns the same format as how the +records were defined. + +[call [cmd {record show}] [arg values] [arg instanceName]] + +Returns a list of values that are set for the instance +[arg instanceName]. The output is a list of key/value pairs. If there +are nested records, then the values of the nested records will +itself be a list. + +[call [cmd {record exists}] [arg record] [arg recordName]] + +Tests for the existence of a [arg record] with the +name [arg recordName]. + +[call [cmd {record exists}] [arg instance] [arg instanceName]] + +Tests for the existence of a [arg instance] with the +name [arg instanceName]. + +[call [cmd {record delete}] [arg record] [arg recordName]] + +Deletes [arg recordName], and all instances of [arg recordName]. It will return +an error if the record does not exist. + +[call [cmd {record delete}] [arg instance] [arg instanceName]] + +Deletes [arg instance] with the name of [arg instanceName]. It +will return an error if the instance does not exist. + +[list_end] +[para] + +[section {RECORD MEMBERS}] + +Record members can either be variables, or other records, However, the +same record can not be nested witin itself (circular). To define a +nested record, you need to specify the [const record] keyword, along +the with name of the record, and the name of the instance of that +nested record. For example, it would look like this: + +[para] +[example_begin] +# this is the nested record +record define mynestedrecord { + nest1 + nest2 +} + +# This is the main record +record define myrecord { + mem1 + mem2 + {record mynestedrecord mem3} +} + +[example_end] + +You can also assign default or initial values to the members of a record, +by enclosing the member entry in braces: + +[para] +[example_begin] + +record define myrecord { + mem1 + {mem2 5} +} + +[example_end] + +All instances created from this record definition, will initially have 5 as +the value for [arg mem2]. If no default is given, then the value will be the empty string. + +[para] +[emph {Getting Values}] +[para] + +To get a value of a member, there are several ways to do this. + +[list_begin enumerated] + +[enum] +To get a member value, then use the instance built-in [method cget] method: +[para] + [arg instanceName] [method cget] -mem1 + +[enum] +To get multiple member values, you can specify them all in one command: +[para] + [arg instanceName] [method cget] -mem1 -mem2 + +[enum] +To get a list of the key/value of all of the members, there are 3 ways: +[para] + - [arg instanceName] [method cget] +[para] + - [arg instanceName] [method configure] +[para] + - [arg instanceName] + +[enum] +To get a value of a nested member, then use the dot notation: +[para] + [arg instanceName] [method cget] -mem3.nest1 + +[list_end] + +[para] +[emph {Setting Values}] +[para] + +To set a value of a member, there are several ways to do this. + +[list_begin enumerated] + +[enum] +To set a member value, then use the instance built-in [method configure] method: +[para] + [arg instanceName] [method configure] -mem1 val1 + +[enum] +To set multiple member values, you can specify them all in one command: +[para] + [arg instanceName] [method configure] -mem1 va1 -mem2 val2 + +[enum] +To set a value of a nested member, then use the dot notation: +[para] + [arg instanceName] [method configure] -mem3.nest1 value + +[list_end] + +[para] +[emph {Alias access}] +[para] + +In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, +there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still +exists. It might prove to be helpful to some. + +[para] +Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that +member. An example will illustrate the point, using the above defined records: + +[para] +[example_begin] +# Create an instance first +% myrecord inst1 +::inst1 +% # To get a member of an instance, just use the +% # alias (it behaves like a Tcl command): +% inst1.mem1 +% +% # To set a member via the alias, just include +% # a value (optionally the equal sign - syntactic sugar) +% inst1.mem1 = 5 +5 +% inst1.mem1 +5 +% # For nested records, just continue with the +% # dot notation (note no equal sign) +% inst1.mem3.nest1 10 +10 +% inst1.mem3.nest1 +10 +% # just the instance by itself gives all +% # member/values pairs for that instance +% inst1 +-mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}} +% # and to get all members within the nested record +% inst1.mem3 +-nest1 10 -nest2 {} +% + +[example_end] + +[section {RECORD COMMAND}] + +The following subcommands and corresponding arguments are available to any +record command: + +[list_begin definitions] + +[call [arg recordName] [method [arg instanceName|#auto]] [opt [arg "-member1 value1 -member2 value2 ..."]]] + +Using the [arg recordName] object command that was created from the record definition, +instances of the record definition can be created. Once a instance is +created, then it inherits the members of the record definition, very +similar to how objects work. During instance generation, an object command for the instance +is created as well, using [arg instanceName]. This object command is used +to access the data members of the instance. During the instantiation, values for +that instance can be given, [emph but] all values must be given, and be given +in key/value pairs. Nested records, need to be in list format. + +[para] +Optionally, [arg #auto] can be used in place of [arg instanceName]. When #auto is used, +then a instance name will automatically be generated, of the form recordName<integer>, where +<integer> is a unique integer (starting at 0) that is generated. + +[list_end] +[para] + +[section {INSTANCE COMMAND}] + +The following subcommands and corresponding arguments are available to +any record instance command: + +[list_begin definitions] + +[call [arg instanceName] [method cget] [opt [arg "-member1 -member2 ..."]]] + +Each instance has the sub command [method cget] associated with it. This +is very similar to how Tk widget's cget command works. It queries +the values of the member for that particular instance. If +no arguments are given, then a key/value list is returned. + +[call [arg instanceName] [method configure] [opt [arg "-member1 value1 -member2 value2 ..."]]] + +Each instance has the sub command [method configure] associated with it. This +is very similar to how Tk widget's configure command works. It sets +the values of the particular member for that particular instance. If +no arguments are given, then a key/value list is returned. + +[list_end] + +[section EXAMPLES] + +Two examples are provided to give an good illustration on how to use +this package. + +[para] +[emph {Example 1}] +[para] + +Probably the most obvious example would be to hold contact information, +such as addresses, phone numbers, comments, etc. Since a person can have +multiple phone numbers, multiple email addresses, etc, we will use nested +records to define these. So, the first thing we do is define the nested +records: + +[para] +[example { + +## +## This is an interactive example, to see what is +## returned by each command as well. +## + +% namespace import ::struct::record::* + +% # define a nested record. Notice that country has default 'USA'. +% record define locations { + street + street2 + city + state + zipcode + {country USA} + phone +} +::locations +% # Define the main record. Notice that it uses the location record twice. +% record define contacts { + first + middle + last + {record locations home} + {record locations work} +} +::contacts +% # Create an instance for the contacts record. +% contacts cont1 +::cont1 +% # Display some introspection values +% record show records +::contacts ::locations +% # +% record show values cont1 +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # +% record show instances contacts +::cont1 +% # +% cont1 config +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # +% cont1 cget +-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} +% # copy one record to another record +% record define contacts2 [record show members contacts] +::contacts2 +% record show members contacts2 +first middle last {record locations home} {record locations work} +% record show members contacts +first middle last {record locations home} {record locations work} +% +}] + +[para] +[emph {Example 1}] +[para] + +This next example just illustrates a simple linked list +[para] +[example { + +% # define a very simple record for linked list +% record define llist { + value + next +} +::llist +% llist lstart +::lstart +% lstart config -value 1 -next [llist #auto] +% [lstart cget -next] config -value 2 -next [llist #auto] +% [[lstart cget -next] cget -next] config -value 3 -next "end" +% set next lstart +lstart +% while 1 { +lappend values [$next cget -value] +set next [$next cget -next] +if {[string match "end" $next]} {break} +} +% puts "$values" +1 2 3 +% # cleanup linked list +% # We could just use delete record llist also +% foreach I [record show instances llist] { +record delete instance $I +} +% record show instances llist +% + +}] + +[para] + +[vset CATEGORY {struct :: record}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/record.tcl b/tcllib/modules/struct/record.tcl new file mode 100644 index 0000000..5279452 --- /dev/null +++ b/tcllib/modules/struct/record.tcl @@ -0,0 +1,778 @@ +#============================================================ +# ::struct::record -- +# +# Implements a container data structure similar to a 'C' +# structure. It hides the ugly details about keeping the +# data organized by using a combination of arrays, lists +# and namespaces. +# +# Each record definition is kept in a master array +# (_recorddefn) under the ::struct::record namespace. Each +# instance of a record is kept within a separate namespace +# for each record definition. Hence, instances of +# the same record definition are managed under the +# same namespace. This avoids possible collisions, and +# also limits one big global array mechanism. +# +# Copyright (c) 2002 by Brett Schwarz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This code may be distributed under the same terms as Tcl. +# +# $Id: record.tcl,v 1.10 2004/09/29 20:56:18 andreas_kupries Exp $ +# +#============================================================ +# +#### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) + +namespace eval ::struct {} + +namespace eval ::struct::record { + + ## + ## array of lists that holds the + ## definition (variables) for each + ## record + ## + ## _recorddefn(some_record) var1 var2 var3 ... + ## + variable _recorddefn + + ## + ## holds the count for each record + ## in cases where the instance is + ## automatically generated + ## + ## _count(some_record) 0 + ## + + ## This is not a count, but an id generator. Its value has to + ## increase monotonicaly. + + variable _count + + ## + ## array that holds the defining record's + ## name for each instances + ## + ## _defn(some_instances) name_of_defining_record + ## + variable _defn + array set _defn {} + + ## + ## This holds the defaults for a record definition. + ## If no default is given for a member of a record, + ## then the value is assigned to the empty string + ## + variable _defaults + + ## + ## These are the possible sub commands + ## + variable commands + set commands [list define delete exists show] + + ## + ## This keeps track of the level that we are in + ## when handling nested records. This is kind of + ## a hack, and probably can be handled better + ## + set _level 0 + + namespace export record +} + +#------------------------------------------------------------ +# ::struct::record::record -- +# +# main command used to access the other sub commands +# +# Arguments: +# cmd_ The sub command (i.e. define, show, delete, exists) +# args arguments to pass to the sub command +# +# Results: +# none returned +#------------------------------------------------------------ +# +proc ::struct::record::record {cmd_ args} { + variable commands + + if {[lsearch $commands $cmd_] < 0} { + error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]" + } + + set cmd_ [string totitle "$cmd_"] + return [uplevel 1 ::struct::record::${cmd_} $args] + +}; # end proc ::struct::record::record + + +#------------------------------------------------------------ +# ::struct::record::Define -- +# +# Used to define a record +# +# Arguments: +# defn_ the name of the record definition +# vars_ the variables of the record (as a list) +# args instances to be create during definition +# +# Results: +# Returns the name of the definition during successful +# creation. +#------------------------------------------------------------ +# +proc ::struct::record::Define {defn_ vars_ args} { + + variable _recorddefn + variable _count + variable _defaults + + set defn_ [Qualify $defn_] + + if {[info exists _recorddefn($defn_)]} { + error "Record definition $defn_ already exists" + } + + if {[lsearch [info commands] $defn_] >= 0} { + error "Structure definition name can not be a Tcl command name" + } + + set _defaults($defn_) [list] + set _recorddefn($defn_) [list] + + + ## + ## Loop through the members of the record + ## definition + ## + foreach V $vars_ { + + set len [llength $V] + set D "" + + ## + ## 2 --> there is a default value + ## assigned to the member + ## + ## 3 --> there is a nested record + ## definition given as a member + ## + if {$len == 2} { + + set D [lindex $V 1] + set V [lindex $V 0] + + } elseif {$len == 3} { + + if {![string match "record" "[lindex $V 0]"]} { + + Delete record $defn_ + error "$V is a Bad member for record definition + definition creation aborted." + } + + set new [lindex $V 1] + + set new [Qualify $new] + + ## + ## Right now, there can not be circular records + ## so, we abort the creation + ## + if {[string match "$defn_" "$new"]} { + Delete record $defn_ + error "Can not have circular records. Structure was not created." + } + + ## + ## Will take care of the nested record later + ## We just join by :: because this is how it + ## use to be declared, so the parsing code + ## is already there. + ## + set V [join [lrange $V 1 2] "::"] + } + + lappend _recorddefn($defn_) $V + lappend _defaults($defn_) $D + } + + + uplevel #0 [list interp alias {} $defn_ {} ::struct::record::Create $defn_] + + set _count($defn_) 0 + + namespace eval ::struct::record${defn_} { + variable values + variable instances + + set instances [list] + } + + ## + ## If there were args given (instances), then + ## create them now + ## + foreach A $args { + + uplevel 1 [list ::struct::record::Create $defn_ $A] + } + + return $defn_ + +}; # end proc ::struct::record::Define + + +#------------------------------------------------------------ +# ::struct::record::Create -- +# +# Creates an instance of a record definition +# +# Arguments: +# defn_ the name of the record definition +# inst_ the name of the instances to create +# args values to set to the record's members +# +# Results: +# Returns the name of the instance for a successful creation +#------------------------------------------------------------ +# +proc ::struct::record::Create {defn_ inst_ args} { + + variable _recorddefn + variable _count + variable _defn + variable _defaults + variable _level + + set inst_ [Qualify "$inst_"] + + ## + ## test to see if the record + ## definition has been defined yet + ## + if {![info exists _recorddefn($defn_)]} { + error "Structure $defn_ does not exist" + } + + + ## + ## if there was no argument given, + ## then assume that the record + ## variable is automatically + ## generated + ## + if {[string match "[Qualify #auto]" "$inst_"]} { + set c $_count($defn_) + set inst_ [format "%s%s" ${defn_} $_count($defn_)] + incr _count($defn_) + } + + ## + ## Test to see if this instance is already + ## created. This avoids any collisions with + ## previously created instances + ## + if {[info exists _defn($inst_)]} { + incr _count($defn_) -1 + error "Instances $inst_ already exists" + } + + set _defn($inst_) $defn_ + + ## + ## Initialize record variables to + ## defaults + ## + + uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] + + set cnt 0 + foreach V $_recorddefn($defn_) D $_defaults($defn_) { + + set [Ns $inst_]values($inst_,$V) $D + + ## + ## Test to see if there is a nested record + ## + if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { + + if {$_level == 0} { + set _level 2 + } + + ## + ## This is to guard against if the creation + ## had failed, that there isn't any + ## lingering variables/alias around + ## + set def [Qualify $def $_level] + + if {![info exists _recorddefn($def)]} { + + Delete inst "$inst_" + + return + } + + ## + ## evaluate the nested record. If there + ## were values for the variables passed + ## in, then we assume that the value for + ## this nested record is a list + ## corresponding the the nested list's + ## variables, and so we pass that to + ## the nested record's instantiation. + ## We then get rid of those args for later + ## processing. + ## + set cnt_plus [expr {$cnt + 1}] + set mem [lindex $args $cnt] + if {![string match "" "$mem"]} { + if {![string match "-$inst" "$mem"]} { + Delete inst "$inst_" + error "$inst is not a member of $defn_" + } + } + incr _level + set narg [lindex $args $cnt_plus] + eval [linsert $narg 0 Create $def ${inst_}.${inst}] + set args [lreplace $args $cnt $cnt_plus] + + incr _level -1 + } else { + + uplevel #0 [list interp alias {} ${inst_}.$V {} ::struct::record::Access $defn_ $inst_ $V] + incr cnt 2 + } + + }; # end foreach variable + + lappend [Ns $inst_]instances $inst_ + + foreach {k v} $args { + + Access $defn_ $inst_ [string trimleft "$k" -] $v + + }; # end foreach arg {} + + if {$_level == 2} { + set _level 0 + } + + return $inst_ + +}; # end proc ::struct::record::Create + + +#------------------------------------------------------------ +# ::struct::record::Access -- +# +# Provides a common proc to access the variables +# from the aliases create for each variable in the record +# +# Arguments: +# defn_ the name of the record to access +# inst_ the name of the instance to create +# var_ the variable of the record to access +# args a value to set to var_ (if any) +# +# Results: +# Returns the value of the record member (var_) +#------------------------------------------------------------ +# +proc ::struct::record::Access {defn_ inst_ var_ args} { + + variable _recorddefn + variable _defn + + set i [lsearch $_recorddefn($defn_) $var_] + + if {$i < 0} { + error "$var_ does not exist in record $defn_" + } + + if {![info exists _defn($inst_)]} { + + error "$inst_ does not exist" + } + + if {[set idx [lsearch $args "="]] >= 0} { + set args [lreplace $args $idx $idx] + } + + ## + ## If a value was given, then set it + ## + if {[llength $args] != 0} { + + set val_ [lindex $args 0] + + set [Ns $inst_]values($inst_,$var_) $val_ + } + + return [set [Ns $inst_]values($inst_,$var_)] + +}; # end proc ::struct::record::Access + + +#------------------------------------------------------------ +# ::struct::record::Cmd -- +# +# Used to process the set/get requests. +# +# Arguments: +# inst_ the record instance name +# args For 'get' this is the record members to +# retrieve. For 'set' this is a member/value +# pair. +# +# Results: +# For 'set' returns the empty string. For 'get' it returns +# the member values. +#------------------------------------------------------------ +# +proc ::struct::record::Cmd {inst_ args} { + + variable _defn + + set result [list] + + set len [llength $args] + if {$len <= 1} {return [Show values "$inst_"]} + + set cmd [lindex $args 0] + + if {[string match "cget" "$cmd"]} { + + set cnt 0 + foreach k [lrange $args 1 end] { + if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { + error "Bad option \"$k\"" + } + + lappend result $r + incr cnt + } + if {$cnt == 1} {set result [lindex $result 0]} + return $result + + } elseif {[string match "config*" "$cmd"]} { + + set L [lrange $args 1 end] + foreach {k v} $L { + ${inst_}.[string trimleft ${k} -] $v + } + + } else { + error "Wrong argument. + must be \"object cget|configure args\"" + } + + return [list] + +}; # end proc ::struct::record::Cmd + + +#------------------------------------------------------------ +# ::struct::record::Ns -- +# +# This just constructs a fully qualified namespace for a +# particular instance. +# +# Arguments; +# inst_ instance to construct the namespace for. +# +# Results: +# Returns the fully qualified namespace for the instance +#------------------------------------------------------------ +# +proc ::struct::record::Ns {inst_} { + + variable _defn + + if {[catch {set ret $_defn($inst_)} err]} { + return $inst_ + } + + return [format "%s%s%s" "::struct::record" $ret "::"] + +}; # end proc ::struct::record::Ns + + +#------------------------------------------------------------ +# ::struct::record::Show -- +# +# Display info about the record that exist +# +# Arguments: +# what_ subcommand +# record_ record or instance to process +# +# Results: +# if what_ = record, then return list of records +# definition names. +# if what_ = members, then return list of members +# or members of the record. +# if what_ = instance, then return a list of instances +# with record definition of record_ +# if what_ = values, then it will return the values +# for a particular instance +#------------------------------------------------------------ +# +proc ::struct::record::Show {what_ {record_ ""}} { + + variable _recorddefn + variable _defn + variable _defaults + + ## + ## We just prepend :: to the record_ argument + ## + if {![string match "::*" "$record_"]} {set record_ "::$record_"} + + if {[string match "record*" "$what_"]} { + return [lsort [array names _recorddefn]] + } elseif {[string match "mem*" "$what_"]} { + + if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { + error "Bad arguments while accessing members. Bad record name" + } + + set res [list] + set cnt 0 + foreach m $_recorddefn($record_) { + set def [lindex $_defaults($record_) $cnt] + if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { + lappend res [list record $d $i] + } elseif {![string match "" "$def"]} { + lappend res [list $m $def] + } else { + lappend res $m + } + + incr cnt + } + + return $res + + } elseif {[string match "inst*" "$what_"]} { + + if {![info exists ::struct::record${record_}::instances]} { + return [list] + } + return [lsort [set ::struct::record${record_}::instances]] + + } elseif {[string match "val*" "$what_"]} { + + set ns $_defn($record_) + + if {[string match "" "$record_"] || ([lsearch [set [Ns $record_]instances] $record_] < 0)} { + + error "Wrong arguments to values. Bad instance name" + } + + set ret [list] + foreach k $_recorddefn($ns) { + + set v [set [Ns $record_]values($record_,$k)] + + if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { + set v [::struct::record::Show values ${record_}.${inst}] + } + + lappend ret -[namespace tail $k] $v + } + return $ret + + } + + return [list] + +}; # end proc ::struct::record::Show + + +#------------------------------------------------------------ +# ::struct::record::Delete -- +# +# Deletes a record instance or a record definition +# +# Arguments: +# sub_ what to delete. Either 'instance' or 'record' +# item_ the specific record instance or definition +# delete. +# +# Returns: +# none +# +#------------------------------------------------------------ +# +proc ::struct::record::Delete {sub_ item_} { + + variable _recorddefn + variable _defn + variable _count + variable _defaults + + ## + ## We just semi-blindly prepend :: to the record_ argument + ## + if {![string match "::*" "$item_"]} {set item_ "::$item_"} + + switch -- $sub_ { + + instance - + instances - + inst { + + + if {[Exists instance $item_]} { + + set ns $_defn($item_) + foreach A [info commands ${item_}.*] { + Delete inst $A + } + + catch { + foreach {k v} [array get [Ns $item_]values $item_,*] { + + unset [Ns $item_]values($k) + } + set i [lsearch [set [Ns $item_]instances] $item_] + set [Ns $item_]instances [lreplace [set [Ns $item_]instances] $i $i] + unset _defn($item_) + } + + # Auto-generated id numbers increase monotonically. + # Reverting here causes the next auto to fail, claiming + # that the instance exists. + # incr _count($ns) -1 + + } else { + #error "$item_ is not a instance" + } + } + record - + records { + + + ## + ## Delete the instances for this + ## record + ## + foreach I [Show instance "$item_"] { + catch {Delete instance "$I"} + } + + catch { + unset _recorddefn($item_) + unset _defaults($item_) + unset _count($item_) + namespace delete ::struct::record${item_} + } + + + } + default { + error "Wrong arguments to delete" + } + + }; # end switch + + catch { uplevel #0 [list interp alias {} $item_ {}]} + + return + +}; # end proc ::struct::record::Delete + + +#------------------------------------------------------------ +# ::struct::record::Exists -- +# +# Tests whether a record definition or record +# instance exists. +# +# Arguments: +# sub_ what to test. Either 'instance' or 'record' +# item_ the specific record instance or definition +# that needs to be tested. +# +# Tests to see if a particular instance exists +# +#------------------------------------------------------------ +# +proc ::struct::record::Exists {sub_ item_} { + + + switch -glob -- $sub_ { + inst* { + + if {([lsearch ::[Ns $item_]instances $item_] >=0) || [llength [info commands ::${item_}.*]]} { + return 1 + } else { + return 0 + } + } + record { + + set item_ "::$item_" + if {[info exists _recorddefn($item_)] || [llength [info commands ${item_}]]} { + return 1 + } else { + return 0 + } + } + default { + error "Wrong arguments. Must be exists record|instance target" + } + }; # end switch + +}; # end proc ::struct::record::Exists + + +#------------------------------------------------------------ +# ::struct::record::Qualify -- +# +# Contructs the qualified name of the calling scope. This +# defaults to 2 levels since there is an extra proc call in +# between. +# +# Arguments: +# item_ the command that needs to be qualified +# level_ how many levels to go up (default = 2) +# +# Results: +# the item_ passed in fully qualified +# +#------------------------------------------------------------ +# +proc ::struct::record::Qualify {item_ {level_ 2}} { + + if {![string match "::*" "$item_"]} { + set ns [uplevel $level_ [list namespace current]] + + if {![string match "::" "$ns"]} { + append ns "::" + } + + set item_ "$ns${item_}" + } + + return "$item_" + +}; # end proc ::struct::record::Qualify + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'record::record' into the general structure namespace. + namespace import -force record::record + namespace export record +} +package provide struct::record 1.2.1 diff --git a/tcllib/modules/struct/record.test b/tcllib/modules/struct/record.test new file mode 100644 index 0000000..62075de --- /dev/null +++ b/tcllib/modules/struct/record.test @@ -0,0 +1,467 @@ +# -*- tcl -*- +#------------------------------------------------------------ +# record.test -- +# +# test suite for struct::record module +# +# Tcl tests for testing the struct::record package, which +# loosely immitates a 'C' structure. Invoke this test suite +# by: tclsh record.test +# + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal record.tcl struct::record +} + +# ------------------------------------------------------------------------- + +namespace import struct::record + +#---------------------------------------------------------------------- + +test record-0.1 {record define} { + record define phones {home work cell} +} ::phones + +test record-0.2 {record define - multi line} { + record define contact { + first + middle + last + {record phones phlist} + } +} ::contact + +test record-0.3 {record define - multi line} { + record define mycontact { + age + sex + {record contact cont} + } +} ::mycontact + +test record-0.4 {definition with instantiation} { + record define location { + street + city + state + {country USA} + } loc(1) loc(5) +} ::location + +test record-0.5 {test error with circular records} { + catch { + record define circular { + one + {record circular cir} + } cir(1) + } err + set err +} "Can not have circular records. Structure was not created." + +test record-0.6 {single instance} { + contact cont(1) +} ::cont(1) + +test record-0.7 {auto instance} { + contact #auto +} ::contact0 + +test record-0.8 {instance of double nested record} { + set res [mycontact #auto] + lappend res [record show values $res] + set res +} {::mycontact0 {-age {} -sex {} -cont {-first {} -middle {} -last {} -phlist {-home {} -work {} -cell {}}}}} + +test record-0.9 {setting a instance var via alias} { + cont(1).first Brett +} Brett + +test record-1.0 {setting a nested instance var via alias} { + cont(1).phlist.cell 425-555-1212 +} 425-555-1212 + +test record-1.1 {setting a double nested instance var via alias} { + mycontact0.cont.phlist.cell 206-555-1212 +} 206-555-1212 + +test record-1.2 {setting values via config} { + cont(1) config -middle Allen -last Schwarz +} "" + +test record-1.3 {setting a double nested instance via config} { + mycontact0 config -cont.phlist.cell 206-555-1212 +} "" + +test record-1.4 {get a value via cget} { + cont(1) cget -first -middle -last +} [list Brett Allen Schwarz] + +test record-1.5 {get a double nested value via cget} { + mycontact0 cget -cont.phlist.cell +} 206-555-1212 + +test record-1.6 {get a value via alias} { + cont(1).first +} Brett + +test record-1.7 {record default value} { + loc(1) cget -country +} USA + +test record-1.8 {setting values via config} { + loc(1) config -street somestreet -city somecity -state somestate -country somecountry +} "" + +test record-1.9 {setting nested vars via config} { + cont(1) config -phlist.home 425-555-1212 +} "" + +test record-2.0 {test value of nested member} { + cont(1) cget -phlist.home +} 425-555-1212 + +test record-2.1 {config with no values} { + loc(1) config +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-2.2 {get with no values} { + loc(1) cget +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-2.3 {get with just instance command} { + loc(1) +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-2.4 {get a nest value via alias} { + cont(1).phlist.cell +} 425-555-1212 + +test record-2.5 {set values during instantiation} { + location loc(2) -street street2 -city city2 -state state2 -country country2 +} ::loc(2) + +test record-2.6 {get the above value via alias} { + loc(2).street +} street2 + +test record-2.7 {set values during instantiation - nested record} { + contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111] +} ::cont(2) + +test record-2.8 {copy one instance to another during creation} { + eval contact cont(3) [cont(1)] +} ::cont(3) + +test record-2.9 {get the above values via alias} { + cont(2).phlist.home +} 425-555-1212 + +test record-3.0 {copy one definition to another definition} { + record define new_contact [record show members contact] +} ::new_contact + +test record-3.1 {show defined records} { + record show records +} [lsort [list ::phones ::contact ::location ::new_contact ::mycontact]] + +test record-3.2 {show members} { + record show members phones +} [list home work cell] + +test record-3.3 {show members - with default value} { + record show members location +} [list street city state [list country USA]] + +test record-3.4 {show members - nested record} { + record show members contact +} [list first middle last [list record phones phlist]] + +test record-3.5 {show values} { + record show values loc(1) +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-3.6 {show values - nested} { + record show values cont(1) +} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]] + +test record-3.7 {show instances} { + record show instance location +} [list ::loc(1) ::loc(2) ::loc(5)] + + +test record-3.8 {delete an instance} { + record delete instance loc(2) +} "" + +test record-3.9 {delete a nested instance} { + record delete instance cont(2) +} "" + +test record-4.0 {delete a record} { + record delete record location +} "" + +test record-4.1 {test existence of an instance that was deleted} { + record exists instance loc(1) +} 0 + +test record-4.2 {show existence of an instance} { + record exists instance cont(1) +} 1 + +test record-4.3 {show non-existent instance} { + record exists instance junk +} 0 + +test record-4.4 {show existence of record} { + record exists record contact +} 1 + + +## +## NAMESPACE TESTS +## + +test record-5.0 {record define} { + namespace eval myns { + record define phones {home work cell} + } +} ::myns::phones + +test record-5.1 {record define - multi line} { + record define ::myns::contact { + first + middle + last + {record phones phlist} + } +} ::myns::contact + +test record-5.2 {definition with instantiation} { + namespace eval myns { + record define location { + street + city + state + {country USA} + } loc(1) loc(5) + } +} ::myns::location + +test record-5.3 {test error with circular records} { + catch { + namespace eval myns { + record define circular { + one + {record ::myns::circular cir} + } cir(1) + } + } err + set err +} "Can not have circular records. Structure was not created." + +test record-5.4 {single instance} { + namespace eval myns { + contact cont(1) + } +} ::myns::cont(1) + +test record-5.5 {auto instance} { + namespace eval myns { + contact #auto + } +} ::myns::contact0 + +test record-5.6 {setting a instance var via alias} { + myns::cont(1).first Brett +} Brett + +test record-5.7 {setting a nested instance var via alias} { + myns::cont(1).phlist.cell 425-555-1212 +} 425-555-1212 + +test record-5.8 {setting values via config} { + myns::cont(1) config -middle Allen -last Schwarz +} "" + +test record-5.9 {get a value via cget} { + myns::cont(1) cget -first -middle -last +} [list Brett Allen Schwarz] + +test record-6.0 {record default value} { + myns::loc(1) cget -country +} USA + +test record-6.1 {setting values via config} { + myns::loc(1) config -street somestreet -city somecity -state somestate -country somecountry +} "" + +test record-6.2 {setting nested vars via config} { + myns::cont(1) config -phlist.home 425-555-1212 +} "" + +test record-6.3 {test value of nested member} { + myns::cont(1) cget -phlist.home +} 425-555-1212 + +test record-6.4 {config with no values} { + myns::loc(1) config +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-6.5 {get with no values} { + myns::loc(1) cget +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-6.6 {get with just instance command} { + myns::loc(1) +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-6.7 {get a nest value via alias} { + myns::cont(1).phlist.cell +} 425-555-1212 + +test record-6.8 {set values during instantiation} { + namespace eval myns { + location loc(2) -street street2 -city city2 -state state2 -country country2 + } +} ::myns::loc(2) + +test record-6.9 {get the above value via alias} { + myns::loc(2).street +} street2 + +test record-7.0 {set values during instantiation - nested record} { + namespace eval myns { + contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111] + } +} ::myns::cont(2) + +test record-7.1 {get the above values via alias} { + myns::cont(2).phlist.home +} 425-555-1212 + + +test record-7.2 {show defined records} { + record show records +} [lsort [list ::contact ::myns::phones ::myns::contact ::myns::location ::new_contact ::phones ::mycontact]] + +test record-7.3 {show members} { + record show members myns::phones +} [list home work cell] + +test record-7.4 {show members - with default value} { + record show members myns::location +} [list street city state [list country USA]] + +test record-7.5 {show members - nested record} { + record show members myns::contact +} [list first middle last [list record phones phlist]] + +test record-7.6 {show values} { + record show values myns::loc(1) +} [list -street somestreet -city somecity -state somestate -country somecountry] + +test record-7.7 {show values - nested} { + record show values myns::cont(1) +} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]] + +test record-7.8 {show instances} { + record show instance myns::location +} [list ::myns::loc(1) ::myns::loc(2) ::myns::loc(5)] + + +test record-7.9 {delete an instance} { + record delete instance myns::loc(2) +} "" + +test record-8.0 {delete a nested instance} { + record delete instance myns::cont(2) +} "" + +test record-8.1 {delete a record} { + record delete record myns::location +} "" + +test record-8.2 {test existence of an instance that was deleted} { + record exists instance myns::loc(1) +} 0 + +test record-8.3 {show existence of an instance} { + record exists instance myns::cont(1) +} 1 + +test record-8.4 {show non-existent instance} { + record exists instance myns::junk +} 0 + +test record-8.5 {show existence of record} { + record exists record myns::contact +} 1 + + +# Auto instances and deletion. + +test record-9.0 {auto instance & deletion} { + set res {} + lappend res [contact #auto] + lappend res [contact #auto] + + record delete instance [lindex $res end] + + lappend res [contact #auto] + +} {::contact1 ::contact2 ::contact3} + +test record-10.0 {nesting records more than one level} { + set jmod aMacro + + record define fitParams { + amp + unmod + jcoup + t2star + } + + record define fitData { + delays + values + } + + record define fitInput { + {reps 30} + {sdev 0.1} + {seed 12345} + {record fitParams params} + {record fitData data} + } + + record define fitXYData { + silent + verbose + macro + confidence + {record fitInput input} + } + + set fitXYInputData [fitXYData #auto] + + $fitXYInputData.silent true + $fitXYInputData.verbose true + $fitXYInputData.macro $jmod + $fitXYInputData.confidence 0.9 + + set res [record show values $fitXYInputData] + + record delete instance $fitXYInputData + set res +} {-silent true -verbose true -macro aMacro -confidence 0.9 -input {-reps 30 -sdev 0.1 -seed 12345 -params {-amp {} -unmod {} -jcoup {} -t2star {}} -data {-delays {} -values {}}}} diff --git a/tcllib/modules/struct/sets.bench b/tcllib/modules/struct/sets.bench new file mode 100644 index 0000000..5ccc967 --- /dev/null +++ b/tcllib/modules/struct/sets.bench @@ -0,0 +1,428 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'struct::set' +# data structure to allow developers to monitor package performance. +# +# (c) 2007-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# We need at least version 8.4 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.4]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +set moddir [file dirname [file dirname [info script]]] +lappend auto_path $moddir + +package forget struct::set + +set self [file join [pwd] [file dirname [info script]]] +set mod [file dirname $self] +set index [file join [file dirname $self] tcllibc pkgIndex.tcl] + +if 1 { + if {[file exists $index]} { + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + package require tcllibc + } +} + +source [file join $self sets.tcl] + +# ### ### ### ######### ######### ######### ########################### +# Helper commands to build various types of sets. + +proc makeN {n {times 1}} { + set res {} + for {set i 0} {$i < $times} {incr i} { + for {set j 1} {$j <= $n} {incr j} { + lappend res $j + } + } + return $res +} + +# Select between configurations for quick overview vs full test + +#set xtime {1 2} +#set xlen {1 10 100} +set xtime {1 2 3} +set xlen {1 10 100 1000} +#set xtime {1 2 3 4} +#set xlen {1 10 100 1000 10000} + +foreach times $xtime { + foreach n $xlen { + set sx($times,$n) [makeN $n $times] + } +} + +# ### ### ### ######### ######### ######### ########################### +## Get all the possible implementations + +struct::set::SwitchTo {} +foreach e [struct::set::KnownImplementations] { + ::struct::set::LoadAccelerator $e +} + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +# empty +# size = cardinality +# contains +# union +# intersect +# difference +# symdiff +# intersect3 +# equal +# include, add +# exclude, subtract +# subsetof + +foreach setimpl [struct::set::Implementations] { + struct::set::SwitchTo $setimpl + + # ### ### ### ######### ######### ######### ########################### + ## empty + + bench -desc "set empty set($setimpl)" -body { + struct::set empty {} + } + + if {$setimpl eq "tcl"} { + # Not useable for a critcl implementation. + bench -desc "set empty, raw set($setimpl)" -body { + struct::set::S_empty {} + } + } + # ### ### ### ######### ######### ######### ########################### + ## cardinality + + foreach times $xtime { + foreach n $xlen { + bench -desc "set size x$times $n set($setimpl)" -body { + struct::set size $sx($times,$n) + } + } + } + + # ### ### ### ######### ######### ######### ########################### + ## contains + + foreach times $xtime { + foreach n $xlen { + bench -desc "set contains, not, x$times $n set($setimpl)" -body { + struct::set contains $sx($times,$n) 0 + } + bench -desc "set contains, early, x$times $n set($setimpl)" -body { + struct::set contains $sx($times,$n) 1 + } + bench -desc "set contains, last, x$times $n set($setimpl)" -body { + struct::set contains $sx($times,$n) $n + } + } + } + + # ### ### ### ######### ######### ######### ########################### + ## union + # cases: no intersection, partial intersection, equal sets, subsets + # and always a varying number of duplicates. + + + # ### ### ### ######### ######### ######### ########################### + ## intersect + + # ### ### ### ######### ######### ######### ########################### + ## difference + + # ### ### ### ######### ######### ######### ########################### + ## symdiff + + # ### ### ### ######### ######### ######### ########################### + ## intersect3 + + # ### ### ### ######### ######### ######### ########################### + ## equal + + foreach times $xtime { + foreach n $xlen { + bench -desc "set equal, yes, x$times $n set($setimpl)" -body { + struct::set equal $sx($times,$n) $sx($times,$n) + } + # sets have no intersection + bench -desc "set equal, no1, x$times $n set($setimpl)" -body { + struct::set equal $sx($times,$n) {a b c d e} + } + # second set is either true subset, or true superset + bench -desc "set equal, no2, x$times $n set($setimpl)" -body { + struct::set equal $sx($times,$n) {1 2 3 4} + } + } + } + + # ### ### ### ######### ######### ######### ########################### + ## include, add + + foreach times $xtime { + foreach n $xlen { + + # Adding/including known items should be fast, as nothing + # changes. It should even be fast in case of a shared + # object. Which we have in A btw. + + bench -desc "set include, known x$times $n set($setimpl)" -pre { + set A $sx($times,$n) + struct::set include A x + } -body { + struct::set include A x + } -post { + unset A + } + bench -desc "set add, known x$times $n set($setimpl)" -pre { + set A $sx($times,$n) + struct::set add A {a b c d e} + } -body { + struct::set add A {a b c d e} + } -post { + unset A + } + + # Now adding/including items not yet in the set is affected + # much more by the environment. I.e: Is the object shared ? + # And: Is the object already in set-type ? Four possibilities. + + # (a) S/U - shared/unshared + # (b) S/C - set/string (c for conversion required) + + # Notes on the results: + # + # I. <SC> - duplication&conversion - time goes up with set size + # II. <SS> - duplication - s.a + # III. <UC> - conversion - s.a, but with larger constant + # IV. <US> - near constant - likely linear in the size of the set added. + # + # The times for I-III ramp up rapidly enough to make Critcl + # slower than Tcl for a constant set containing somewhere between + # 100-1000 elements. This however is only of consequence to + # one-shot set operations. In case of multiple operations only + # the first one incurs the above costs, any operation coming + # after is fast, see IV. I.e.Tcl keeps on adding large times + # to the total, Critcl otoh goes flat. IOW Critcl may incur a + # high startup cost when starting with large constant sets, + # but amortizes this then over all future operations. + + # Note 2: Most of the other benchmarks do not measure + # conversion time, because the first untimed execution of a + # body forces not only bc compilation of the script, but also + # the input to set-type already (values held in the array + # 'sx'). + + # -- + + # I. shared string-type <SC> + + bench -desc "set include, missing <SC> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + set B $A + } -body { + struct::set include A x + } -ipost { + unset A B + } + bench -desc "set add, missing <SC> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + set B $A + } -body { + struct::set add A {a b c d e} + } -ipost { + unset A B + } + + # II. shared set-type <SS> + + bench -desc "set include, missing <SS> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + } -body { + struct::set include A x + } -ipost { + unset A + } + bench -desc "set add, missing <SS> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + } -body { + struct::set add A {a b c d e} + } -ipost { + unset A + } + + # III. unshared string-type <UC> + + bench -desc "set include, missing <UC> x$times $n set($setimpl)" -ipre { + # string range creates new unshared duplicate in A. + set A [string range $sx($times,$n) 1 end] + } -body { + struct::set include A x + } -ipost { + unset A + } + bench -desc "set add, missing <UC> x$times $n set($setimpl)" -ipre { + set A [string range $sx($times,$n) 1 end] + } -body { + struct::set add A {a b c d e} + } -ipost { + unset A + } + + # IV. unshared set-type <US> + + bench -desc "set include, missing <US> x$times $n set($setimpl)" -ipre { + # string range creates new unshared duplicate in A. + # Adding the empty set forces the value of A to set-type. + set A [string range $sx($times,$n) 1 end] + struct::set add A {} + } -body { + struct::set include A x + } -ipost { + unset A + } + bench -desc "set add, missing <US> x$times $n set($setimpl)" -ipre { + set A [string range $sx($times,$n) 1 end] + struct::set add A {} + } -body { + struct::set add A {a b c d e} + } -ipost { + unset A + } + } + } + + # ### ### ### ######### ######### ######### ########################### + ## exclude, subtract + + foreach times $xtime { + foreach n $xlen { + + # Subtracting/excluding unknown items should be fast, as + # nothing changes. It should even be fast in case of a shared + # object. Which we have in A btw. + + bench -desc "set exclude, missing x$times $n set($setimpl)" -pre { + set A $sx($times,$n) + } -body { + struct::set exclude A x + } -post { + unset A + } + bench -desc "set subtract, missing x$times $n set($setimpl)" -pre { + set A $sx($times,$n) + } -body { + struct::set subtract A {a b c d e} + } -post { + unset A + } + + # Now subtracting/excluding items in the set is affected + # much more by the environment. I.e: Is the object shared ? + # And: Is the object already in set-type ? Four possibilities. + + # See above for discussion. + # -- + + # I. shared string-type <SC> + + bench -desc "set exclude, known <SC> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + set B $A + } -body { + struct::set exclude A 1 + } -ipost { + unset A B + } + bench -desc "set subtract, known <SC> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + set B $A + } -body { + struct::set subtract A {1 2 3 4 5} + } -ipost { + unset A B + } + + # II. shared set-type <SS> + + bench -desc "set exclude, known <SS> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + } -body { + struct::set exclude A 1 + } -ipost { + unset A + } + bench -desc "set subtract, known <SS> x$times $n set($setimpl)" -ipre { + set A $sx($times,$n) + } -body { + struct::set subtract A {1 2 3 4 5} + } -ipost { + unset A + } + + # III. unshared string-type <UC> + + bench -desc "set exclude, known <UC> x$times $n set($setimpl)" -ipre { + # string range creates new unshared duplicate in A. + set A [string range $sx($times,$n) 1 end] + } -body { + struct::set exclude A 1 + } -ipost { + unset A + } + bench -desc "set subtract, known <UC> x$times $n set($setimpl)" -ipre { + set A [string range $sx($times,$n) 1 end] + } -body { + struct::set subtract A {1 2 3 4 5} + } -ipost { + unset A + } + + # IV. unshared set-type <US> + + bench -desc "set exclude, known <US> x$times $n set($setimpl)" -ipre { + # string range creates new unshared duplicate in A. + # Adding the empty set forces the value of A to set-type. + set A [string range $sx($times,$n) 1 end] + struct::set add A {} + } -body { + struct::set exclude A 1 + } -ipost { + unset A + } + bench -desc "set subtract, known <US> x$times $n set($setimpl)" -ipre { + set A [string range $sx($times,$n) 1 end] + struct::set add A {} + } -body { + struct::set subtract A {1 2 3 4 5} + } -ipost { + unset A + } + } + } + + # ### ### ### ######### ######### ######### ########################### + ## subsetof + +} + +# ### ### ### ######### ######### ######### ########################### +## Complete + +return + +# ### ### ### ######### ######### ######### ########################### +## Notes ... diff --git a/tcllib/modules/struct/sets.tcl b/tcllib/modules/struct/sets.tcl new file mode 100644 index 0000000..8831637 --- /dev/null +++ b/tcllib/modules/struct/sets.tcl @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.2 + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/tcllib/modules/struct/sets.test b/tcllib/modules/struct/sets.test new file mode 100644 index 0000000..3d64df9 --- /dev/null +++ b/tcllib/modules/struct/sets.test @@ -0,0 +1,121 @@ +# Tests for the 'set' module in the 'struct' library. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcllib +# procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2004-2008 by Andreas Kupries +# +# RCS: @(#) $Id: sets.test,v 1.18 2008/03/07 06:51:36 andreas_kupries Exp $ + +#---------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useAccel [useTcllibC] struct/sets.tcl struct::set + TestAccelInit struct::set +} + +# ------------------------------------------------------------------------- + +set sempty {} +set smultiples {a::foo b::foo c::foo a::foo d::foo f::foo a::foo f::foo c::foo h::foo j::foo} +set sa {a::foo b::foo c::foo d::foo} +set sb {e::foo f::foo g::foo h::foo} +set sc {c::foo d::foo e::foo f::foo} +set sd {a::foo b::foo c::foo d::foo e::foo f::foo} ; # a + c +set se {c::foo d::foo e::foo f::foo g::foo h::foo} ; # b + c +set sf {a::foo b::foo c::foo d::foo e::foo f::foo g::foo h::foo} ; # a + b +set sg {a::foo b::foo c::foo d::foo f::foo h::foo j::foo} +set sh {c::foo d::foo} +set si {a::foo b::foo} +set sj {e::foo f::foo} +set sk {a::foo b::foo e::foo f::foo} +set sl {b::foo c::foo d::foo} + +interp alias {} setop {} ::struct::set + +proc luniq {list} { + set x() {} ; unset x() + foreach l $list {set x($l) .} + return [lsort [array names x]] +} + +############################################################ +## Iterate over all loaded implementations, activate +## them in turn, and run the tests for the active +## implementation. + +TestAccelDo struct::set impl { + # The global variable 'impl' is part of the public + # API the testsuite (in set.testsuite) can expect + # from the environment. + + switch -exact -- $impl { + critcl { + if {[package vsatisfies [package present Tcl] 8.5]} { + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "setop $m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "setop $m" $loarg] + } + + proc Nothing {} { + return [tcltest::wrongNumArgs {setop} {cmd ?arg ...?} 0] + } + } else { + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "::struct::set $m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "::struct::set $m" $loarg] + } + + proc Nothing {} { + return [tcltest::wrongNumArgs {::struct::set} {cmd ?arg ...?} 0] + } + } + } + tcl { + if {[package vsatisfies [package present Tcl] 8.6]} { + # In 8.6 head Tcl again reports what the alias resolved to + proc Nothing {} { + return [tcltest::wrongNumArgs {::struct::set} {cmd args} 0] + } + } elseif {[package vsatisfies [package present Tcl] 8.5]} { + # In 8.5 head the alias itself is reported, not what it + # resolved to. + proc Nothing {} { + return [tcltest::wrongNumArgs setop {cmd args} 0] + } + } else { + proc Nothing {} { + return [tcltest::wrongNumArgs {::struct::set} {cmd args} 0] + } + } + + proc tmWrong {m loarg n} { + return [tcltest::wrongNumArgs "::struct::set::S_$m" $loarg $n] + } + + proc tmTooMany {m loarg} { + return [tcltest::tooManyArgs "::struct::set::S_$m" $loarg] + } + } + } + + source [localPath sets.testsuite] +} + +############################################################ +TestAccelExit struct::set +testsuiteCleanup diff --git a/tcllib/modules/struct/sets.testsuite b/tcllib/modules/struct/sets.testsuite new file mode 100644 index 0000000..29fd3ef --- /dev/null +++ b/tcllib/modules/struct/sets.testsuite @@ -0,0 +1,529 @@ +# Tests for the 'set' module in the 'struct' library. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcllib +# procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2004-2008 by Andreas Kupries +# +# RCS: @(#) $Id: sets.testsuite,v 1.6 2008/03/09 04:38:47 andreas_kupries Exp $ + +#---------------------------------------------------------------------- + +test set-${impl}-1.0 {nothing} { + catch {setop} msg + set msg +} [Nothing] + +test set-${impl}-1.1 {bogus} { + catch {setop foo} msg + set msg +} {bad option "foo": must be add, contains, difference, empty, equal, exclude, include, intersect, intersect3, size, subsetof, subtract, symdiff, or union} + + +test set-${impl}-2.0 {emptiness} { + catch {setop empty} msg + set msg +} [tmWrong empty {set} 0] + +test set-${impl}-2.1 {emptiness} { + catch {setop empty a b} msg + set msg +} [tmTooMany empty {set}] + +test set-${impl}-2.2 {emptiness} { + setop empty $sempty +} 1 + +test set-${impl}-2.3 {emptiness} { + setop empty $smultiples +} 0 + +test set-${impl}-2.4 {emptiness} { + setop empty $sa +} 0 + + +test set-${impl}-3.0 {size} { + catch {setop size} msg + set msg +} [tmWrong size {set} 0] + +test set-${impl}-3.1 {size} { + catch {setop size a b} msg + set msg +} [tmTooMany size {set}] + +test set-${impl}-3.2 {size} { + setop size $sempty +} 0 + +test set-${impl}-3.3 {size} { + setop size $smultiples +} 7 + +test set-${impl}-3.4 {size} { + setop size $sa +} 4 + + +test set-${impl}-4.0 {union} { + setop union +} {} + +test set-${impl}-4.1 {union} { + setop union $sempty +} $sempty + +test set-${impl}-4.2 {union} { + luniq [setop union $smultiples] +} [luniq $smultiples] + +test set-${impl}-4.3 {union} { + luniq [setop union $sa] +} $sa + +test set-${impl}-4.4 {union} { + lsort [setop union $sa $sb] +} $sf + +test set-${impl}-4.5 {union} { + lsort [setop union $sa $sc] +} $sd + +test set-${impl}-4.6 {union} { + lsort [setop union $sa $sd] +} $sd + +test set-${impl}-4.7 {union} { + lsort [setop union $sa $sempty] +} $sa + +test set-${impl}-4.8 {union} { + lsort [setop union $sempty $sa] +} $sa + +test set-${impl}-4.9 {union} { + lsort [setop union $sempty $sempty] +} $sempty + +test set-${impl}-4.10 {union} { + lsort [setop union $sa $sempty $smultiples] +} $sg + + +test set-${impl}-5.0 {intersect} { + setop intersect +} {} + +test set-${impl}-5.1 {intersect} { + setop intersect $sempty +} $sempty + +test set-${impl}-5.2 {intersect} { + luniq [setop intersect $smultiples] +} [luniq $smultiples] + +test set-${impl}-5.3 {intersect} { + luniq [setop intersect $sa] +} $sa + +test set-${impl}-5.4 {intersect} { + lsort [setop intersect $sa $sb] +} $sempty + +test set-${impl}-5.5 {intersect} { + lsort [setop intersect $sa $sc] +} $sh + +test set-${impl}-5.6 {intersect} { + lsort [setop intersect $sa $sd] +} $sa + +test set-${impl}-5.7 {intersect} { + lsort [setop intersect $sa $sempty] +} $sempty + +test set-${impl}-5.8 {intersect} { + lsort [setop intersect $sempty $sa] +} $sempty + +test set-${impl}-5.9 {intersect} { + lsort [setop intersect $sempty $sempty] +} $sempty + +test set-${impl}-5.10 {intersect} { + lsort [setop intersect $sa $sempty $smultiples] +} $sempty + +test set-${impl}-5.11 {intersect} { + lsort [setop intersect $sa $sa] +} $sa + +test set-${impl}-5.12 {intersect} { + lsort [setop intersect $sa $sc $sd] +} $sh + +test set-${impl}-5.13 {intersect} { + lsort [setop intersect $sa $sc {x y}] +} $sempty + + +test set-${impl}-6.0 {difference} { + catch {setop difference} msg + set msg +} [tmWrong difference {A B} 0] + +test set-${impl}-6.1 {difference} { + catch {setop difference a} msg + set msg +} [tmWrong difference {A B} 1] + +test set-${impl}-6.2 {difference} { + catch {setop difference a b c} msg + set msg +} [tmTooMany difference {A B}] + +test set-${impl}-6.3 {difference} { + luniq [setop difference $sa $sempty] +} $sa + +test set-${impl}-6.4 {difference} { + setop difference $sempty $sa +} $sempty + +test set-${impl}-6.5 {difference} { + lsort [setop difference $sa $sb] +} $sa + +test set-${impl}-6.6 {difference} { + lsort [setop difference $sa $sc] +} $si + +test set-${impl}-6.7 {difference} { + lsort [setop difference $sa $sd] +} $sempty + +test set-${impl}-6.8 {difference} { + lsort [setop difference $sd $sa] +} $sj + +test set-${impl}-6.9 {difference} { + lsort [setop difference \ + [list "Washington, DC (District of Columbia)" Maryland Virginia] \ + [list "Washington, DC (District of Columbia)" Virginia]] +} Maryland + +test set-${impl}-6.10 {difference} { + lsort [setop difference \ + [list DC Maryland Virginia] \ + [list DC Virginia]] +} Maryland + + +test set-${impl}-7.0 {symdiff} { + catch {setop symdiff} msg + set msg +} [tmWrong symdiff {A B} 0] + +test set-${impl}-7.1 {symdiff} { + catch {setop symdiff a} msg + set msg +} [tmWrong symdiff {A B} 1] + +test set-${impl}-7.2 {symdiff} { + catch {setop symdiff a b c} msg + set msg +} [tmTooMany symdiff {A B}] + +test set-${impl}-7.3 {symdiff} { + lsort [setop symdiff $sa $sempty] +} $sa + +test set-${impl}-7.4 {symdiff} { + lsort [setop symdiff $sempty $sa] +} $sa + +test set-${impl}-7.5 {symdiff} { + lsort [setop symdiff $sa $sb] +} $sf + +test set-${impl}-7.6 {symdiff} { + lsort [setop symdiff $sa $sc] +} $sk + +test set-${impl}-7.7 {symdiff} { + lsort [setop symdiff $sa $sd] +} $sj + +test set-${impl}-7.8 {symdiff} { + lsort [setop symdiff $sd $sa] +} $sj + + +test set-${impl}-8.0 {intersect3} { + catch {setop intersect3} msg + set msg +} [tmWrong intersect3 {A B} 0] + +test set-${impl}-8.1 {intersect3} { + catch {setop intersect3 a} msg + set msg +} [tmWrong intersect3 {A B} 1] + +test set-${impl}-8.2 {intersect3} { + catch {setop intersect3 a b c} msg + set msg +} [tmTooMany intersect3 {A B}] + +test set-${impl}-8.3 {intersect3} { + foreach {i da db} [setop intersect3 $sa $sempty] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sempty $sa $sempty] + +test set-${impl}-8.4 {intersect3} { + foreach {i da db} [setop intersect3 $sempty $sa] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sempty $sempty $sa] + +test set-${impl}-8.5 {intersect3} { + foreach {i da db} [setop intersect3 $sa $sb] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sempty $sa $sb] + +test set-${impl}-8.6 {intersect3} { + foreach {i da db} [setop intersect3 $sa $sc] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sh $si $sj] + +test set-${impl}-8.7 {intersect3} { + foreach {i da db} [setop intersect3 $sa $sd] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sa $sempty $sj] + +test set-${impl}-8.8 {intersect3} { + foreach {i da db} [setop intersect3 $sempty $sempty] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sempty $sempty $sempty] + +test set-${impl}-8.9 {intersect3} { + foreach {i da db} [setop intersect3 $sa $sa] break + list [lsort $i] [lsort $da] [lsort $db] +} [list $sa $sempty $sempty] + + +test set-${impl}-9.0 {equal} { + catch {setop equal} msg + set msg +} [tmWrong equal {A B} 0] + +test set-${impl}-9.1 {equal} { + catch {setop equal a} msg + set msg +} [tmWrong equal {A B} 1] + +test set-${impl}-9.2 {equal} { + catch {setop equal a b c} msg + set msg +} [tmTooMany equal {A B}] + +test set-${impl}-9.3 {equal} { + setop equal $sempty $sempty +} 1 + +test set-${impl}-9.4 {equal} { + setop equal $sempty $sa +} 0 + +test set-${impl}-9.5 {equal} { + setop equal $sa $sempty +} 0 + +test set-${impl}-9.6 {equal} { + setop equal $sa $sb +} 0 + +test set-${impl}-9.7 {equal} { + setop equal $sa $sa +} 1 + +test set-${impl}-9.8 {equal} { + setop equal $sa $sd +} 0 + +test set-${impl}-9.9 {equal} { + setop equal $smultiples $sg +} 1 + + +test set-${impl}-10.0 {include} { + catch {setop include} msg + set msg +} [tmWrong include {Avar element} 0] + +test set-${impl}-10.1 {include} { + catch {setop include A} msg + set msg +} [tmWrong include {Avar element} 1] + +test set-${impl}-10.2 {include, non-existing variable} { + catch {unset A} + setop include A B + set A +} {B} + +test set-${impl}-10.3 {include, missing} { + catch {unset A} ; set A $sa + setop include A B + lsort $A +} {B a::foo b::foo c::foo d::foo} + +test set-${impl}-10.4 {include, known} { + catch {unset A} ; set A $sa + setop include A a::foo + lsort $A +} $sa + +test set-${impl}-10.5-bug-1908098 {include, non-existent variable} { + catch {unset A} + catch {unset res} + lappend res [setop include A a::foo] + lappend res [lsort $A] +} {{} a::foo} + +test set-${impl}-11.0 {exclude} { + catch {setop exclude} msg + set msg +} [tmWrong exclude {Avar element} 0] + +test set-${impl}-11.1 {exclude} { + catch {setop exclude A} msg + set msg +} [tmWrong exclude {Avar element} 1] + +test set-${impl}-11.2 {exclude, non-existent variable} { + catch {unset X} + catch {setop exclude X B} msg + set msg +} {can't read "X": no such variable} + +test set-${impl}-11.3 {exclude} { + catch {unset A} ; set A $sa + setop exclude A B + lsort $A +} $sa + +test set-${impl}-11.4 {exclude} { + catch {unset A} ; set A $sa + setop exclude A a::foo + lsort $A +} $sl + + +test set-${impl}-12.0 {add} { + catch {setop add} msg + set msg +} [tmWrong add {Avar B} 0] + +test set-${impl}-12.1 {add} { + catch {setop add A} msg + set msg +} [tmWrong add {Avar B} 1] + +test set-${impl}-12.2 {add, non-existent variable} { + catch {unset A} + catch {unset res} + lappend res [setop add A B] + lappend res $A +} {{} B} + +test set-${impl}-12.3 {add, missing} { + catch {unset A} ; set A $sa + setop add A $sb + lsort $A +} $sf + +test set-${impl}-12.4 {add, missing&known} { + catch {unset A} ; set A $sa + setop add A $sc + lsort $A +} $sd + +test set-${impl}-12.5 {add, known} { + catch {unset A} ; set A $sa + setop add A $sa + lsort $A +} $sa + + +test set-${impl}-13.0 {subtract} { + catch {setop subtract} msg + set msg +} [tmWrong subtract {Avar B} 0] + +test set-${impl}-13.1 {subtract} { + catch {setop subtract A} msg + set msg +} [tmWrong subtract {Avar B} 1] + +test set-${impl}-13.2 {subtract, non-existent variable} { + catch {unset X} + catch {setop subtract X B} msg + set msg +} {can't read "X": no such variable} + +test set-${impl}-13.3 {subtract} { + catch {unset A} ; set A $sa + setop subtract A $sb + lsort $A +} $sa + +test set-${impl}-13.4 {subtract} { + catch {unset A} ; set A $sa + setop subtract A $sc + lsort $A +} $si + +test set-${impl}-13.5 {subtract} { + catch {unset A} ; set A $sa + setop subtract A $sa + lsort $A +} {} + + +test set-${impl}-14.0 {subsetof} { + catch {setop subsetof} msg + set msg +} [tmWrong subsetof {A B} 0] + +test set-${impl}-14.1 {subsetof} { + catch {setop subsetof A} msg + set msg +} [tmWrong subsetof {A B} 1] + +test set-${impl}-14.2 {subsetof} { + setop subsetof $sa $sb +} 0 + +test set-${impl}-14.3 {subsetof} { + setop subsetof $sa $sc +} 0 + +test set-${impl}-14.4 {subsetof} { + setop subsetof $sa $sa +} 1 + +test set-${impl}-14.5 {subsetof} { + setop subsetof $sa $sf +} 1 + +#---------------------------------------------------------------------- + +test set-${impl}-15.0 {shimmering, keep order} { + set pure [list a b c d e f] ; # pure value + setop difference {} $pure ; # shimmer to set + llength $pure ; # shimmer back to list + string range $pure 0 end ; # generate and query the string rep +} {a b c d e f} + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/sets/ds.h b/tcllib/modules/struct/sets/ds.h new file mode 100644 index 0000000..737dca1 --- /dev/null +++ b/tcllib/modules/struct/sets/ds.h @@ -0,0 +1,24 @@ +/* struct::set - critcl - layer 0 declarations + * Tcl_ObjType 'set'. + */ + +#ifndef _DS_H +#define _DS_H 1 + +#include "tcl.h" + +typedef struct S *SPtr; + +typedef struct S { + Tcl_HashTable el; +} S; + +#endif /* _DS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/sets/m.c b/tcllib/modules/struct/sets/m.c new file mode 100644 index 0000000..820435e --- /dev/null +++ b/tcllib/modules/struct/sets/m.c @@ -0,0 +1,772 @@ +/* struct::set - critcl - layer 3 definitions. + * + * -> Set functions. + * Implementations for all set commands. + */ + +#include "s.h" +#include "m.h" + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * sm_ADD -- + * + * Copies the argument tree over into this tree object. Uses direct + * access to internal data structures for matching tree objects, and + * goes through a serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set add SETVAR SET + * [0] [1] [2] [3] + */ + + SPtr vs, s; + Tcl_Obj* val; + int new = 0; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "Avar B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[3], &s) != TCL_OK) { + return TCL_ERROR; + } + + val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (val == NULL) { + /* Create missing variable */ + + vs = s_dup (NULL); + val = s_new (vs); + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + + } else if (s_get (interp, val, &vs) != TCL_OK) { + return TCL_ERROR; + } + + if (s->el.numEntries) { + int new, nx = 0; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + for(he = Tcl_FirstHashEntry(&s->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&s->el, he); + if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue; + /* Key not known to vs, to be added */ + + /* _Now_ unshare the object, if required */ + + if (Tcl_IsShared (val)) { + val = Tcl_DuplicateObj (val); + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + s_get (interp, val, &vs); + } + + (void*) Tcl_CreateHashEntry(&vs->el, key, &new); + nx = 1; + } + if (nx) { + Tcl_InvalidateStringRep(val); + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_CONTAINS -- + * + * Copies this tree over into the argument tree. Uses direct access to + * internal data structures for matching tree objects, and goes through a + * serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set contains SET ITEM + * [0] [1] [2] [3] + */ + + SPtr s; + CONST char* item; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "set item"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &s) != TCL_OK) { + return TCL_ERROR; + } + + item = Tcl_GetString (objv [3]); + + Tcl_SetObjResult (interp, + Tcl_NewIntObj (s_contains (s, item))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_DIFFERENCE -- + * + * Returns a list containing the ancestors of the named node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set difference SETa SETb + * [0] [1] [2] [3] + */ + + SPtr sa, sb; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "A B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, + s_new (s_difference (sa, sb))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_EMPTY -- + * + * Appends a value to an attribute of the named node. + * May create the attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set empty SET + * [0] [1] [2] + */ + + SPtr s; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "set"); + return TCL_ERROR; + } + + if (objv[2]->typePtr == s_ltype ()) { + int lc; + Tcl_Obj** lv; + Tcl_ListObjGetElements(interp, objv[2], &lc, &lv); + Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0)); + return TCL_OK; + } + + if (s_get (interp, objv[2], &s) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, + Tcl_NewIntObj (s_empty (s))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_EQUAL -- + * + * Returns a dictionary mapping from nodes to attribute values, for a + * named attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set equal SETa SETb + * [0] [1] [2] [3] + */ + + SPtr sa, sb; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "A B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, + Tcl_NewIntObj (s_equal (sa, sb))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_EXCLUDE -- + * + * Returns a list of all direct or indirect descendants of the named + * node, possibly run through a Tcl command prefix for filtering. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. Per the filter command prefix, if + * one has been specified. + * + *--------------------------------------------------------------------------- + */ + +int +sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set exclude SETVAR ITEM + * [0] [1] [2] [3] + */ + + SPtr vs; + Tcl_Obj* val; + char* key; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "Avar element"); + return TCL_ERROR; + } + + val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); + if (val == NULL) { + return TCL_ERROR; + } + if (s_get (interp, val, &vs) != TCL_OK) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv[3]); + if (s_contains (vs, key)) { + if (Tcl_IsShared (val)) { + val = Tcl_DuplicateObj (val); + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + s_get (interp, val, &vs); + } + + s_subtract1 (vs, key); + Tcl_InvalidateStringRep(val); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_INCLUDE -- + * + * Deletes the named nodes, but not its children. They are put into the + * place where the deleted node was. Complementary to sm_SPLICE. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set include SETVAR ITEM + * [0] [1] [2] [3] + */ + + SPtr vs; + Tcl_Obj* val; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "Avar element"); + return TCL_ERROR; + } + + val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (val == NULL) { + /* Create missing variable */ + + vs = s_dup (NULL); + s_add1 (vs, Tcl_GetString (objv[3])); + val = s_new (vs); + + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + } else { + /* Extend variable */ + char* key; + + if (s_get (interp, val, &vs) != TCL_OK) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv[3]); + if (!s_contains (vs, key)) { + if (Tcl_IsShared (val)) { + val = Tcl_DuplicateObj (val); + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + s_get (interp, val, &vs); + } + + s_add1 (vs, key); + Tcl_InvalidateStringRep(val); + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_INTERSECT -- + * + * Deletes the named node and its children. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set intersect ?SET...? + * [0] [1] [2] + */ + + SPtr sa, sb, next, acc; + int i; + + if (objc == 2) { + /* intersect nothing = nothing */ + Tcl_SetObjResult (interp, s_new (s_dup (NULL))); + return TCL_OK; + } + + for (i = 2; i < objc; i++) { + if (s_get (interp, objv[i], &sa) != TCL_OK) { + return TCL_ERROR; + } + } + + s_get (interp, objv[2], &sa); + + if (objc == 3) { + /* intersect with itself = unchanged */ + Tcl_SetObjResult (interp, s_new (s_dup (sa))); + return TCL_OK; + } + + acc = sa; + for (i = 3; i < objc; i++) { + s_get (interp, objv[i], &sb); + next = s_intersect (acc, sb); + if (acc != sa) s_free (acc); + acc = next; + if (s_empty (acc)) break; + } + + if (acc == sa) { + acc = s_dup (acc); + } + + Tcl_SetObjResult (interp, s_new (acc)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_INTERSECT3 -- + * + * Returns a non-negative integer number describing the distance between + * the named node and the root of the tree. A depth of 0 implies that + * the node is the root node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set intersect3 SETa SETb + * [0] [1] [2] [3] + */ + + SPtr sa, sb; + Tcl_Obj* lv [3]; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "A B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + lv [0] = s_new (s_intersect (sa, sb)); + lv [1] = s_new (s_difference (sa, sb)); + lv [2] = s_new (s_difference (sb, sa)); + + Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_SIZE -- + * + * Returns a list of all descendants of the named node, possibly run + * through a Tcl command prefix for filtering. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. Per the filter command prefix, if + * one has been specified. + * + *--------------------------------------------------------------------------- + */ + +int +sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set size SET + * [0] [1] [2] + */ + + SPtr s; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "set"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &s) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, + Tcl_NewIntObj (s_size (s))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_SUBSETOF -- + * + * Parses a Tcl value containing a serialized tree and copies it over + * he existing tree. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set subsetof SETa SETb + * [0] [1] [2] [3] + */ + + SPtr sa, sb; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "A B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, + Tcl_NewIntObj (s_subsetof (sa, sb))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_SUBTRACT -- + * + * Destroys the whole tree object. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Releases memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set subtract SETVAR SET + * [0] [1] [2] [3] + */ + + SPtr vs, s; + Tcl_Obj* val; + int del; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "Avar B"); + return TCL_ERROR; + } + + val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); + if (val == NULL) { + return TCL_ERROR; + } + if (s_get (interp, val, &vs) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &s) != TCL_OK) { + return TCL_ERROR; + } + + if (s->el.numEntries) { + int new, dx = 0; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + for(he = Tcl_FirstHashEntry(&s->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&s->el, he); + if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue; + /* Key known to vs, to be removed */ + + /* _Now_ unshare the object, if required */ + + if (Tcl_IsShared (val)) { + val = Tcl_DuplicateObj (val); + (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); + s_get (interp, val, &vs); + } + + Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key)); + dx = 1; + } + if (dx) { + Tcl_InvalidateStringRep(val); + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_SYMDIFF -- + * + * Returns a boolean value signaling whether the named node exists in + * the tree. True implies existence, and false non-existence. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set symdiff SETa SETb + * [0] [1] [2] [3] + */ + + SPtr sa, sb, xa, xb, u; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "A B"); + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + if (s_get (interp, objv[2], &sa) != TCL_OK) { + return TCL_ERROR; + } + if (s_get (interp, objv[3], &sb) != TCL_OK) { + return TCL_ERROR; + } + + xa = s_difference (sa, sb); + xb = s_difference (sb, sa); + u = s_union (xa, xb); + + s_free (xa); + s_free (xb); + + Tcl_SetObjResult (interp, s_new (u)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * sm_UNION -- + * + * Returns the value of the named attribute at the given node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: set union ?SET...? + * [0] [1] [2] + */ + + SPtr sa, acc; + int i; + + if (objc == 2) { + /* union nothing = nothing */ + Tcl_SetObjResult (interp, s_new (s_dup (NULL))); + return TCL_OK; + } + + for (i = 2; i < objc; i++) { + if (s_get (interp, objv[i], &sa) != TCL_OK) { + return TCL_ERROR; + } + } + + acc = s_dup (NULL); + + for (i = 2; i < objc; i++) { + s_get (interp, objv[i], &sa); + s_add (acc, sa, NULL); + } + + Tcl_SetObjResult (interp, s_new (acc)); + return TCL_OK; +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/sets/m.h b/tcllib/modules/struct/sets/m.h new file mode 100644 index 0000000..2460518 --- /dev/null +++ b/tcllib/modules/struct/sets/m.h @@ -0,0 +1,33 @@ +/* struct::set - critcl - layer 3 declarations + * Set commands. + */ + +#ifndef _M_H +#define _M_H 1 + +#include "tcl.h" + +int sm_ADD (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_CONTAINS (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_DIFFERENCE (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_EMPTY (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_EQUAL (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_EXCLUDE (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_INCLUDE (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_INTERSECT (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_INTERSECT3 (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_SIZE (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_SUBSETOF (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_SUBTRACT (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_SYMDIFF (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int sm_UNION (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _M_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/sets/s.c b/tcllib/modules/struct/sets/s.c new file mode 100644 index 0000000..92d2650 --- /dev/null +++ b/tcllib/modules/struct/sets/s.c @@ -0,0 +1,458 @@ +/* struct::set - critcl - layer 0 declarations + * Tcl_ObjType 'set'. + */ + +#include <string.h> +#include "s.h" + +/* .................................................. */ + +static void free_rep (Tcl_Obj* obj); +static void dup_rep (Tcl_Obj* obj, Tcl_Obj* dup); +static void string_rep (Tcl_Obj* obj); +static int from_any (Tcl_Interp* ip, Tcl_Obj* obj); + +static +Tcl_ObjType s_type = { + "tcllib::struct::set/critcl::set", + free_rep, + dup_rep, + string_rep, + from_any +}; + +/* .................................................. */ + +int +s_get (Tcl_Interp* interp, Tcl_Obj* o, SPtr* sStar) +{ + if (o->typePtr != &s_type) { + int res = from_any (interp, o); + if (res != TCL_OK) { + return res; + } + } + + *sStar = (SPtr) o->internalRep.otherValuePtr; + return TCL_OK; +} + +Tcl_Obj* +s_new (SPtr s) +{ + Tcl_Obj* o = Tcl_NewObj(); + Tcl_InvalidateStringRep(o); + + o->internalRep.otherValuePtr = s; + o->typePtr = &s_type; + return o; +} + +Tcl_ObjType* +s_stype (void) +{ + return &s_type; +} + +Tcl_ObjType* +s_ltype (void) +{ + static Tcl_ObjType* l; + if (l == NULL) { + l = Tcl_GetObjType ("list"); + } + return l; +} + +/* .................................................. */ + +static void +free_rep (Tcl_Obj* o) +{ + s_free ((SPtr) o->internalRep.otherValuePtr); + o->internalRep.otherValuePtr = NULL; +} + +static void +dup_rep (Tcl_Obj* obj, Tcl_Obj* dup) +{ + SPtr s = s_dup ((SPtr) obj->internalRep.otherValuePtr); + + dup->internalRep.otherValuePtr = s; + dup->typePtr = &s_type; +} + +static void +string_rep (Tcl_Obj* obj) +{ + SPtr s = (SPtr) obj->internalRep.otherValuePtr; + int numElems = s->el.numEntries; + + /* iterate hash table and generate list-like string rep */ + +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int localLen [LOCAL_SIZE], *lenPtr; + register int i; + char *elem, *dst; + int length; + + Tcl_HashSearch hs; + Tcl_HashEntry* he; + + /* + * Convert each key of the hash to string form and then convert it to + * proper list element form, adding it to the result buffer. */ + + /* + * Pass 1: estimate space, gather flags. + */ + + if (numElems <= LOCAL_SIZE) { + flagPtr = localFlags; + lenPtr = localLen; + } else { + flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + lenPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + } + obj->length = 1; + + for(i = 0, he = Tcl_FirstHashEntry(&s->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs), i++) { + + elem = Tcl_GetHashKey (&s->el, he); + lenPtr [i] = strlen (elem); + + obj->length += Tcl_ScanCountedElement(elem, lenPtr[i], + &flagPtr[i]) + 1; + } + + /* + * Pass 2: copy into string rep buffer. + */ + + obj->bytes = ckalloc((unsigned) obj->length); + dst = obj->bytes; + + for(i = 0, he = Tcl_FirstHashEntry(&s->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs), i++) { + + elem = Tcl_GetHashKey (&s->el, he); + + dst += Tcl_ConvertCountedElement(elem, lenPtr[i], + dst, flagPtr[i]); + *dst = ' '; + dst++; + } + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + ckfree((char *) lenPtr); + } + if (dst == obj->bytes) { + *dst = 0; + } else { + dst--; + *dst = 0; + } + obj->length = dst - obj->bytes; +} + +static int +from_any (Tcl_Interp* ip, Tcl_Obj* obj) +{ + /* Go through an intermediate list rep. + */ + + int lc, i, new; + Tcl_Obj** lv; + Tcl_ObjType* oldTypePtr; + SPtr s; + + if (Tcl_ListObjGetElements (ip, obj, &lc, &lv) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Remember the old type after the conversion to list, or we will try to + * free a list intrep using the free-proc of whatever type the word had + * before. For example 'parsedvarname'. That would be bad. Segfault like + * bad. + */ + + oldTypePtr = obj->typePtr; + + /* Now, if the value was pure we forcibly generate the string-rep, to + * capture the existing semantics of the value. Because we now enter the + * realm of unordered, and the actual value may not be. If so, then not + * having the string-rep will later cause the generation of an arbitrarily + * ordered string-rep when the value is shimmered to some other type. This + * is most visible for lists, which are ordered. A shimmer list->set->list + * may reorder the elements if we do not capture their order in the + * string-rep. + * + * See test case -15.0 in sets.testsuite demonstrating this. + * Disable the Tcl_GetString below and see the test fail. + */ + + Tcl_GetString (obj); + + /* Gen hash table from list */ + + s = (SPtr) ckalloc (sizeof (S)); + Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); + + for (i=0; i < lc; i++) { + (void) Tcl_CreateHashEntry(&s->el, + Tcl_GetString (lv[i]), &new); + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * Tcl_ListObjGetElements, to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(obj); + } + + obj->internalRep.otherValuePtr = s; + obj->typePtr = &s_type; + return TCL_OK; +} + +/* .................................................. */ + +int +s_size (SPtr a) +{ + return a->el.numEntries; +} + +int +s_empty (SPtr a) +{ + return (a->el.numEntries == 0); +} + +void +s_free (SPtr a) +{ + Tcl_DeleteHashTable(&a->el); + ckfree ((char*) a); +} + +SPtr +s_dup (SPtr a) +{ + SPtr s = (SPtr) ckalloc (sizeof (S)); + Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); + + if (!a) return s; + s_add (s, a, NULL); + return s; +} + +int +s_contains (SPtr a, const char* item) +{ + return Tcl_FindHashEntry (&a->el, item) != NULL; +} + +SPtr +s_difference (SPtr a, SPtr b) +{ + int new; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + SPtr s; + + /* a - nothing = a. Just duplicate */ + + if (!b->el.numEntries) { + return s_dup (a); + } + + s = (SPtr) ckalloc (sizeof (S)); + Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); + + /* nothing - b = nothing */ + + if (!a->el.numEntries) return s; + + /* Have to get it the hard way, no shortcut */ + + for(he = Tcl_FirstHashEntry(&a->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&a->el, he); + + if (Tcl_FindHashEntry (&b->el, key) != NULL) continue; + /* key is in a, not in b <=> in (a-b) */ + + (void*) Tcl_CreateHashEntry(&s->el, key, &new); + } + + return s; +} + +SPtr +s_intersect (SPtr a, SPtr b) +{ + int new; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + SPtr s = (SPtr) ckalloc (sizeof (S)); + Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); + + /* Shortcut when we know that the result is empty */ + + if (!a->el.numEntries) return s; + if (!b->el.numEntries) return s; + + /* Ensure that we iterate over the smaller of the two sets */ + + if (b->el.numEntries < a->el.numEntries) { + SPtr t = a ; a = b ; b = t; + } + + for(he = Tcl_FirstHashEntry(&a->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&a->el, he); + + if (Tcl_FindHashEntry (&b->el, key) == NULL) continue; + /* key is in a, in b <=> in (a*b) */ + + (void*) Tcl_CreateHashEntry(&s->el, key, &new); + } + + return s; +} + +SPtr +s_union (SPtr a, SPtr b) +{ + int new; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + SPtr s = (SPtr) ckalloc (sizeof (S)); + Tcl_InitHashTable(&s->el, TCL_STRING_KEYS); + + s_add (s, a, NULL); + s_add (s, b, NULL); + + return s; +} + +void +s_add (SPtr a, SPtr b, int* newPtr) +{ + int new, nx = 0; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + if (b->el.numEntries) { + for(he = Tcl_FirstHashEntry(&b->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&b->el, he); + (void*) Tcl_CreateHashEntry(&a->el, key, &new); + if (new) {nx = 1;} + } + } + if(newPtr) {*newPtr = nx;} +} + +void +s_add1 (SPtr a, const char* item) +{ + int new; + + (void*) Tcl_CreateHashEntry(&a->el, item, &new); +} + +void +s_subtract (SPtr a, SPtr b, int* delPtr) +{ + int new; + Tcl_HashSearch hs; + Tcl_HashEntry* he, *dhe; + CONST char* key; + int dx = 0; + + if (b->el.numEntries) { + for(he = Tcl_FirstHashEntry(&b->el, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + key = Tcl_GetHashKey (&b->el, he); + dhe = Tcl_FindHashEntry(&a->el, key); + if (!dhe) continue; + /* Key is known, to be removed */ + dx = 1; + Tcl_DeleteHashEntry (dhe); + } + } + if(delPtr) {*delPtr = dx;} +} + +void +s_subtract1 (SPtr a, const char* item) +{ + Tcl_HashEntry* he; + + he = Tcl_FindHashEntry(&a->el, item); + if (!he) return; + Tcl_DeleteHashEntry (he); +} + +int +s_equal (SPtr a, SPtr b) +{ + /* (a == b) <=> (|a| == |b| && (a-b) = {}) + */ + + int res = 0; + + if (s_size (a) == s_size(b)) { + SPtr t = s_difference (a, b); + res = s_empty (t); + s_free (t); + } + return res; +} + +int +s_subsetof (SPtr a, SPtr b) +{ + /* (a <= b) <=> (|a| <= |b| && (a-b) = {}) + */ + + int res = 0; + + if (s_size (a) <= s_size(b)) { + SPtr t = s_difference (a, b); + res = s_empty (t); + s_free (t); + } + return res; +} + +/* .................................................. */ + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/sets/s.h b/tcllib/modules/struct/sets/s.h new file mode 100644 index 0000000..41eb1b2 --- /dev/null +++ b/tcllib/modules/struct/sets/s.h @@ -0,0 +1,40 @@ +/* struct::set - critcl - layer 0 declarations + * Tcl_ObjType 'set'. + */ + +#ifndef _S_H +#define _S_H 1 + +#include "tcl.h" +#include "ds.h" + +int s_get (Tcl_Interp* interp, Tcl_Obj* o, SPtr* sStar); +Tcl_Obj* s_new (SPtr s); + +Tcl_ObjType* s_stype (void); +Tcl_ObjType* s_ltype (void); + +void s_add (SPtr a, SPtr b, int* newPtr); +void s_add1 (SPtr a, const char* item); +int s_contains (SPtr a, const char* item); +SPtr s_difference (SPtr a, SPtr b); +SPtr s_dup (SPtr a); /* a == NULL allowed */ +int s_empty (SPtr a); +int s_equal (SPtr a, SPtr b); +void s_free (SPtr a); +SPtr s_intersect (SPtr a, SPtr b); +int s_size (SPtr a); +int s_subsetof (SPtr a, SPtr b); +void s_subtract (SPtr a, SPtr b, int* delPtr); +void s_subtract1 (SPtr a, const char* item); +SPtr s_union (SPtr a, SPtr b); + +#endif /* _S_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/sets_c.tcl b/tcllib/modules/struct/sets_c.tcl new file mode 100644 index 0000000..cd07f92 --- /dev/null +++ b/tcllib/modules/struct/sets_c.tcl @@ -0,0 +1,93 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. C implementation. +# +# Copyright (c) 2007 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require critcl +# @sak notprovided struct_setc +package provide struct_setc 2.1.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders sets/*.h + critcl::csources sets/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include <m.h> + } + + # Main command, set creation. + + critcl::ccommand set_critcl {dummy interp objc objv} { + /* Syntax - dispatcher to the sub commands. + */ + + static CONST char* methods [] = { + "add", "contains", "difference", "empty", + "equal","exclude", "include", "intersect", + "intersect3", "size", "subsetof", "subtract", + "symdiff", "union", + NULL + }; + enum methods { + S_add, S_contains, S_difference, S_empty, + S_equal,S_exclude, S_include, S_intersect, + S_intersect3, S_size, S_subsetof, S_subtract, + S_symdiff, S_union + }; + + int m; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case S_add: return sm_ADD (NULL, interp, objc, objv); + case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); + case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); + case S_empty: return sm_EMPTY (NULL, interp, objc, objv); + case S_equal: return sm_EQUAL (NULL, interp, objc, objv); + case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); + case S_include: return sm_INCLUDE (NULL, interp, objc, objv); + case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); + case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); + case S_size: return sm_SIZE (NULL, interp, objc, objv); + case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); + case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); + case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); + case S_union: return sm_UNION (NULL, interp, objc, objv); + } + /* Not coming to this place */ + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/tcllib/modules/struct/sets_tcl.tcl b/tcllib/modules/struct/sets_tcl.tcl new file mode 100644 index 0000000..a2e1fde --- /dev/null +++ b/tcllib/modules/struct/sets_tcl.tcl @@ -0,0 +1,452 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.0 + +namespace eval ::struct::set { + # Only export one command, the one used to instantiate a new tree + namespace export set_tcl +} + +########################## +# Public functions + +# ::struct::set::set -- +# +# Command that access all set commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::set::set_tcl {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + ::set sub S_$cmd + if { [llength [info commands ::struct::set::$sub]] == 0 } { + ::set optlist [info commands ::struct::set::S_*] + ::set xlist {} + foreach p $optlist { + lappend xlist [string range $p 17 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] +} + +########################## +# Implementations of the functionality. +# + +# ::struct::set::S_empty -- +# +# Determines emptiness of the set +# +# Parameters: +# set -- The set to check for emptiness. +# +# Results: +# A boolean value. True indicates that the set is empty. +# +# Side effects: +# None. +# +# Notes: + +proc ::struct::set::S_empty {set} { + return [expr {[llength $set] == 0}] +} + +# ::struct::set::S_size -- +# +# Computes the cardinality of the set. +# +# Parameters: +# set -- The set to inspect. +# +# Results: +# An integer greater than or equal to zero. +# +# Side effects: +# None. + +proc ::struct::set::S_size {set} { + return [llength [Cleanup $set]] +} + +# ::struct::set::S_contains -- +# +# Determines if the item is in the set. +# +# Parameters: +# set -- The set to inspect. +# item -- The element to look for. +# +# Results: +# A boolean value. True indicates that the element is present. +# +# Side effects: +# None. + +proc ::struct::set::S_contains {set item} { + return [expr {[lsearch -exact $set $item] >= 0}] +} + +# ::struct::set::S_union -- +# +# Computes the union of the arguments. +# +# Parameters: +# args -- List of sets to unify. +# +# Results: +# The union of the arguments. +# +# Side effects: +# None. + +proc ::struct::set::S_union {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + foreach setX $args { + foreach x $setX {::set ($x) {}} + } + return [array names {}] +} + + +# ::struct::set::S_intersect -- +# +# Computes the intersection of the arguments. +# +# Parameters: +# args -- List of sets to intersect. +# +# Results: +# The intersection of the arguments +# +# Side effects: +# None. + +proc ::struct::set::S_intersect {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + ::set res [lindex $args 0] + foreach set [lrange $args 1 end] { + if {[llength $res] && [llength $set]} { + ::set res [Intersect $res $set] + } else { + # Squash 'res'. Otherwise we get the wrong result if res + # is not empty, but 'set' is. + ::set res {} + break + } + } + return $res +} + +proc ::struct::set::Intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + + # This is slower than local vars, but more robust + if {[llength $B] > [llength $A]} { + ::set res $A + ::set A $B + ::set B $res + } + ::set res {} + foreach x $A {::set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res +} + +# ::struct::set::S_difference -- +# +# Compute difference of two sets. +# +# Parameters: +# A, B -- Sets to compute the difference for. +# +# Results: +# A - B +# +# Side effects: +# None. + +proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] +} + +if {0} { + # Tcllib SF Bug 1002143. We cannot use the implementation below. + # It will treat set elements containing '(' and ')' as array + # elements, and this screws up the storage of elements as the name + # of local vars something fierce. No way around this. Disabling + # this code and always using the other implementation (s.a.) is + # the only possible fix. + + if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Tcl 8.[23]. Use explicit array to perform the operation. + } else { + # Tcl 8.4+, has 'unset -nocomplain' + + proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + # Get the variable B out of the way, avoid collisions + # prepare for "pure list optimization" + ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] + unset B + + # unset A early: no local variables left + foreach [lindex [list $A [unset A]] 0] {.} {break} + + eval $::struct::set::tmp + return [info locals] + } + } +} + +# ::struct::set::S_symdiff -- +# +# Compute symmetric difference of two sets. +# +# Parameters: +# A, B -- The sets to compute the s.difference for. +# +# Results: +# The symmetric difference of the two input sets. +# +# Side effects: +# None. + +proc ::struct::set::S_symdiff {A B} { + # symdiff == (A-B) + (B-A) == (A+B)-(A*B) + if {[llength $A] == 0} {return $B} + if {[llength $B] == 0} {return $A} + return [S_union \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_intersect3 -- +# +# Return intersection and differences for two sets. +# +# Parameters: +# A, B -- The sets to inspect. +# +# Results: +# List containing A*B, A-B, and B-A +# +# Side effects: +# None. + +proc ::struct::set::S_intersect3 {A B} { + return [list \ + [S_intersect $A $B] \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_equal -- +# +# Compares two sets for equality. +# +# Parameters: +# a First set to compare. +# b Second set to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None. + +proc ::struct::set::S_equal {A B} { + ::set A [Cleanup $A] + ::set B [Cleanup $B] + + # Equal if of same cardinality and difference is empty. + + if {[::llength $A] != [::llength $B]} {return 0} + return [expr {[llength [S_difference $A $B]] == 0}] +} + + +proc ::struct::set::Cleanup {A} { + # unset A to avoid collisions + if {[llength $A] < 2} {return $A} + # We cannot use variables to avoid an explicit array. The set + # elements may look like namespace vars (i.e. contain ::), and + # such elements break that, cannot be proc-local variables. + array set S {} + foreach item $A {set S($item) .} + return [array names S] +} + +# ::struct::set::S_include -- +# +# Add an element to a set. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# element -- The item to add to the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by the element (if the element was not already present). + +proc ::struct::set::S_include {Avar element} { + # Avar = Avar + {element} + upvar 1 $Avar A + if {![info exists A] || ![S_contains $A $element]} { + lappend A $element + } + return +} + +# ::struct::set::S_exclude -- +# +# Remove an element from a set. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# element -- The item to remove from the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# the element remove (if the element was actually present). + +proc ::struct::set::S_exclude {Avar element} { + # Avar = Avar - {element} + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + while {[::set pos [lsearch -exact $A $element]] >= 0} { + ::set A [lreplace [K $A [::set A {}]] $pos $pos] + } + return +} + +# ::struct::set::S_add -- +# +# Add a set to a set. Similar to 'union', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# B -- The set to add to the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by all the elements in B. + +proc ::struct::set::S_add {Avar B} { + # Avar = Avar + B + upvar 1 $Avar A + if {![info exists A]} {set A {}} + ::set A [S_union [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subtract -- +# +# Remove a set from a set. Similar to 'difference', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# B -- The set to remove from the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# all elements of B are removed. + +proc ::struct::set::S_subtract {Avar B} { + # Avar = Avar - B + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + ::set A [S_difference [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subsetof -- +# +# A predicate checking if the first set is a subset +# or equal to the second set. +# +# Parameters: +# A -- The possible subset. +# B -- The set to compare to. +# +# Results: +# A boolean value, true if A is subset of or equal to B +# +# Side effects: +# None. + +proc ::struct::set::S_subsetof {A B} { + # A subset|== B <=> (A == A*B) + return [S_equal $A [S_intersect $A $B]] +} + +# ::struct::set::K -- +# Performance helper command. + +proc ::struct::set::K {x y} {::set x} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'set::set' into the general structure namespace + # for pickup by the main management. + + namespace import -force set::set_tcl +} diff --git a/tcllib/modules/struct/skiplist.man b/tcllib/modules/struct/skiplist.man new file mode 100644 index 0000000..6c55cb8 --- /dev/null +++ b/tcllib/modules/struct/skiplist.man @@ -0,0 +1,86 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::skiplist n 1.3] +[keywords skiplist] +[copyright {2000 Keith Vetter}] +[comment { + This software is licensed under a BSD license as described in tcl/tk + license.txt file but with the copyright held by Keith Vetter. +}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate skiplists}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::skiplist [opt 1.3]] +[description] +[para] + +The [cmd ::struct::skiplist] command creates a new skiplist object +with an associated global Tcl command whose name is +[arg skiplistName]. This command may be used to invoke various +operations on the skiplist. It has the following general form: + +[list_begin definitions] +[call [cmd skiplistName] [arg option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] + +[para] + +Skip lists are an alternative data structure to binary trees. They can +be used to maintain ordered lists over any sequence of insertions and +deletions. Skip lists use randomness to achieve probabilistic +balancing, and as a result the algorithms for insertion and deletion +in skip lists are much simpler and faster than those for binary trees. + +[para] + +To read more about skip lists see Pugh, William. +[emph {Skip lists: a probabilistic alternative to balanced trees}] +In: Communications of the ACM, June 1990, 33(6) 668-676. + +[para] + +Currently, the key can be either a number or a string, and comparisons +are performed with the built in greater than operator. + +The following commands are possible for skiplist objects: + +[list_begin definitions] +[call [arg skiplistName] [method delete] [arg node] [opt [arg node]...]] + +Remove the specified nodes from the skiplist. + +[call [arg skiplistName] [method destroy]] + +Destroy the skiplist, including its storage space and associated command. + +[call [arg skiplistName] [method insert] [arg {key value}]] + +Insert a node with the given [arg key] and [arg value] into the +skiplist. If a node with that key already exists, then the that node's +value is updated and its node level is returned. Otherwise a new node +is created and 0 is returned. + +[call [arg skiplistName] [method search] [arg node] [opt "[const -key] [arg key]"]] + +Search for a given key in a skiplist. If not found then 0 is returned. +If found, then a two element list of 1 followed by the node's value is retuned. + +[call [arg skiplistName] [method size]] + +Return a count of the number of nodes in the skiplist. + +[call [arg skiplistName] [method walk] [arg cmd]] + +Walk the skiplist from the first node to the last. At each node, the +command [arg cmd] will be evaluated with the key and value of the +current node appended. + +[list_end] + +[vset CATEGORY {struct :: skiplist}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/skiplist.tcl b/tcllib/modules/struct/skiplist.tcl new file mode 100644 index 0000000..579f0ef --- /dev/null +++ b/tcllib/modules/struct/skiplist.tcl @@ -0,0 +1,437 @@ +# skiplist.tcl -- +# +# Implementation of a skiplist data structure for Tcl. +# +# To quote the inventor of skip lists, William Pugh: +# Skip lists are a probabilistic data structure that seem likely +# to supplant balanced trees as the implementation method of +# choice for many applications. Skip list algorithms have the +# same asymptotic expected time bounds as balanced trees and are +# simpler, faster and use less space. +# +# For more details on how skip lists work, see Pugh, William. Skip +# lists: a probabilistic alternative to balanced trees in +# Communications of the ACM, June 1990, 33(6) 668-676. Also, see +# ftp://ftp.cs.umd.edu/pub/skipLists/ +# +# Copyright (c) 2000 by Keith Vetter +# This software is licensed under a BSD license as described in tcl/tk +# license.txt file but with the copyright held by Keith Vetter. +# +# TODO: +# customize key comparison to a user supplied routine + +namespace eval ::struct {} + +namespace eval ::struct::skiplist { + # Data storage in the skiplist module + # ------------------------------- + # + # For each skiplist, we have the following arrays + # state - holds the current level plus some magic constants + # nodes - all the nodes in the skiplist, including a dummy header node + + # counter is used to give a unique name for unnamed skiplists + variable counter 0 + + # Internal constants + variable MAXLEVEL 16 + variable PROB .5 + variable MAXINT [expr {0x7FFFFFFF}] + + # commands is the list of subcommands recognized by the skiplist + variable commands [list \ + "destroy" \ + "delete" \ + "insert" \ + "search" \ + "size" \ + "walk" \ + ] + + # State variables that can be set in the instantiation + variable vars [list maxlevel probability] + + # Only export one command, the one used to instantiate a new skiplist + namespace export skiplist +} + +# ::struct::skiplist::skiplist -- +# +# Create a new skiplist with a given name; if no name is given, use +# skiplistX, where X is a number. +# +# Arguments: +# name name of the skiplist; if null, generate one. +# +# Results: +# name name of the skiplist created + +proc ::struct::skiplist::skiplist {{name ""} args} { + set usage "skiplist name ?-maxlevel ##? ?-probability ##?" + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "skiplist${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create skiplist" + } + + # Handle the optional arguments + set more_eval "" + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + set value [lindex $args $i] + switch -glob -- $flag { + "-maxl*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0} { + error "value for the maxlevel option must be greater than 0" + } + append more_eval "; set state(maxlevel) $value" + } + "-prob*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0 || $value >= 1} { + error "probability must be between 0 and 1" + } + append more_eval "; set state(prob) $value" + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Set up the namespace for this skiplist + namespace eval ::struct::skiplist::skiplist$name { + variable state + variable nodes + + # NB. maxlevel and prob may be overridden by $more_eval at the end + set state(maxlevel) $::struct::skiplist::MAXLEVEL + set state(prob) $::struct::skiplist::PROB + set state(level) 1 + set state(cnt) 0 + set state(size) 0 + + set nodes(nil,key) $::struct::skiplist::MAXINT + set nodes(header,key) "---" + set nodes(header,value) "---" + + for {set i 1} {$i < $state(maxlevel)} {incr i} { + set nodes(header,$i) nil + } + } $more_eval + + # Create the command to manipulate the skiplist + interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name + + return $name +} + +########################### +# Private functions follow + +# ::struct::skiplist::SkiplistProc -- +# +# Command that processes all skiplist object commands. +# +# Arguments: +# name name of the skiplist object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::skiplist::SkiplistProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::skiplist::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [linsert $args 0 ::struct::skiplist::_$cmd $name] +} + +## ::struct::skiplist::_destroy -- +# +# Destroy a skiplist, including its associated command and data storage. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# None. + +proc ::struct::skiplist::_destroy {name} { + namespace delete ::struct::skiplist::skiplist$name + interp alias {} ::$name {} +} + +# ::struct::skiplist::_search -- +# +# Searches for a key in a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to search for +# +# Results: +# 0 if not found +# [list 1 node_value] if found + +proc ::struct::skiplist::_search {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + } + set x $nodes($x,1) + if {$nodes($x,key) == $key} { + return [list 1 $nodes($x,value)] + } + return 0 +} + +# ::struct::skiplist::_insert -- +# +# Add a node to a skiplist. +# +# Arguments: +# name name of the skiplist. +# key key for the node to insert +# value value of the node to insert +# +# Results: +# 0 if new node was created +# level if existing node was updated + +proc ::struct::skiplist::_insert {name key value} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Does the node already exist? + if {$nodes($x,key) == $key} { + set nodes($x,value) $value + return 0 + } + + # Here to insert item + incr state(size) + set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)] + + # Did the skip list level increase??? + if {$lvl > $state(level)} { + for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} { + set update($i) header + } + set state(level) $lvl + } + + # Create a unique new node name and fill in the key, value parts + set x [incr state(cnt)] + set nodes($x,key) $key + set nodes($x,value) $value + + for {set i 1} {$i <= $lvl} {incr i} { + set nodes($x,$i) $nodes($update($i),$i) + set nodes($update($i),$i) $x + } + + return $lvl +} + +# ::struct::skiplist::_delete -- +# +# Deletes a node from a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to delete +# +# Results: +# 1 if we deleted a node +# 0 otherwise + +proc ::struct::skiplist::_delete {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Did we find a node to delete? + if {$nodes($x,key) != $key} { + return 0 + } + + # Here when we found a node to delete + incr state(size) -1 + + # Unlink this node from all the linked lists that include to it + for {set i 1} {$i <= $state(level)} {incr i} { + set fwd $nodes($update($i),$i) + if {$nodes($fwd,key) != $key} break + set nodes($update($i),$i) $nodes($x,$i) + } + + # Delete all traces of this node + foreach v [array names nodes($x,*)] { + unset nodes($v) + } + + # Fix up the level in case it went down + while {$state(level) > 1} { + if {! [string equal "nil" $nodes(header,$state(level))]} break + incr state(level) -1 + } + + return 1 +} + +# ::struct::skiplist::_size -- +# +# Returns how many nodes are in the skiplist +# +# Arguments: +# name name of the skiplist. +# +# Results: +# number of nodes in the skiplist + +proc ::struct::skiplist::_size {name} { + upvar ::struct::skiplist::skiplist${name}::state state + + return $state(size) +} + +# ::struct::skiplist::_walk -- +# +# Walks a skiplist performing a specified command on each node. +# Command is executed at the global level with the actual command +# executed is: command key value +# +# Arguments: +# name name of the skiplist. +# cmd command to run on each node +# +# Results: +# none. + +proc ::struct::skiplist::_walk {name cmd} { + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} { + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy $nodes($x,key) $nodes($x,value) + uplevel 2 $cmdcpy + } +} + +# ::struct::skiplist::randomLevel -- +# +# Generates a random level for a new node. We limit it to 1 greater +# than the current level. +# +# Arguments: +# prob probability to use in generating level +# level current biggest level +# maxlevel biggest possible level +# +# Results: +# an integer between 1 and $maxlevel + +proc ::struct::skiplist::randomLevel {prob level maxlevel} { + + set lvl 1 + while {(rand() < $prob) && ($lvl < $maxlevel)} { + incr lvl + } + + if {$lvl > $level} { + set lvl [expr {$level + 1}] + } + + return $lvl +} + +# ::struct::skiplist::_dump -- +# +# Dumps out a skip list. Useful for debugging. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# none. + +proc ::struct::skiplist::_dump {name} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + + puts "Current level $state(level)" + puts "Maxlevel: $state(maxlevel)" + puts "Probability: $state(prob)" + puts "" + puts "NODE KEY FORWARD" + for {set x header} {$x != "nil"} {set x $nodes($x,1)} { + puts -nonewline [format "%-6s %3s %4s" $x $nodes($x,key) $nodes($x,1)] + for {set i 2} {[info exists nodes($x,$i)]} {incr i} { + puts -nonewline [format %4s $nodes($x,$i)] + } + puts "" + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'skiplist::skiplist' into the general structure namespace. + namespace import -force skiplist::skiplist + namespace export skiplist +} +package provide struct::skiplist 1.3 diff --git a/tcllib/modules/struct/skiplist.test b/tcllib/modules/struct/skiplist.test new file mode 100644 index 0000000..5e300f8 --- /dev/null +++ b/tcllib/modules/struct/skiplist.test @@ -0,0 +1,335 @@ +# -*- tcl -*- +# skiplist.test: tests for the skiplist structure. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2000 by Keith Vetter +# This software is licensed under a BSD license as described in tcl/tk +# license.txt file but with the copyright held by Keith Vetter. + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal skiplist.tcl struct::skiplist +} + +#---------------------------------------------------------------------- + +# ::shuffle -- +# +# creates a randomly ordered list of the integers from 0 to n-1. +# +# Arguments: +# n size of the list to shuffle +# +# Results: +# list of integers from 0 to n-1 in a random order + +proc shuffle {n} { + set t [list ] + set tt [list ] + for {set i 0} {$i < $n} {incr i} { + lappend t $i + } + + # Select a random item out of list t and append to list tt + + for {set i [expr {$n - 1}]} {$i >= 0} {incr i -1} { + set r [expr rand()] + set x [expr {int($r * ($i + 1))}] + lappend tt [lindex $t $x] + set t [lreplace $t $x $x] + } + + return $tt +} + +test skiplist-0.1 {skiplist errors} { + struct::skiplist myskiplist + catch {struct::skiplist myskiplist} msg + myskiplist destroy + set msg +} "command \"myskiplist\" already exists, unable to create skiplist" + +test skiplist-0.2 {skiplist errors} { + struct::skiplist myskiplist + catch {myskiplist} msg + myskiplist destroy + set msg +} "wrong # args: should be \"myskiplist option ?arg arg ...?\"" + +test skiplist-0.3 {skiplist errors} { + struct::skiplist myskiplist + catch {myskiplist foo} msg + myskiplist destroy + set msg +} "bad option \"foo\": must be destroy, delete, insert, search, size, or walk" + +test skiplist-0.4 {skiplist errors} { + catch {struct::skiplist set} msg + set msg +} "command \"set\" already exists, unable to create skiplist" + +test skiplist-0.5 {skiplist errors} { + catch {struct::skiplist myskiplist -foo bar} msg + set msg +} "unknown option \"-foo\": should be \"skiplist name ?-maxlevel ##? ?-probability ##?\"" + +test skiplist-0.6 {skiplist errors} { + catch {struct::skiplist myskiplist -maxlevel bar} msg + set msg +} "value for the maxlevel option must be greater than 0" + +test skiplist-0.7 {skiplist errors} { + catch {struct::skiplist myskiplist -probability bar} msg + set msg +} "probability must be between 0 and 1" + + + + +test skiplist-1.0 {insert} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + set t [myskiplist search 5] + myskiplist destroy + set t +} "1 value_5" + +test skiplist-1.1 {insert} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + myskiplist insert 5 value_5.2 + myskiplist insert 5 value_5.3 + myskiplist insert 5 value_5.4 + set t [myskiplist search 5] + myskiplist destroy + set t +} "1 value_5.4" + +test skiplist-1.2 {insert} { + struct::skiplist myskiplist + unset a + foreach a [list 9 7 5 3 1 8 6 4 2] { + myskiplist insert $a value_$a + } + set t [list ] + myskiplist walk {lappend t} + myskiplist destroy + set t +} "1 value_1 2 value_2 3 value_3 4 value_4 5 value_5 6 value_6 7 value_7 8 value_8 9 value_9" + +test skiplist-1.3 {insert} { + struct::skiplist myskiplist + foreach a [shuffle 500] { + set a2 [expr {$a + 1}] + myskiplist insert $a $a2 + } + set t [list ] + myskiplist walk {lappend t} + myskiplist destroy + set sum [set sum2 0] + foreach {key value} $t { + set sum [expr {$sum + $key}] + set sum2 [expr {$sum2 + $value}] + } + set sum "$sum $sum2" +} "124750 125250" + +test skiplist-1.4 {insert} { + struct::skiplist myskiplist + foreach a [shuffle 500] { + myskiplist insert $a -1 + } + foreach a [shuffle 500] { + myskiplist insert $a $a + } + set t [list ] + myskiplist walk {lappend t} + myskiplist destroy + set sum 0 + foreach {key value} $t { + set sum [expr {$sum + $value}] + } + set sum +} "124750" + +test skiplist-1.5 {insert} { + struct::skiplist myskiplist + foreach a [list k e i t h p o w l v r] { + myskiplist insert $a value_$a + } + set t [list ] + myskiplist walk {lappend t } + set str "" + foreach {key value} $t { + append str $key + } + myskiplist destroy + set str +} "ehikloprtvw" + + + +test skiplist-2.0 {delete} { + struct::skiplist myskiplist + myskiplist insert 4 value_4 + set t [myskiplist delete 4] + myskiplist destroy + set t +} "1" + +test skiplist-2.1 {delete} { + struct::skiplist myskiplist + myskiplist insert 4 value_4 + myskiplist delete 4 + set t [myskiplist search 4] + myskiplist destroy + set t +} "0" + +test skiplist-2.2 {delete} { + struct::skiplist myskiplist + myskiplist insert 4 value_4 + set t [myskiplist delete 5] + myskiplist destroy + set t +} "0" + +test skiplist-2.3 {delete} { + struct::skiplist myskiplist + myskiplist insert 8 value_8 + myskiplist insert 7 value_7 + myskiplist insert 6 value_6 + myskiplist insert 5 value_5 + myskiplist insert 4 value_4 + myskiplist delete 6 + myskiplist delete 5 + myskiplist delete 4 + + set t [myskiplist search 7] + myskiplist destroy + set t +} "1 value_7" + +test skiplist-2.4 {delete} { + struct::skiplist myskiplist + set data [shuffle 100] + foreach a $data { + myskiplist insert $a value_$a + if {$a == 1} { + myskiplist insert 999 value_999 + } + } + foreach a $data { + myskiplist delete $a + } + + set size [myskiplist size] + set search [myskiplist search 999] + myskiplist destroy + + if {$size != 1} { + return "size is $size but should be 1" + } + set search +} "1 value_999" + + + + +test skiplist-3.0 {search} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + myskiplist insert 4 value_4 + myskiplist insert 3 value_3 + set t [myskiplist search 4] + myskiplist destroy + set t +} "1 value_4" + +test skiplist-3.1 {search} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + myskiplist insert 4 value_4 + myskiplist insert 3 value_3 + set t [myskiplist search 14] + myskiplist destroy + set t +} "0" + + +test skiplist-4.0 {size} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + myskiplist insert 4 value_4 + myskiplist insert 3 value_3 + set t [myskiplist size] + myskiplist destroy + set t +} "3" + +test skiplist-4.1 {size} { + struct::skiplist myskiplist + for {set i 0} {$i < 500} {incr i} { + myskiplist insert $i value_$i + } + set t [myskiplist size] + myskiplist destroy + set t +} "500" + + + +test skiplist-5.0 {walk} { + struct::skiplist myskiplist + myskiplist insert 5 value_5 + myskiplist insert 4 value_4 + myskiplist insert 3 value_3 + set t [list ] + myskiplist walk {lappend t } + myskiplist destroy + set t +} "3 value_3 4 value_4 5 value_5" + +test skiplist-5.1 {walk} { + struct::skiplist myskiplist + foreach a [shuffle 500] { + set a2 [expr {$a + 1}] + myskiplist insert $a $a2 + } + set t [list ] + myskiplist walk {lappend t} + myskiplist destroy + set sum 0 + set sum2 0 + foreach {key value} $t { + set sum [expr {$sum + $key}] + set sum2 [expr {$sum2 + $value}] + } + set sum "$sum $sum2" +} "124750 125250" + +test skiplist-5.2 {walk} { + struct::skiplist myskiplist1 + struct::skiplist myskiplist2 + foreach a [shuffle 500] { + myskiplist1 insert $a value_$a + } + myskiplist1 walk {myskiplist2 insert } + set size [myskiplist2 size] + myskiplist1 destroy + myskiplist2 destroy + set size +} "500" + +testsuiteCleanup diff --git a/tcllib/modules/struct/stack.bench b/tcllib/modules/struct/stack.bench new file mode 100644 index 0000000..b1acfac --- /dev/null +++ b/tcllib/modules/struct/stack.bench @@ -0,0 +1,244 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'struct::stack' +# data structure to allow developers to monitor package performance. +# +# (c) 2008-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.4]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package require Tcl 8.4 + +package forget struct::list +package forget struct::stack + +set self [file join [pwd] [file dirname [info script]]] +set mod [file dirname $self] +set index [file join [file dirname $self] tcllibc pkgIndex.tcl] + +if 1 { + if {[file exists $index]} { + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + package require tcllibc + } +} + +source [file join $mod cmdline cmdline.tcl] +source [file join $self list.tcl] +source [file join $self stack.tcl] + +# ### ### ### ######### ######### ######### ########################### +## Create a few helpers + +proc makeNcmd {n} { + return [linsert [struct::list iota $n] 0 s push] +} + +proc makeN {n} { + struct::stack s + if {$n > 0} { eval [makeNcmd $n] } + return +} + +# ### ### ### ######### ######### ######### ########################### +## Get all the possible implementations + +struct::stack::SwitchTo {} +foreach e [struct::stack::KnownImplementations] { + ::struct::stack::LoadAccelerator $e +} + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +# We have only 6 stack operations +# +# * peek - Retrieve N elements, keep on stack, N > 0 +# * pop - Destructively retrieve N elements, N > 0 +# * push - Add N elements to the stack, N > 0 +# * rotate - Rotate the top N elements K steps, N > 1, K > 0 +# * size - Query the size of the stack. +# * clear - Remove all elements from the stack. +# * get - Alternate API to peek, retrieve whole stack +# * trim - Alternate API to pop, set to specific size, return deleted elements. + +# peek/pop: +# - Time to retrieve/remove 1/10/100/1000 elements incrementally from a stack. +# - Time to retrieve/remove ............. elements at once from a stack. +# - Stack sizes 10/100/1000/1000 and pop only elements less than size. +# Expected: Amortized linear time in number of retrieved/removed elements. + +foreach stackimpl [struct::stack::Implementations] { + struct::stack::SwitchTo $stackimpl + + foreach base {10 100 1000 10000} { + + bench -desc "stack trim once $base/0 stack($stackimpl)" -ipre { + makeN $base + } -body { + s trim 0 + } -ipost { + s destroy + } + + foreach remove {1 10 100 1000 10000} { + if {$remove > $base} continue + + bench -desc "stack pop once $base/$remove stack($stackimpl)" -ipre { + makeN $base + } -body { + s pop $remove + } -ipost { + s destroy + } + + set newsize [expr {$base - $remove}] + + bench -desc "stack trim once $base/$remove stack($stackimpl)" -ipre { + makeN $base + } -body { + s trim $newsize + } -ipost { + s destroy + } + + bench -desc "stack pop incr $base/$remove stack($stackimpl)" -pre { + set cmd {} + foreach x [struct::list iota $remove] { + lappend cmd [list s pop] + } + proc foo {} [join $cmd \n] + catch {foo} ;# compile + } -ipre { + makeN $base + } -body { + foo + } -ipost { + s destroy + } -post { + rename foo {} + } + + bench -desc "stack peek $base/$remove stack($stackimpl)" -ipre { + makeN $base + } -body { + s peek $remove + } -ipost { + s destroy + } + } + + bench -desc "stack get $base stack($stackimpl)" -ipre { + makeN $base + } -body { + s get + } -ipost { + s destroy + } + } + + # rotate + # - Time to rotate 1,N/4,N/2,N-1 steps of 10/100/1000 elements atop 10/100/1000/10000 + # Expected: Linear time in number of rotating elements. + # C: As expected. + # Tcl: Linear in both number of rotating elements and number of steps! Fix this. + + foreach n {10 100 1000 10000} { + foreach top {10 100 1000} { + if {$top > $n} continue + foreach s [list 1 [expr {$top >> 2}] [expr {$top >> 1}] [expr {$top - 1}]] { + bench -desc "stack rotate $n/$top/$s stack($stackimpl)" -pre { + makeN $n + } -body { + s rotate $top $s + } -post { + s destroy + } + } + } + } + + # push: + # - Time to add 1/10/100/1000 elements incrementally to an empty stack + # - Time to add ............. elements at once to an empty stack. + # - As above, to a stack containing 1/10/100/1000 elements already. + # Expected: Amortized linear time in number of elements added. + + foreach base {0 1 10 100 1000 10000} { + foreach add {1 10 100 1000 10000} { + bench -desc "stack push once $base/$add stack($stackimpl)" -ipre { + makeN $base + set cmd [makeNcmd $add] + } -body { + eval $cmd + } -ipost { + s destroy + } + bench -desc "stack push incr $base/$add stack($stackimpl)" -pre { + set cmd {} + foreach x [struct::list iota $add] { + lappend cmd [list s push $x] + } + proc foo {} [join $cmd \n] + catch {foo} ;# compile + } -ipre { + makeN $base + } -body { + foo + } -ipost { + s destroy + } -post { + rename foo {} + } + } + } + + # size + # - Time to query size of stack containing 0/1/10/100/1000/10000 elements. + # Expected: Constant time. + + foreach n {0 1 10 100 1000 10000} { + bench -desc "stack size $n stack($stackimpl)" -pre { + makeN $n + } -body { + s size + } -post { + s destroy + } + } + + # clear + # - Time to clear a stack containing 0/1/10/100/1000/10000 elements. + # Expected: Constant to linear time in number of elements to clear. + + foreach n {0 1 10 100 1000 10000} { + bench -desc "stack clear $n stack($stackimpl)" -ipre { + makeN $n + } -body { + s clear + } -ipost { + s destroy + } + } + +} ;# End of loop over stack implementations + +# ### ### ### ######### ######### ######### ########################### +## Complete + +return + +# ### ### ### ######### ######### ######### ########################### +## Notes ... diff --git a/tcllib/modules/struct/stack.man b/tcllib/modules/struct/stack.man new file mode 100644 index 0000000..cbefcbd --- /dev/null +++ b/tcllib/modules/struct/stack.man @@ -0,0 +1,108 @@ +[manpage_begin struct::stack n 1.5.3] +[keywords graph] +[keywords matrix] +[keywords queue] +[keywords tree] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate stack objects}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::stack [opt 1.5.3]] +[description] + +The [namespace ::struct] namespace contains a commands for processing +finite stacks. + +[para] + +It exports a single command, [cmd ::struct::stack]. All functionality +provided here can be reached through a subcommand of this command. + +[para] + +[emph Note:] As of version 1.3.3 of this package a critcl based C +implementation is available. This implementation however requires Tcl +8.4 to run. + +[para] + +The [cmd ::struct::stack] command creates a new stack object with an +associated global Tcl command whose name is [emph stackName]. This +command may be used to invoke various operations on the stack. It has +the following general form: + +[list_begin definitions] + +[call [arg stackName] [cmd option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. The following commands are possible for stack objects: + +[call [arg stackName] [method clear]] + +Remove all items from the stack. + +[call [arg stackName] [method destroy]] + +Destroy the stack, including its storage space and associated command. + +[call [arg stackName] [method get]] + +Returns the whole contents of the stack as a list, without removing +them from the stack. + +[call [arg stackName] [method getr]] + +A variant of [method get], which returns the contents in reversed order. + +[call [arg stackName] [method peek] [opt [arg count]]] + +Return the top [arg count] items of the stack, without removing them from +the stack. If [arg count] is not specified, it defaults to 1. If +[arg count] is 1, the result is a simple string; otherwise, it is a +list. If specified, [arg count] must be greater than or equal to 1. + +If there are not enoughs items on the stack to fulfull the request, +this command will throw an error. + +[call [arg stackName] [method peekr] [opt [arg count]]] + +A variant of [method peek], which returns the items in reversed order. + +[call [arg stackName] [method trim] [opt [arg newsize]]] + +Shrinks the stack to contain at most [arg newsize] elements and +returns a list containing the elements which were removed. Nothing is +done if the stack is already at the specified size, or smaller. In +that case the result is the empty list. + +[call [arg stackName] [method trim*] [opt [arg newsize]]] + +A variant of [method trim] which performs the shrinking, but does not +return the removed elements. + +[call [arg stackName] [method pop] [opt [arg count]]] + +Return the top [arg count] items of the stack, and remove them +from the stack. If [arg count] is not specified, it defaults to 1. +If [arg count] is 1, the result is a simple string; otherwise, it is a +list. If specified, [arg count] must be greater than or equal to 1. + +If there are not enoughs items on the stack to fulfull the request, +this command will throw an error. + +[call [arg stackName] [method push] [arg item] [opt [arg item...]]] + +Push the [arg item] or items specified onto the stack. If more than +one [arg item] is given, they will be pushed in the order they are +listed. + +[call [arg stackName] [method size]] + +Return the number of items on the stack. + +[list_end] + +[vset CATEGORY {struct :: stack}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/stack.tcl b/tcllib/modules/struct/stack.tcl new file mode 100644 index 0000000..0dcbca2 --- /dev/null +++ b/tcllib/modules/struct/stack.tcl @@ -0,0 +1,187 @@ +# stack.tcl -- +# +# Implementation of a stack data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack.tcl,v 1.20 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: stack_c.tcl + +package require Tcl 8.4 +namespace eval ::struct::stack {} + +# ### ### ### ######### ######### ######### +## Management of stack implementations. + +# ::struct::stack::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::stack::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of stack requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::stack_critcl]] + } + tcl { + variable selfdir + if { + [package vsatisfies [package provide Tcl] 8.5] && + ![catch {package require TclOO 0.6.1-} mx] + } { + source [file join $selfdir stack_oo.tcl] + } else { + source [file join $selfdir stack_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::stack::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::stack::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::stack ::struct::stack_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::stack_$key ::struct::stack + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::stack::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::stack::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::stack::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::stack::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::stack::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::stack { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::stack { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export stack +} + +package provide struct::stack 1.5.3 diff --git a/tcllib/modules/struct/stack.test b/tcllib/modules/struct/stack.test new file mode 100644 index 0000000..0686bc6 --- /dev/null +++ b/tcllib/modules/struct/stack.test @@ -0,0 +1,106 @@ +# -*- tcl -*- +# stack.test: tests for the stack package. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: stack.test,v 1.19 2010/03/17 22:11:45 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 1.0 + +testing { + useAccel [useTcllibC] struct/stack.tcl struct::stack + TestAccelInit struct::stack +} + +#---------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in stack.testsuite) can expect from the environment. + +TestAccelDo struct::stack impl { + namespace import -force struct::stack + + switch -exact -- $impl { + critcl { + set MY mystack + + proc tmWrong {m loarg n {xarg {}}} { + return [tcltest::wrongNumArgs "mystack $m" $loarg $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + return [tcltest::tooManyArgs "mystack $m" $loarg] + } + + proc tmTake {tcl c} { return $c } + } + tcl { + set MY ::mystack + + if {[package vsatisfies [package provide Tcl] 8.5]} { + if {[catch {package present TclOO}]} { + # Without TclOO + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "I $m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "I $m" "name$xarg"] + } + } else { + # OO implementation. + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "mystack $m" "$loarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "mystack $m" "$loarg"] + } + } + } else { + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "::struct::stack::I::$m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "::struct::stack::I::$m" "name$xarg"] + } + } + + proc tmTake {tcl c} { return $tcl } + } + } + + source [localPath stack.testsuite] +} + +#---------------------------------------------------------------------- +TestAccelExit struct::stack +testsuiteCleanup diff --git a/tcllib/modules/struct/stack.testsuite b/tcllib/modules/struct/stack.testsuite new file mode 100644 index 0000000..13cf13d --- /dev/null +++ b/tcllib/modules/struct/stack.testsuite @@ -0,0 +1,641 @@ +# -*- tcl -*- +# stack.test: tests for the stack package. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: stack.testsuite,v 1.5 2010/03/24 06:13:00 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint stack_critcl [string equal $impl critcl] +::tcltest::testConstraint stack_oo [expr {![catch {package present TclOO}] && [string equal $impl tcl]}] + +#---------------------------------------------------------------------- + +test stack-${impl}-0.1.0 {stack errors} !stack_oo { + stack mystack + catch {stack mystack} msg + mystack destroy + set msg +} {command "::mystack" already exists, unable to create stack} + +test stack-${impl}-0.1.1 {stack errors} stack_oo { + stack mystack + catch {stack mystack} msg + mystack destroy + set msg +} {can't create object "mystack": command already exists with that name} + +test stack-${impl}-0.2 {stack errors} badTest { + stack mystack + catch {mystack} msg + mystack destroy + set msg +} {wrong # args: should be "::mystack option ?arg arg ...?"} + +test stack-${impl}-0.3.0 {stack errors} tcl8.4minus { + stack mystack + catch {mystack foo} msg + mystack destroy + set msg +} {bad option "foo": must be clear, destroy, get, getr, peek, peekr, pop, push, rotate, size, trim, or trim*} + +test stack-${impl}-0.3.1.0 {stack errors} {tcl8.5plus !stack_oo} { + stack mystack + catch {mystack foo} msg + mystack destroy + set msg +} [tmTake \ + {unknown or ambiguous subcommand "foo": must be clear, destroy, get, getr, peek, peekr, pop, push, rotate, size, trim, or trim*} \ + {bad option "foo": must be clear, destroy, get, getr, peek, peekr, pop, push, rotate, size, trim, or trim*} \ + ] + +test stack-${impl}-0.3.1.1 {stack errors} {tcl8.5plus stack_oo} { + stack mystack + catch {mystack foo} msg + mystack destroy + set msg +} [tmTake \ + {unknown method "foo": must be clear, destroy, get, getr, peek, peekr, pop, push, rotate, size, trim or trim*} \ + {bad option "foo": must be clear, destroy, get, getr, peek, peekr, pop, push, rotate, size, trim, or trim*} \ + ] + +test stack-${impl}-0.4.0 {stack errors} !stack_oo { + catch {stack set} msg + set msg +} {command "::set" already exists, unable to create stack} + +test stack-${impl}-0.4.1 {stack errors} stack_oo { + catch {stack set} msg + set msg +} {can't create object "set": command already exists with that name} + +#---------------------------------------------------------------------- + +test stack-${impl}-1.1 {stack creation} { + set foo [stack mystack] + set cmd [info commands ::mystack] + set size [mystack size] + mystack destroy + list $foo $cmd $size +} {::mystack ::mystack 0} + +test stack-${impl}-1.2.0 {stack creation} !stack_oo { + set foo [stack] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + list $foo $cmd $size +} {::stack1 ::stack1 0} + +test stack-${impl}-1.2.1 {stack creation} stack_oo { + set foo [stack] + set cmd [info commands ::$foo] + set size [$foo size] + $foo destroy + string match [list ::oo::Obj* ::oo::Obj* 0] [list $foo $cmd $size] +} 1 + +#---------------------------------------------------------------------- + +test stack-${impl}-2.1 {stack destroy} { + stack mystack + mystack destroy + info commands ::mystack +} {} + +#---------------------------------------------------------------------- + +test stack-${impl}-3.2 {size operation} { + stack mystack + mystack push a b c d e f g + set size [mystack size] + mystack destroy + set size +} 7 + +test stack-${impl}-3.3 {size operation} { + stack mystack + mystack push a b c d e f g + mystack pop 3 + set size [mystack size] + mystack destroy + set size +} 4 + +test stack-${impl}-3.4 {size operation} { + stack mystack + mystack push a b c d e f g + mystack pop 3 + mystack peek 3 + set size [mystack size] + mystack destroy + set size +} 4 + +#---------------------------------------------------------------------- + +test stack-${impl}-4.1 {push operation} { + stack mystack + catch {mystack push} msg + mystack destroy + set msg +} "wrong # args: should be \"$MY push item ?item ...?\"" + +test stack-${impl}-4.2 {push operation, singleton items} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack pop] [mystack pop] [mystack pop]] + mystack destroy + set result +} {c b a} + +test stack-${impl}-4.3 {push operation, multiple items} { + stack mystack + mystack push a b c + set result [list [mystack pop] [mystack pop] [mystack pop]] + mystack destroy + set result +} {c b a} + +test stack-${impl}-4.4 {push operation, spaces in items} { + stack mystack + mystack push a b "foo bar" + set result [list [mystack pop] [mystack pop] [mystack pop]] + mystack destroy + set result +} {{foo bar} b a} + +test stack-${impl}-4.5 {push operation, bad chars in items} { + stack mystack + mystack push a b \{ + set result [list [mystack pop] [mystack pop] [mystack pop]] + mystack destroy + set result +} [list \{ b a] + +#---------------------------------------------------------------------- + +test stack-${impl}-5.1 {pop operation} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack pop] [mystack pop] [mystack pop]] + mystack destroy + set result +} {c b a} + +test stack-${impl}-5.2 {pop operation, multiple items} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [mystack pop 3] + mystack destroy + set result +} {c b a} + +#---------------------------------------------------------------------- + +test stack-${impl}-6.1 {peek operation} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack peek] [mystack peek] [mystack peek]] + mystack destroy + set result +} {c c c} + +test stack-${impl}-6.2 {peek operation} { + stack mystack + catch {mystack peek 0} msg + mystack destroy + set msg +} {invalid item count 0} + +test stack-${impl}-6.3 {peek operation} { + stack mystack + catch {mystack peek -1} msg + mystack destroy + set msg +} {invalid item count -1} + +test stack-${impl}-6.4 {peek operation} { + stack mystack + catch {mystack peek} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-6.5 {peek operation} { + stack mystack + mystack push a + catch {mystack peek 2} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-6.11 {peek operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack peek 3] + mystack destroy + set result +} {d c b} + +#---------------------------------------------------------------------- + +test stack-${impl}-6.6 {pop operation, multiple items} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack peek 3] [mystack pop 3]] + mystack destroy + set result +} {{c b a} {c b a}} + +test stack-${impl}-6.7 {pop operation} { + stack mystack + catch {mystack pop 0} msg + mystack destroy + set msg +} {invalid item count 0} + +test stack-${impl}-6.8 {pop operation} { + stack mystack + catch {mystack pop -1} msg + mystack destroy + set msg +} {invalid item count -1} + +test stack-${impl}-6.9 {pop operation} { + stack mystack + catch {mystack pop} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-6.10 {pop operation} { + stack mystack + mystack push a + catch {mystack pop 2} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +#---------------------------------------------------------------------- + +test stack-${impl}-7.1 {clear operation} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack peek 3]] + mystack clear + lappend result [mystack size] + mystack destroy + set result +} {{c b a} 0} + +#---------------------------------------------------------------------- + +test stack-${impl}-8.1 {rotate operation} { + stack mystack + mystack push a b c d e f g h + mystack rotate 3 1 + set result [mystack get] + mystack destroy + set result +} {g f h e d c b a} + +test stack-${impl}-8.2 {rotate operation} { + stack mystack + mystack push a b c d e f g h + mystack rotate 3 2 + set result [mystack get] + mystack destroy + set result +} {f h g e d c b a} + +test stack-${impl}-8.3 {rotate operation} { + stack mystack + mystack push a b c d e f g h + mystack rotate 3 5 + set result [mystack get] + mystack destroy + set result +} {f h g e d c b a} + +test stack-${impl}-8.4 {rotate operation} { + stack mystack + mystack push a b c d e f g h + mystack rotate 8 1 + set result [mystack get] + mystack destroy + set result +} {g f e d c b a h} + +test stack-${impl}-8.5 {rotate operation} { + stack mystack + mystack push a b c d e f g h + mystack rotate 8 -1 + set result [mystack get] + mystack destroy + set result +} {a h g f e d c b} + +test stack-${impl}-8.6 {rotate operation} { + stack mystack + catch {mystack rotate 8 -1} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-8.7 {rotate operation} { + stack mystack + mystack push a b c d + catch {mystack rotate 8 -1} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +#---------------------------------------------------------------------- + +test stack-${impl}-9.0 {get operation, wrong args, too many} { + stack mystack + catch {mystack get X} msg + mystack destroy + set msg +} [tmTooMany get {}] + +test stack-${impl}-9.1 {get operation, empty stack} { + stack mystack + set result [mystack get] + mystack destroy + set result +} {} + +test stack-${impl}-9.2 {get operation} { + stack mystack + mystack push a b c d + set result [mystack get] + mystack destroy + set result +} {d c b a} + +test stack-${impl}-9.3 {get operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack get] + mystack destroy + set result +} {d c b a} + +#---------------------------------------------------------------------- + +test stack-${impl}-10.0 {trim operation, wrong args, not enough} { + stack mystack + catch {mystack trim} msg + mystack destroy + set msg +} [tmWrong trim {newsize} 0] + +test stack-${impl}-10.1 {trim operation, wrong args, too many} { + stack mystack + catch {mystack trim X Y} msg + mystack destroy + set msg +} [tmTooMany trim {newsize}] + +test stack-${impl}-10.2 {trim operation, bad argument} { + stack mystack + catch {mystack trim X} msg + mystack destroy + set msg +} {expected integer but got "X"} + +test stack-${impl}-10.3 {trim operation, bad argument} { + stack mystack + catch {mystack trim -4} msg + mystack destroy + set msg +} {invalid size -4} + +test stack-${impl}-10.4 {trim operation, empty stack} { + stack mystack + set result [mystack size] + lappend result [mystack trim 1] + lappend result [mystack size] + mystack destroy + set result +} {0 {} 0} + +test stack-${impl}-10.5 {trim operation} { + stack mystack + mystack push a b c d + set result [mystack size] + lappend result [mystack trim 1] + lappend result [mystack size] + mystack destroy + set result +} {4 {d c b} 1} + +test stack-${impl}-10.6 {trim operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack size] + lappend result [mystack trim 1] + lappend result [mystack size] + mystack destroy + set result +} {4 {d c b} 1} + +test stack-${impl}-10.7 {trim operation} { + stack mystack + mystack push a b c d + set result [mystack size] + lappend result [mystack trim 5] + lappend result [mystack size] + mystack destroy + set result +} {4 {} 4} + +#---------------------------------------------------------------------- + +test stack-${impl}-11.0 {getr operation, wrong args, too many} { + stack mystack + catch {mystack getr X} msg + mystack destroy + set msg +} [tmTooMany getr {}] + +test stack-${impl}-11.1 {getr operation, empty stack} { + stack mystack + set result [mystack getr] + mystack destroy + set result +} {} + +test stack-${impl}-11.2 {getr operation} { + stack mystack + mystack push a b c d + set result [mystack getr] + mystack destroy + set result +} {a b c d} + +test stack-${impl}-11.3 {getr operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack getr] + mystack destroy + set result +} {a b c d} + +#---------------------------------------------------------------------- + +test stack-${impl}-12.0 {trim* operation, wrong args, not enough} { + stack mystack + catch {mystack trim*} msg + mystack destroy + set msg +} [tmWrong trim* {newsize} 0] + +test stack-${impl}-12.1 {trim* operation, wrong args, too many} { + stack mystack + catch {mystack trim* X Y} msg + mystack destroy + set msg +} [tmTooMany trim* {newsize}] + +test stack-${impl}-12.2 {trim* operation, bad argument} { + stack mystack + catch {mystack trim* X} msg + mystack destroy + set msg +} {expected integer but got "X"} + +test stack-${impl}-12.3 {trim* operation, bad argument} { + stack mystack + catch {mystack trim* -4} msg + mystack destroy + set msg +} {invalid size -4} + +test stack-${impl}-12.4 {trim* operation, empty stack} { + stack mystack + set result [mystack size] + lappend result [mystack trim* 1] + lappend result [mystack size] + mystack destroy + set result +} {0 {} 0} + +test stack-${impl}-12.5 {trim* operation} { + stack mystack + mystack push a b c d + set result [mystack size] + lappend result [mystack trim* 1] + lappend result [mystack size] + mystack destroy + set result +} {4 {} 1} + +test stack-${impl}-12.6 {trim* operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack size] + lappend result [mystack trim* 1] + lappend result [mystack size] + mystack destroy + set result +} {4 {} 1} + +test stack-${impl}-12.7 {trim* operation} { + stack mystack + mystack push a b c d + set result [mystack size] + lappend result [mystack trim* 5] + lappend result [mystack size] + mystack destroy + set result +} {4 {} 4} + +#---------------------------------------------------------------------- + +test stack-${impl}-13.1 {peekr operation} { + stack mystack + mystack push a + mystack push b + mystack push c + set result [list [mystack peekr] [mystack peekr] [mystack peekr]] + mystack destroy + set result +} {c c c} + +test stack-${impl}-13.2 {peekr operation} { + stack mystack + catch {mystack peekr 0} msg + mystack destroy + set msg +} {invalid item count 0} + +test stack-${impl}-13.3 {peekr operation} { + stack mystack + catch {mystack peekr -1} msg + mystack destroy + set msg +} {invalid item count -1} + +test stack-${impl}-13.4 {peekr operation} { + stack mystack + catch {mystack peekr} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-13.5 {peekr operation} { + stack mystack + mystack push a + catch {mystack peekr 2} msg + mystack destroy + set msg +} {insufficient items on stack to fill request} + +test stack-${impl}-13.6 {peekr operation} { + stack mystack + mystack push a + mystack push b + mystack push c + mystack push d + set result [mystack peekr 3] + mystack destroy + set result +} {b c d} + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/stack/ds.h b/tcllib/modules/struct/stack/ds.h new file mode 100644 index 0000000..2b99ae5 --- /dev/null +++ b/tcllib/modules/struct/stack/ds.h @@ -0,0 +1,36 @@ +/* struct::stack - critcl - layer 1 declarations + * (a) Data structures. + */ + +#ifndef _DS_H +#define _DS_H 1 + +#include "tcl.h" + +/* Forward declarations of references to stacks. + */ + +typedef struct S* SPtr; + +/* Node structure. + */ + +/* Stack structure + */ + +typedef struct S { + Tcl_Command cmd; /* Token of the object command for + * the stack */ + int max; /* Max number of objects in stack seen so far */ + Tcl_Obj* stack; /* List object holding the stack */ +} S; + +#endif /* _DS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/m.c b/tcllib/modules/struct/stack/m.c new file mode 100644 index 0000000..9883e88 --- /dev/null +++ b/tcllib/modules/struct/stack/m.c @@ -0,0 +1,382 @@ +/* struct::stack - critcl - layer 3 definitions. + * + * -> Method functions. + * Implementations for all stack methods. + */ + +#include "util.h" +#include "m.h" +#include "s.h" +#include "ms.h" + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * stm_CLEAR -- + * + * Removes all elements currently on the stack. I.e empties the stack. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +stm_CLEAR (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: stack clear + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + /* + * Delete and recreate the stack memory. A combination of delete/new, + * except the main structure is left unchanged + */ + + Tcl_DecrRefCount (s->stack); + + s->max = 0; + s->stack = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (s->stack); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * stm_DESTROY -- + * + * Destroys the whole stack object. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Releases memory. + * + *--------------------------------------------------------------------------- + */ + +int +stm_DESTROY (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: stack destroy + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DeleteCommandFromToken(interp, s->cmd); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * stm_GET -- + * + * Non-destructively retrieves all elements of the stack. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +stm_GET (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int revers) +{ + /* Syntax: stack get + * [0] [1] + */ + + int n; + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_ListObjLength (interp, s->stack, &n); + + if (n) { + return st_peek (s, interp, n, 0, 1, revers, 1 + /* no pop, list all, <revers>, return result */); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0,NULL)); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * stm_TRIM -- + * + * Destructively retrieves one or more elements from the top of the + * stack, trims the stack to a new size. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +stm_TRIM (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int ret) +{ + /* Syntax: stack trim N + * [0] [1] [2] + */ + + int n, len; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "newsize"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) { + return TCL_ERROR; + } else if (n < 0) { + Tcl_AppendResult (interp, "invalid size ", + Tcl_GetString (objv[2]), + NULL); + return TCL_ERROR; + } + + Tcl_ListObjLength (interp, s->stack, &len); + + if (len > n) { + return st_peek (s, interp, len-n, 1, 1, 0, ret + /* pop, list all, normal order, <ret> */); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0,NULL)); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * stm_PEEK/POP -- + * + * (Non-)destructively retrieves one or more elements from the top of the + * stack. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +stm_PEEK (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int pop, int revers) +{ + /* Syntax: stack peek|pop ?n? + * [0] [1] [2] + */ + + int listc = 0; + Tcl_Obj** listv; + Tcl_Obj* r; + int n = 1; + int i, j; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?n?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) { + return TCL_ERROR; + } else if (n < 1) { + Tcl_AppendResult (interp, "invalid item count ", + Tcl_GetString (objv[2]), + NULL); + return TCL_ERROR; + } + } + + return st_peek (s, interp, n, pop, 0, revers, 1 + /* <pop>, single, <revers>, return result */); +} + +/* + *--------------------------------------------------------------------------- + * + * stm_PUSH -- + * + * Adds one or more elements to the stack. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +stm_PUSH (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: stack push item... + * [0] [1] [2] + */ + + int i; + + if (objc < 3) { + Tcl_WrongNumArgs (interp, 2, objv, "item ?item ...?"); + return TCL_ERROR; + } + + for (i = 2; i < objc; i++) { + Tcl_ListObjAppendElement (interp, s->stack, objv[i]); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * stm_ROTATE -- + * + * Rotates the N top elements of the stack by K steps. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +stm_ROTATE (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: stack rotate count steps + * [0] [1] [2] [3] + */ + + int n, steps, start, i, j; + int listc = 0; + Tcl_Obj** listv = NULL; + Tcl_Obj** tmp = NULL; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "count steps"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &n) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[3], &steps) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_ListObjGetElements (interp, s->stack, &listc, &listv); + + if (n > listc) { + Tcl_AppendResult (interp, "insufficient items on stack to fill request", + NULL); + return TCL_ERROR; + } + + /* Begin rotation */ + + start = listc - n; + steps = steps % n; + while (steps < 0) steps += n; + steps = n - steps; + listv += start; + + tmp = NALLOC(n,Tcl_Obj*); + + for (i = 0; i < n; i++) { + j = (i + steps) % n; + ASSERT_BOUNDS (i,n); + ASSERT_BOUNDS (j,n); + tmp[i] = listv[j]; + } + for (i = 0; i < n; i++) { + ASSERT_BOUNDS (i,n); + listv[i] = tmp [i]; + } + + ckfree ((char*) tmp); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * stm_SIZE -- + * + * Returns the number of elements currently held by the stack. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +stm_SIZE (S* s, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: stack size + * [0] [1] + */ + + int listc = 0; + + if ((objc != 2)) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_ListObjLength (interp, s->stack, &listc); + Tcl_SetObjResult (interp, Tcl_NewIntObj (listc)); + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/m.h b/tcllib/modules/struct/stack/m.h new file mode 100644 index 0000000..6f350ed --- /dev/null +++ b/tcllib/modules/struct/stack/m.h @@ -0,0 +1,28 @@ +/* struct::stack - critcl - layer 3 declarations + * Method functions. + */ + +#ifndef _M_H +#define _M_H 1 + +#include "tcl.h" +#include <s.h> + +int stm_CLEAR (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int stm_DESTROY (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int stm_PEEK (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int pop, int revers); +int stm_PUSH (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int stm_ROTATE (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int stm_SIZE (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int stm_GET (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int revers); +int stm_TRIM (S* sd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv, int ret); + +#endif /* _M_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/ms.c b/tcllib/modules/struct/stack/ms.c new file mode 100644 index 0000000..8c4156f --- /dev/null +++ b/tcllib/modules/struct/stack/ms.c @@ -0,0 +1,79 @@ +/* struct::stack - critcl - layer 2 definitions + * + * -> Support for the stack methods in layer 3. + */ + +#include <ms.h> +#include <m.h> +#include <s.h> +#include <util.h> + +/* .................................................. */ +/* + *--------------------------------------------------------------------------- + * + * stms_objcmd -- + * + * Implementation of stack objects, the main dispatcher function. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the called methods. + * + *--------------------------------------------------------------------------- + */ + +int +stms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + S* s = (S*) cd; + int m; + + static CONST char* methods [] = { + "clear", "destroy", "get", "getr", "peek", "peekr", + "pop", "push", "rotate", "size", "trim", "trim*", + NULL + }; + enum methods { + M_CLEAR, M_DESTROY, M_GET, M_GETR, M_PEEK, M_PEEKR, + M_POP, M_PUSH, M_ROTATE, M_SIZE, M_TRIM, M_TRIMV + }; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case M_CLEAR: return stm_CLEAR (s, interp, objc, objv); + case M_DESTROY: return stm_DESTROY (s, interp, objc, objv); + case M_GET: return stm_GET (s, interp, objc, objv, 0 ); /* get */ + case M_GETR: return stm_GET (s, interp, objc, objv, 1 ); /* getr */ + case M_PEEK: return stm_PEEK (s, interp, objc, objv, 0, 0); /* peek */ + case M_PEEKR: return stm_PEEK (s, interp, objc, objv, 0, 1); /* peekr */ + case M_POP: return stm_PEEK (s, interp, objc, objv, 1, 0); /* pop */ + case M_PUSH: return stm_PUSH (s, interp, objc, objv); + case M_ROTATE: return stm_ROTATE (s, interp, objc, objv); + case M_SIZE: return stm_SIZE (s, interp, objc, objv); + case M_TRIM: return stm_TRIM (s, interp, objc, objv, 1 ); /* trim */ + case M_TRIMV: return stm_TRIM (s, interp, objc, objv, 0 ); /* trim* */ + } + /* Not coming to this place */ +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/ms.h b/tcllib/modules/struct/stack/ms.h new file mode 100644 index 0000000..7c8b276 --- /dev/null +++ b/tcllib/modules/struct/stack/ms.h @@ -0,0 +1,20 @@ +/* struct::stack - critcl - layer 2 declarations + * Support for stack methods. + */ + +#ifndef _MS_H +#define _MS_H 1 + +#include "tcl.h" + +int stms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _MS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/s.c b/tcllib/modules/struct/stack/s.c new file mode 100644 index 0000000..9284284 --- /dev/null +++ b/tcllib/modules/struct/stack/s.c @@ -0,0 +1,133 @@ +/* struct::stack - critcl - layer 1 definitions + * (c) Stack functions + */ + +#include <s.h> +#include <util.h> + +/* .................................................. */ + +S* +st_new (void) +{ + S* s = ALLOC (S); + + s->max = 0; + s->stack = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (s->stack); + + return s; +} + +void +st_delete (S* s) +{ + /* Delete a stack in toto. + */ + + Tcl_DecrRefCount (s->stack); + ckfree ((char*) s); +} + +int +st_peek (S* s, Tcl_Interp* interp, int n, int pop, int listall, int revers, int ret) +{ + + int listc = 0; + Tcl_Obj** listv; + Tcl_Obj* r; + int i, j; + + Tcl_ListObjGetElements (interp, s->stack, &listc, &listv); + + if (n > listc) { + Tcl_AppendResult (interp, + "insufficient items on stack to fill request", + NULL); + return TCL_ERROR; + } + + if (ret) { + if ((n == 1) && !listall) { + r = listv [listc-1]; + } else { + /* Grab range at the top of the stack, and revert order */ + + ASSERT_BOUNDS (listc-n,listc); + + r = Tcl_NewListObj (n, listv + (listc - n)); + + /* + * Note the double negation here. To get the normal order of the + * result, the list has to be reversed. To get the reverted order + * result, nothing is to be done. So we revers on !revers + */ + + if ((n > 1) && !revers) { + Tcl_ListObjGetElements (interp, r, &listc, &listv); + for (i = 0, j = listc-1; + i < j; + i++, j--) { + Tcl_Obj* tmp; + + ASSERT_BOUNDS (i,listc); + ASSERT_BOUNDS (j,listc); + + tmp = listv[i]; + listv[i] = listv[j]; + listv[j] = tmp; + } + } + } + + Tcl_SetObjResult (interp, r); + } + + if (pop) { + Tcl_ListObjGetElements (interp, s->stack, &listc, &listv); + + if (n == listc) { + /* Complete removal, like clear */ + + Tcl_DecrRefCount (s->stack); + + s->max = 0; + s->stack = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (s->stack); + + } else if ((listc-n) < (s->max/2)) { + /* Size dropped under threshold, shrink used memory. + */ + + Tcl_Obj* r; + + ASSERT_BOUNDS (listc-n,listc); + + r = Tcl_NewListObj (listc-n, listv); + Tcl_DecrRefCount (s->stack); + s->stack = r; + Tcl_IncrRefCount (s->stack); + s->max = listc - n; + } else { + /* Keep current list, just reduce number of elements held. + */ + + ASSERT_BOUNDS (listc-n,listc); + + Tcl_ListObjReplace (interp, s->stack, listc-n, n, 0, NULL); + } + } + + return TCL_OK; +} + + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/s.h b/tcllib/modules/struct/stack/s.h new file mode 100644 index 0000000..1a9c16a --- /dev/null +++ b/tcllib/modules/struct/stack/s.h @@ -0,0 +1,24 @@ +/* struct::stack - critcl - layer 1 declarations + * (c) Stack functions + */ + +#ifndef _S_H +#define _S_H 1 + +#include "tcl.h" +#include <ds.h> + +SPtr st_new (void); +void st_delete (SPtr s); +int st_peek (SPtr s, Tcl_Interp* interp, int n, + int pop, int listall, int revers, int ret); + +#endif /* _T_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack/util.h b/tcllib/modules/struct/stack/util.h new file mode 100644 index 0000000..585f9a3 --- /dev/null +++ b/tcllib/modules/struct/stack/util.h @@ -0,0 +1,41 @@ +/* struct::stack - critcl - layer 0 declarations + * API general utilities + */ + +#ifndef _UTIL_H +#define _UTIL_H 1 + +#include <tcl.h> + +/* Allocation macros for common situations. + */ + +#define ALLOC(type) (type *) ckalloc (sizeof (type)) +#define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type)) + +/* Assertions in general, and asserting the proper range of an array index. + */ + +#undef STACK_DEBUG +#define STACK_DEBUG 1 + +#ifdef STACK_DEBUG +#define XSTR(x) #x +#define STR(x) XSTR(x) +#define RANGEOK(i,n) ((0 <= (i)) && (i < (n))) +#define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__));} +#define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " > " STR(n)) +#else +#define ASSERT(x,msg) +#define ASSERT_BOUNDS(i,n) +#endif + +#endif /* _UTIL_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/stack_c.tcl b/tcllib/modules/struct/stack_c.tcl new file mode 100644 index 0000000..3f3b5b5 --- /dev/null +++ b/tcllib/modules/struct/stack_c.tcl @@ -0,0 +1,156 @@ +# stackc.tcl -- +# +# Implementation of a stack data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_c.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_stackc +package provide struct_stackc 1.3.1 +package require Tcl 8.4 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders stack/*.h + critcl::csources stack/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include <util.h> + #include <s.h> + #include <ms.h> + #include <m.h> + + /* .................................................. */ + /* Global stack management, per interp + */ + + typedef struct SDg { + long int counter; + char buf [50]; + } SDg; + + static void + SDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + SDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::stack/critcl" + + Tcl_InterpDeleteProc* proc = SDgrelease; + SDg* sdg; + + sdg = Tcl_GetAssocData (interp, KEY, &proc); + if (sdg == NULL) { + sdg = (SDg*) ckalloc (sizeof (SDg)); + sdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) sdg); + } + + sdg->counter ++; + sprintf (sdg->buf, "stack%d", sdg->counter); + return sdg->buf; + +#undef KEY + } + + static void + SDdeleteCmd (ClientData clientData) + { + /* Release the whole stack. */ + st_delete ((S*) clientData); + } + } + + # Main command, stack creation. + + critcl::ccommand stack_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + S* sd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = SDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + sd = st_new(); + sd->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + stms_objcmd, (ClientData) sd, + SDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/tcllib/modules/struct/stack_oo.tcl b/tcllib/modules/struct/stack_oo.tcl new file mode 100644 index 0000000..f7520c1 --- /dev/null +++ b/tcllib/modules/struct/stack_oo.tcl @@ -0,0 +1,296 @@ +# stack.tcl -- +# +# Stack implementation for Tcl 8.6+, or 8.5 + TclOO +# +# Copyright (c) 2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_oo.tcl,v 1.4 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::stack::stack_oo} +catch {rename ::struct::stack::stack_oo {}} + +oo::class create ::struct::stack::stack_oo { + + variable mystack + + constructor {} { + set mystack {} + return + } + + # clear -- + # + # Clear a stack. + # + # Results: + # None. + + method clear {} { + set mystack {} + return + } + + # get -- + # + # Retrieve the whole contents of the stack. + # + # Results: + # items list of all items in the stack. + + method get {} { + return [lreverse $mystack] + } + + method getr {} { + return $mystack + } + + # peek -- + # + # Retrieve the value of an item on the stack without popping it. + # + # Arguments: + # count number of items to pop; defaults to 1 + # + # Results: + # items top count items from the stack; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] + } + + method peekr {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] + } + + # trim -- + # + # Pop items off a stack until a maximum size is reached. + # + # Arguments: + # count requested size of the stack. + # + # Results: + # item List of items trimmed, may be empty. + + method trim {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return $result + } + + method trim* {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return + } + + # pop -- + # + # Pop an item off a stack. + # + # Arguments: + # count number of items to pop; defaults to 1 + # + # Results: + # item top count items from the stack; if the stack is empty, + # returns a list of count nulls. + + method pop {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } + + set ssize [llength $mystack] + + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [my K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [my K $mystack [unset mystack]] end-$count end] + } + return $result + } + + # push -- + # + # Push an item onto a stack. + # + # Arguments: + # args items to push. + # + # Results: + # None. + + method push {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] push item ?item ...?\"" + } + + lappend mystack {*}$args + return + } + + # rotate -- + # + # Rotate the top count number of items by step number of steps. + # + # Arguments: + # count number of items to rotate. + # steps number of steps to rotate. + # + # Results: + # None. + + method rotate {count steps} { + set len [llength $mystack] + if { $count > $len } { + return -code error "insufficient items on stack to fill request" + } + + # Rotation algorithm: + # do + # Find the insertion point in the stack + # Move the end item to the insertion point + # repeat $steps times + + set start [expr {$len - $count}] + set steps [expr {$steps % $count}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [my K $mystack [unset mystack]] \ + end end] $start $item] + } + return + } + + # size -- + # + # Return the number of objects on a stack. + # + # Results: + # count number of items on the stack. + + method size {} { + return [llength $mystack] + } + + # ### ### ### ######### ######### ######### + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + + proc stack_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::stack::stack_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::stack::stack_oo new] + } + } +} diff --git a/tcllib/modules/struct/stack_tcl.tcl b/tcllib/modules/struct/stack_tcl.tcl new file mode 100644 index 0000000..a11f635 --- /dev/null +++ b/tcllib/modules/struct/stack_tcl.tcl @@ -0,0 +1,505 @@ +# stack.tcl -- +# +# Stack implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $ + +namespace eval ::struct::stack { + # counter is used to give a unique name for unnamed stacks + variable counter 0 + + # Only export one command, the one used to instantiate a new stack + namespace export stack_tcl +} + +# ::struct::stack::stack_tcl -- +# +# Create a new stack with a given name; if no name is given, use +# stackX, where X is a number. +# +# Arguments: +# name name of the stack; if null, generate one. +# +# Results: +# name name of the stack created + +proc ::struct::stack::stack_tcl {args} { + variable I::stacks + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "stack${counter}" + } + 2 { + # Standard call. New empty stack. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"stack ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create stack" + } + + set stacks($name) [list ] + + # Create the command to manipulate the stack + interp alias {} $name {} ::struct::stack::StackProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::stack::StackProc -- +# +# Command that processes all stack object commands. +# +# Arguments: +# name name of the stack object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +if {[package vsatisfies [package provide Tcl] 8.5]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::stack::StackProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::stack::I { + namespace export clear destroy get getr peek peekr \ + trim trim* pop push rotate size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::stack::StackProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if {![llength [info commands ::struct::stack::I::$cmd]]} { + set optlist [lsort [info commands ::struct::stack::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "lreverse")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name] + } +} + +# ### ### ### ######### ######### ######### + +namespace eval ::struct::stack::I { + # The stacks array holds all of the stacks you've made + variable stacks +} + +# ### ### ### ######### ######### ######### + +# ::struct::stack::I::clear -- +# +# Clear a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::I::clear {name} { + variable stacks + set stacks($name) {} + return +} + +# ::struct::stack::I::destroy -- +# +# Destroy a stack object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::I::destroy {name} { + variable stacks + unset stacks($name) + interp alias {} $name {} + return +} + +# ::struct::stack::I::get -- +# +# Retrieve the whole contents of the stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# items list of all items in the stack. + +proc ::struct::stack::I::get {name} { + variable stacks + return [lreverse $stacks($name)] +} + +proc ::struct::stack::I::getr {name} { + variable stacks + return $stacks($name) +} + +# ::struct::stack::I::peek -- +# +# Retrieve the value of an item on the stack without popping it. +# +# Arguments: +# name name of the stack object. +# count number of items to pop; defaults to 1 +# +# Results: +# items top count items from the stack; if there are not enough items +# to fulfill the request, throws an error. + +proc ::struct::stack::I::peek {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] +} + +proc ::struct::stack::I::peekr {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] +} + +# ::struct::stack::I::trim -- +# +# Pop items off a stack until a maximum size is reached. +# +# Arguments: +# name name of the stack object. +# count requested size of the stack. +# +# Results: +# item List of items trimmed, may be empty. + +proc ::struct::stack::I::trim {name newsize} { + variable stacks + upvar 0 stacks($name) mystack + + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return $result +} + +proc ::struct::stack::I::trim* {name newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + variable stacks + upvar 0 stacks($name) mystack + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return +} + +# ::struct::stack::I::pop -- +# +# Pop an item off a stack. +# +# Arguments: +# name name of the stack object. +# count number of items to pop; defaults to 1 +# +# Results: +# item top count items from the stack; if the stack is empty, +# returns a list of count nulls. + +proc ::struct::stack::I::pop {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } + set ssize [llength $mystack] + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [K $mystack [unset mystack]] end-$count end] + } + return $result + + # ------------------------------------------------------- + + set newsize [expr {[llength $mystack] - $count}] + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + if {$count == 1} { + set result [lindex $result 0] + } + + return $result +} + +# ::struct::stack::I::push -- +# +# Push an item onto a stack. +# +# Arguments: +# name name of the stack object +# args items to push. +# +# Results: +# None. + +if {[package vsatisfies [package provide Tcl] 8.5]} { + + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + lappend mystack {*}$args + return + } +} else { + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + if {[llength $args] == 1} { + lappend mystack [lindex $args 0] + } else { + eval [linsert $args 0 lappend mystack] + } + return + } +} + +# ::struct::stack::I::rotate -- +# +# Rotate the top count number of items by step number of steps. +# +# Arguments: +# name name of the stack object. +# count number of items to rotate. +# steps number of steps to rotate. +# +# Results: +# None. + +proc ::struct::stack::I::rotate {name count steps} { + variable stacks + upvar 0 stacks($name) mystack + set len [llength $mystack] + if { $count > $len } { + return -code error "insufficient items on stack to fill request" + } + + # Rotation algorithm: + # do + # Find the insertion point in the stack + # Move the end item to the insertion point + # repeat $steps times + + set start [expr {$len - $count}] + set steps [expr {$steps % $count}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [K $mystack [unset mystack]] \ + end end] $start $item] + } + return +} + +# ::struct::stack::I::size -- +# +# Return the number of objects on a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# count number of items on the stack. + +proc ::struct::stack::I::size {name} { + variable stacks + return [llength $stacks($name)] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::stack::I::K {x y} { set x } + +if {![llength [info commands lreverse]]} { + proc ::struct::stack::I::lreverse {x} { + # assert (llength(x) > 1) + set l [llength $x] + if {$l <= 1} { return $x } + set r [list] + while {$l} { lappend r [lindex $x [incr l -1]] } + return $r + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + namespace import -force stack::stack_tcl +} diff --git a/tcllib/modules/struct/struct.tcl b/tcllib/modules/struct/struct.tcl new file mode 100644 index 0000000..c909472 --- /dev/null +++ b/tcllib/modules/struct/struct.tcl @@ -0,0 +1,18 @@ +package require Tcl 8.2 +package require struct::graph 2.0 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 2.0 +package require struct::matrix 2.0 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::set 2.1 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.3 + +namespace eval ::struct { + namespace export * +} + +package provide struct 2.1 diff --git a/tcllib/modules/struct/struct1.tcl b/tcllib/modules/struct/struct1.tcl new file mode 100644 index 0000000..7ff3e39 --- /dev/null +++ b/tcllib/modules/struct/struct1.tcl @@ -0,0 +1,17 @@ +package require Tcl 8.2 +package require struct::graph 1.2.1 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 1.2.1 +package require struct::matrix 1.2.1 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.3 + +namespace eval ::struct { + namespace export * +} + +package provide struct 1.4 diff --git a/tcllib/modules/struct/struct_list.man b/tcllib/modules/struct/struct_list.man new file mode 100644 index 0000000..e30f453 --- /dev/null +++ b/tcllib/modules/struct/struct_list.man @@ -0,0 +1,830 @@ +[comment {-*- tcl -*- doctools manpage}] +[comment {$Id: struct_list.man,v 1.24 2010/10/05 21:47:25 andreas_kupries Exp $}] +[vset LIST_VERSION 1.8.3] +[manpage_begin struct::list n [vset LIST_VERSION]] +[keywords assign] +[keywords common] +[keywords comparison] +[keywords diff] +[keywords differential] +[keywords equal] +[keywords equality] +[keywords filter] +[keywords {first permutation}] +[keywords Fisher-Yates] +[keywords flatten] +[keywords folding] +[keywords {full outer join}] +[keywords {generate permutations}] +[keywords {inner join}] +[keywords join] +[keywords {left outer join}] +[keywords list] +[keywords {longest common subsequence}] +[keywords map] +[keywords {next permutation}] +[keywords {outer join}] +[keywords permutation] +[keywords reduce] +[keywords repeating] +[keywords repetition] +[keywords reshuffle] +[keywords reverse] +[keywords {right outer join}] +[keywords shuffle] +[keywords subsequence] +[keywords swapping] +[copyright {2003-2005 by Kevin B. Kenny. All rights reserved}] +[copyright {2003-2012 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Procedures for manipulating lists}] +[category {Data structures}] +[require Tcl 8.4] +[require struct::list [opt [vset LIST_VERSION]]] +[description] + +[para] + +The [cmd ::struct::list] namespace contains several useful commands +for processing Tcl lists. Generally speaking, they implement +algorithms more complex or specialized than the ones provided by Tcl +itself. + +[para] + +It exports only a single command, [cmd struct::list]. All +functionality provided here can be reached through a subcommand of +this command. + +[section COMMANDS] +[list_begin definitions] + +[call [cmd ::struct::list] [method longestCommonSubsequence] \ + [arg sequence1] [arg sequence2] [opt [arg maxOccurs]]] + +Returns the longest common subsequence of elements in the two lists +[arg sequence1] and [arg sequence2]. If the [arg maxOccurs] parameter +is provided, the common subsequence is restricted to elements that +occur no more than [arg maxOccurs] times in [arg sequence2]. + +[para] + +The return value is a list of two lists of equal length. The first +sublist is of indices into [arg sequence1], and the second sublist is +of indices into [arg sequence2]. Each corresponding pair of indices +corresponds to equal elements in the sequences; the sequence returned +is the longest possible. + +[call [cmd ::struct::list] [method longestCommonSubsequence2] \ + [arg {sequence1 sequence2}] [opt [arg maxOccurs]]] + +Returns an approximation to the longest common sequence of elements in +the two lists [arg sequence1] and [arg sequence2]. + +If the [arg maxOccurs] parameter is omitted, the subsequence computed +is exactly the longest common subsequence; otherwise, the longest +common subsequence is approximated by first determining the longest +common sequence of only those elements that occur no more than + +[arg maxOccurs] times in [arg sequence2], and then using that result +to align the two lists, determining the longest common subsequences of +the sublists between the two elements. + +[para] + +As with [method longestCommonSubsequence], the return value is a list +of two lists of equal length. The first sublist is of indices into +[arg sequence1], and the second sublist is of indices into + +[arg sequence2]. Each corresponding pair of indices corresponds to +equal elements in the sequences. The sequence approximates the +longest common subsequence. + +[call [cmd ::struct::list] [method lcsInvert] [arg lcsData] [arg len1] [arg len2]] + +This command takes a description of a longest common subsequence + +([arg lcsData]), inverts it, and returns the result. Inversion means +here that as the input describes which parts of the two sequences are +identical the output describes the differences instead. + +[para] + +To be fully defined the lengths of the two sequences have to be known +and are specified through [arg len1] and [arg len2]. + +[para] + +The result is a list where each element describes one chunk of the +differences between the two sequences. This description is a list +containing three elements, a type and two pairs of indices into + +[arg sequence1] and [arg sequence2] respectively, in this order. + +The type can be one of three values: + +[list_begin definitions] +[def [const added]] + +Describes an addition. I.e. items which are missing in [arg sequence1] +can be found in [arg sequence2]. + +The pair of indices into [arg sequence1] describes where the added +range had been expected to be in [arg sequence1]. The first index +refers to the item just before the added range, and the second index +refers to the item just after the added range. + +The pair of indices into [arg sequence2] describes the range of items +which has been added to it. The first index refers to the first item +in the range, and the second index refers to the last item in the +range. + +[def [const deleted]] + +Describes a deletion. I.e. items which are in [arg sequence1] are +missing from [arg sequence2]. + +The pair of indices into [arg sequence1] describes the range of items +which has been deleted. The first index refers to the first item in +the range, and the second index refers to the last item in the range. + +The pair of indices into [arg sequence2] describes where the deleted +range had been expected to be in [arg sequence2]. The first index +refers to the item just before the deleted range, and the second index +refers to the item just after the deleted range. + +[def [const changed]] + +Describes a general change. I.e a range of items in [arg sequence1] +has been replaced by a different range of items in [arg sequence2]. + +The pair of indices into [arg sequence1] describes the range of items +which has been replaced. The first index refers to the first item in +the range, and the second index refers to the last item in the range. + +The pair of indices into [arg sequence2] describes the range of items +replacing the original range. Again the first index refers to the +first item in the range, and the second index refers to the last item +in the range. + +[list_end] + +[para] +[example { + sequence 1 = {a b r a c a d a b r a} + lcs 1 = {1 2 4 5 8 9 10} + lcs 2 = {0 1 3 4 5 6 7} + sequence 2 = {b r i c a b r a c} + + Inversion = {{deleted {0 0} {-1 0}} + {changed {3 3} {2 2}} + {deleted {6 7} {4 5}} + {added {10 11} {8 8}}} +}] + +[emph Notes:] +[para] +[list_begin itemized] +[item] +An index of [const -1] in a [term deleted] chunk refers to just before +the first element of the second sequence. + +[item] +Also an index equal to the length of the first sequence in an +[term added] chunk refers to just behind the end of the sequence. + +[list_end] + +[call [cmd ::struct::list] [method lcsInvert2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]] + +Similar to [method lcsInvert]. Instead of directly taking the result +of a call to [method longestCommonSubsequence] this subcommand expects +the indices for the two sequences in two separate lists. + +[call [cmd ::struct::list] [method lcsInvertMerge] [arg lcsData] [arg len1] [arg len2]] + +Similar to [method lcsInvert]. It returns essentially the same +structure as that command, except that it may contain chunks of type +[const unchanged] too. + +[para] + +These new chunks describe the parts which are unchanged between the +two sequences. This means that the result of this command describes +both the changed and unchanged parts of the two sequences in one +structure. + +[para] +[example { + sequence 1 = {a b r a c a d a b r a} + lcs 1 = {1 2 4 5 8 9 10} + lcs 2 = {0 1 3 4 5 6 7} + sequence 2 = {b r i c a b r a c} + + Inversion/Merge = {{deleted {0 0} {-1 0}} + {unchanged {1 2} {0 1}} + {changed {3 3} {2 2}} + {unchanged {4 5} {3 4}} + {deleted {6 7} {4 5}} + {unchanged {8 10} {5 7}} + {added {10 11} {8 8}}} +}] + +[call [cmd ::struct::list] [method lcsInvertMerge2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]] + +Similar to [method lcsInvertMerge]. Instead of directly taking the +result of a call to [method longestCommonSubsequence] this subcommand +expects the indices for the two sequences in two separate lists. + +[call [cmd ::struct::list] [method reverse] [arg sequence]] + +The subcommand takes a single [arg sequence] as argument and returns a new +sequence containing the elements of the input sequence in reverse +order. + +[call [cmd ::struct::list] [method shuffle] [arg list]] + +The subcommand takes a [arg list] and returns a copy of that list +with the elements it contains in random order. Every possible +ordering of elements is equally likely to be generated. The +Fisher-Yates shuffling algorithm is used internally. + +[call [cmd ::struct::list] [method assign] [arg sequence] [arg varname] [opt [arg varname]]...] + +The subcommand assigns the first [var n] elements of the input + +[arg sequence] to the one or more variables whose names were listed +after the sequence, where [var n] is the number of specified +variables. + +[para] + +If there are more variables specified than there are elements in the +[arg sequence] the empty string will be assigned to the superfluous +variables. + +[para] + +If there are more elements in the [arg sequence] than variable names +specified the subcommand returns a list containing the unassigned +elements. Else an empty list is returned. + +[example { + tclsh> ::struct::list assign {a b c d e} foo bar + c d e + tclsh> set foo + a + tclsh> set bar + b +}] + +[call [cmd ::struct::list] [method flatten] [opt [option -full]] [opt [option --]] [arg sequence]] + +The subcommand takes a single [arg sequence] and returns a new +sequence where one level of nesting was removed from the input +sequence. In other words, the sublists in the input sequence are +replaced by their elements. + +[para] + +The subcommand will remove any nesting it finds if the option +[option -full] is specified. + +[example { + tclsh> ::struct::list flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} + 1 2 3 4 5 6 7 {8 9} 10 + tclsh> ::struct::list flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} + 1 2 3 4 5 6 7 8 9 10 +}] + +[call [cmd ::struct::list] [method map] [arg sequence] [arg cmdprefix]] + +The subcommand takes a [arg sequence] to operate on and a command +prefix ([arg cmdprefix]) specifying an operation, applies the command +prefix to each element of the sequence and returns a sequence +consisting of the results of that application. + +[para] + +The command prefix will be evaluated with a single word appended to +it. The evaluation takes place in the context of the caller of the +subcommand. + +[para] + +[example { + tclsh> # squaring all elements in a list + + tclsh> proc sqr {x} {expr {$x*$x}} + tclsh> ::struct::list map {1 2 3 4 5} sqr + 1 4 9 16 25 + + tclsh> # Retrieving the second column from a matrix + tclsh> # given as list of lists. + + tclsh> proc projection {n list} {::lindex $list $n} + tclsh> ::struct::list map {{a b c} {1 2 3} {d f g}} {projection 1} + b 2 f +}] + +[call [cmd ::struct::list] [method mapfor] [arg var] [arg sequence] [arg script]] + +The subcommand takes a [arg sequence] to operate on and a tcl [arg script], +applies the script to each element of the sequence and returns a sequence +consisting of the results of that application. + +[para] + +The script will be evaluated as is, and has access to the current list element +through the specified iteration variable [arg var]. The evaluation takes place +in the context of the caller of the subcommand. + +[para] + +[example { + tclsh> # squaring all elements in a list + + tclsh> ::struct::list mapfor x {1 2 3 4 5} { + expr {$x * $x} + } + 1 4 9 16 25 + + tclsh> # Retrieving the second column from a matrix + tclsh> # given as list of lists. + + tclsh> ::struct::list mapfor x {{a b c} {1 2 3} {d f g}} { + lindex $x 1 + } + b 2 f +}] + +[call [cmd ::struct::list] [method filter] [arg sequence] [arg cmdprefix]] + +The subcommand takes a [arg sequence] to operate on and a command +prefix ([arg cmdprefix]) specifying an operation, applies the command +prefix to each element of the sequence and returns a sequence +consisting of all elements of the [arg sequence] for which the command +prefix returned [const true]. + +In other words, this command filters out all elements of the input +[arg sequence] which fail the test the [arg cmdprefix] represents, and +returns the remaining elements. + +[para] + +The command prefix will be evaluated with a single word appended to +it. The evaluation takes place in the context of the caller of the +subcommand. + +[para] + +[example { + tclsh> # removing all odd numbers from the input + + tclsh> proc even {x} {expr {($x % 2) == 0}} + tclsh> ::struct::list filter {1 2 3 4 5} even + 2 4 +}] + +[para] + +[emph Note:] The [method filter] is a specialized application of +[method fold] where the result is extended with the current item or +not, depending o nthe result of the test. + +[call [cmd ::struct::list] [method filterfor] [arg var] [arg sequence] [arg expr]] + +The subcommand takes a [arg sequence] to operate on and a tcl expression +([arg expr]) specifying a condition, applies the conditionto each element +of the sequence and returns a sequence consisting of all elements of the +[arg sequence] for which the expression returned [const true]. + +In other words, this command filters out all elements of the input +[arg sequence] which fail the test the condition [arg expr] represents, and +returns the remaining elements. + +[para] + +The expression will be evaluated as is, and has access to the current list +element through the specified iteration variable [arg var]. The evaluation +takes place in the context of the caller of the subcommand. + +[para] + +[example { + tclsh> # removing all odd numbers from the input + + tclsh> ::struct::list filterfor x {1 2 3 4 5} {($x % 2) == 0} + 2 4 +}] + +[call [cmd ::struct::list] [method split] [arg sequence] [arg cmdprefix] [opt "[arg passVar] [arg failVar]"]] + +This is a variant of method [method filter], see above. Instead of +returning just the elements passing the test we get lists of both +passing and failing elements. + +[para] + +If no variable names are specified then the result of the command will +be a list containing the list of passing elements, and the list of +failing elements, in this order. Otherwise the lists of passing and +failing elements are stored into the two specified variables, and the +result will be a list containing two numbers, the number of elements +passing the test, and the number of elements failing, in this order. + +[para] + +The interface to the test is the same as used by [method filter]. + +[call [cmd ::struct::list] [method fold] [arg sequence] [arg initialvalue] [arg cmdprefix]] + +The subcommand takes a [arg sequence] to operate on, an arbitrary +string [arg {initial value}] and a command prefix ([arg cmdprefix]) +specifying an operation. + +[para] + +The command prefix will be evaluated with two words appended to +it. The second of these words will always be an element of the +sequence. The evaluation takes place in the context of the caller of +the subcommand. + +[para] + +It then reduces the sequence into a single value through repeated +application of the command prefix and returns that value. This +reduction is done by + +[list_begin definitions] +[def [const 1]] + +Application of the command to the initial value and the first element +of the list. + +[def [const 2]] + +Application of the command to the result of the last call and the +second element of the list. + +[def [const ...]] +[def [const i]] + +Application of the command to the result of the last call and the +[var i]'th element of the list. + +[def [const ...]] +[def [const end]] + +Application of the command to the result of the last call and the last +element of the list. The result of this call is returned as the result +of the subcommand. + +[list_end] +[para] +[example { + tclsh> # summing the elements in a list. + tclsh> proc + {a b} {expr {$a + $b}} + tclsh> ::struct::list fold {1 2 3 4 5} 0 + + 15 +}] + +[call [cmd ::struct::list] [method shift] [arg listvar]] + +The subcommand takes the list contained in the variable named by + +[arg listvar] and shifts it down one element. + +After the call [arg listvar] will contain a list containing the second +to last elements of the input list. The first element of the ist is +returned as the result of the command. Shifting the empty list does +nothing. + +[call [cmd ::struct::list] [method iota] [arg n]] + +The subcommand returns a list containing the integer numbers +in the range [const {[0,n)}]. The element at index [var i] +of the list contain the number [const i]. + +[para] + +For "[arg n] == [const 0]" an empty list will be returned. + +[call [cmd ::struct::list] [method equal] [arg a] [arg b]] + +The subcommand compares the two lists [arg a] and [arg b] for +equality. In other words, they have to be of the same length and have +to contain the same elements in the same order. If an element is a +list the same definition of equality applies recursively. + +[para] + +A boolean value will be returned as the result of the command. +This value will be [const true] if the two lists are equal, and +[const false] else. + +[call [cmd ::struct::list] [method repeat] [arg size] [arg element1] [opt "[arg element2] [arg element3]..."]] + +The subcommand creates a list of length + +"[arg size] * [emph {number of elements}]" by repeating [arg size] +times the sequence of elements +[arg element1] [arg element2] [arg ...]. + +[arg size] must be a positive integer, [arg element][var n] can be any +Tcl value. + +Note that [cmd {repeat 1 arg ...}] is identical to +[cmd {list arg ...}], though the [arg arg] is required +with [method repeat]. + +[para] +[emph Examples:] +[para] +[example { + tclsh> ::struct::list repeat 3 a + a a a + tclsh> ::struct::list repeat 3 [::struct::list repeat 3 0] + {0 0 0} {0 0 0} {0 0 0} + tclsh> ::struct::list repeat 3 a b c + a b c a b c a b c + tclsh> ::struct::list repeat 3 [::struct::list repeat 2 a] b c + {a a} b c {a a} b c {a a} b c +}] + +[call [cmd ::struct::list] [method repeatn] [arg value] [arg size]...] + +The subcommand creates a (nested) list containing the [arg value] in +all positions. The exact size and degree of nesting is determined by +the [arg size] arguments, all of which have to be integer numbers +greater than or equal to zero. + +[para] + +A single argument [arg size] which is a list of more than one element +will be treated as if more than argument [arg size] was specified. + +[para] + +If only one argument [arg size] is present the returned list will not +be nested, of length [arg size] and contain [arg value] in all +positions. + +If more than one [arg size] argument is present the returned +list will be nested, and of the length specified by the last +[arg size] argument given to it. The elements of that list +are defined as the result of [cmd Repeat] for the same arguments, +but with the last [arg size] value removed. + +[para] + +An empty list will be returned if no [arg size] arguments are present. + +[para] +[example { + tclsh> ::struct::list repeatn 0 3 4 + {0 0 0} {0 0 0} {0 0 0} {0 0 0} + tclsh> ::struct::list repeatn 0 {3 4} + {0 0 0} {0 0 0} {0 0 0} {0 0 0} + tclsh> ::struct::list repeatn 0 {3 4 5} + {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} +}] + +[call [cmd ::struct::list] [method dbJoin] [opt [option -inner]|[option -left]|[option -right]|[option -full]] [opt "[option -keys] [arg varname]"] \{[arg keycol] [arg table]\}...] + +The method performs a table join according to relational algebra. The +execution of any of the possible outer join operation is triggered by +the presence of either option [option -left], [option -right], or +[option -full]. If none of these options is present a regular inner +join will be performed. This can also be triggered by specifying +[option -inner]. The various possible join operations are explained in +detail in section [sectref {TABLE JOIN}]. + +[para] + +If the [option -keys] is present its argument is the name of a +variable to store the full list of found keys into. Depending on the +exact nature of the input table and the join mode the output table may +not contain all the keys by default. In such a case the caller can +declare a variable for this information and then insert it into the +output table on its own, as she will have more information about the +placement than this command. + +[para] + +What is left to explain is the format of the arguments. + +[para] + +The [arg keycol] arguments are the indices of the columns in the +tables which contain the key values to use for the joining. Each +argument applies to the table following immediately after it. The +columns are counted from [const 0], which references the first +column. The table associated with the column index has to have at +least [arg keycol]+1 columns. An error will be thrown if there are +less. + +[para] + +The [arg table] arguments represent a table or matrix of rows and +columns of values. We use the same representation as generated and +consumed by the methods [method {get rect}] and [method {set rect}] of +[cmd matrix] objects. In other words, each argument is a list, +representing the whole matrix. Its elements are lists too, each +representing a single rows of the matrix. The elements of the +row-lists are the column values. + +[para] + +The table resulting from the join operation is returned as the result +of the command. We use the same representation as described above for +the input [arg table]s. + +[call [cmd ::struct::list] [method dbJoinKeyed] [opt [option -inner]|[option -left]|[option -right]|[option -full]] [opt "[option -keys] [arg varname]"] [arg table]...] + +The operations performed by this method are the same as described +above for [method dbJoin]. The only difference is in the specification +of the keys to use. Instead of using column indices separate from the +table here the keys are provided within the table itself. The row +elements in each [arg table] are not the lists of column values, but a +two-element list where the second element is the regular list of +column values and the first element is the key to use. + +[call [cmd ::struct::list] [method swap] [arg listvar] [arg i] [arg j]] + +The subcommand exchanges the elements at the indices [arg i] and +[arg j] in the list stored in the variable named by [arg listvar]. The +list is modified in place, and also returned as the result of the +subcommand. + +[call [cmd ::struct::list] [method firstperm] [arg list]] + +This subcommand returns the lexicographically first permutation of the +input [arg list]. + +[call [cmd ::struct::list] [method nextperm] [arg perm]] + +This subcommand accepts a permutation of a set of elements (provided +by [arg perm]) and returns the next permutatation in lexicographic +sequence. + +[para] +The algorithm used here is by Donal E. Knuth, see section +[sectref REFERENCES] for details. + +[call [cmd ::struct::list] [method permutations] [arg list]] + +This subcommand returns a list containing all permutations of the +input [arg list] in lexicographic order. + +[call [cmd ::struct::list] [method foreachperm] [arg var] [arg list] [arg body]] + +This subcommand executes the script [arg body] once for each +permutation of the specified [arg list]. The permutations are visited +in lexicographic order, and the variable [arg var] is set to the +permutation for which [arg body] is currently executed. The result of +the loop command is the empty string. + +[list_end] + +[section {LONGEST COMMON SUBSEQUENCE AND FILE COMPARISON}] + +[para] + +The [method longestCommonSubsequence] subcommand forms the core of a +flexible system for doing differential comparisons of files, similar +to the capability offered by the Unix command [syscmd diff]. + +While this procedure is quite rapid for many tasks of file comparison, +its performance degrades severely if [arg sequence2] contains many +equal elements (as, for instance, when using this procedure to compare +two files, a quarter of whose lines are blank. This drawback is +intrinsic to the algorithm used (see the Reference for details). + +[para] + +One approach to dealing with the performance problem that is sometimes +effective in practice is arbitrarily to exclude elements that appear +more than a certain number of times. + +This number is provided as the [arg maxOccurs] parameter. If frequent +lines are excluded in this manner, they will not appear in the common +subsequence that is computed; the result will be the longest common +subsequence of infrequent elements. + +The procedure [method longestCommonSubsequence2] implements this +heuristic. + +It functions as a wrapper around [method longestCommonSubsequence]; it +computes the longest common subsequence of infrequent elements, and +then subdivides the subsequences that lie between the matches to +approximate the true longest common subsequence. + +[section {TABLE JOIN}] + +This is an operation from relational algebra for relational databases. + +[para] + +The easiest way to understand the regular inner join is that it +creates the cartesian product of all the tables involved first and +then keeps only all those rows in the resulting table for which the +values in the specified key columns are equal to each other. + +[para] + +Implementing this description naively, i.e. as described above will +generate a [emph huge] intermediate result. To avoid this the +cartesian product and the filtering of row are done at the same +time. What is required is a fast way to determine if a key is present +in a table. In a true database this is done through indices. Here we +use arrays internally. + +[para] + +An [term outer] join is an extension of the inner join for two +tables. There are three variants of outerjoins, called [term left], +[term right], and [term full] outer joins. Their result always +contains all rows from an inner join and then some additional rows. + +[list_begin enumerated] +[enum] + +For the left outer join the additional rows are all rows from the left +table for which there is no key in the right table. They are joined to +an empty row of the right table to fit them into the result. + +[enum] + +For the right outer join the additional rows are all rows from the right +table for which there is no key in the left table. They are joined to +an empty row of the left table to fit them into the result. + +[enum] + +The full outer join combines both left and right outer join. In other +words, the additional rows are as defined for left outer join, and +right outer join, combined. + +[list_end] + +[para] + +We extend all the joins from two to [var n] tables ([var n] > 2) by +executing + +[example { + (...((table1 join table2) join table3) ...) join tableN +}] + +[para] + +Examples for all the joins: + +[example { + Inner Join + + {0 foo} {0 bagel} {0 foo 0 bagel} + {1 snarf} inner join {1 snatz} = {1 snarf 1 snatz} + {2 blue} {3 driver} + + Left Outer Join + + {0 foo} {0 bagel} {0 foo 0 bagel} + {1 snarf} left outer join {1 snatz} = {1 snarf 1 snatz} + {2 blue} {3 driver} {2 blue {} {}} + + Right Outer Join + + {0 foo} {0 bagel} {0 foo 0 bagel} + {1 snarf} right outer join {1 snatz} = {1 snarf 1 snatz} + {2 blue} {3 driver} {{} {} 3 driver} + + Full Outer Join + + {0 foo} {0 bagel} {0 foo 0 bagel} + {1 snarf} full outer join {1 snatz} = {1 snarf 1 snatz} + {2 blue} {3 driver} {2 blue {} {}} + {{} {} 3 driver} +}] + +[section REFERENCES] + +[list_begin enumerated] + +[enum] +J. W. Hunt and M. D. McIlroy, "An algorithm for differential +file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone +Laboratories (1976). Available on the Web at the second +author's personal site: [uri http://www.cs.dartmouth.edu/~doug/] + +[enum] +Donald E. Knuth, "Fascicle 2b of 'The Art of Computer Programming' +volume 4". Available on the Web at the author's personal site: +[uri http://www-cs-faculty.stanford.edu/~knuth/fasc2b.ps.gz]. + +[list_end] + +[vset CATEGORY {struct :: list}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/struct_set.man b/tcllib/modules/struct/struct_set.man new file mode 100644 index 0000000..13ae6ef --- /dev/null +++ b/tcllib/modules/struct/struct_set.man @@ -0,0 +1,136 @@ +[comment {-*- tcl -*- doctools manpage}] +[comment {$Id: struct_set.man,v 1.12 2009/01/29 06:16:20 andreas_kupries Exp $}] +[manpage_begin struct::set n 2.2.3] +[keywords cardinality] +[keywords difference] +[keywords emptiness] +[keywords exclusion] +[keywords inclusion] +[keywords intersection] +[keywords membership] +[keywords set] +[keywords {symmetric difference}] +[keywords union] +[copyright {2004-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Procedures for manipulating sets}] +[category {Data structures}] +[require Tcl 8.0] +[require struct::set [opt 2.2.3]] +[description] + +[para] + +The [cmd ::struct::set] namespace contains several useful commands for +processing finite sets. + +[para] + +It exports only a single command, [cmd struct::set]. All +functionality provided here can be reached through a subcommand of +this command. + +[para] + +[emph Note:] As of version 2.2 of this package a critcl based C +implementation is available. This implementation however requires Tcl +8.4 to run. + +[section COMMANDS] +[list_begin definitions] + +[call [cmd ::struct::set] [method empty] [arg set]] + +Returns a boolean value indicating if the [arg set] is +empty ([const true]), or not ([const false]). + +[call [cmd ::struct::set] [method size] [arg set]] + +Returns an integer number greater than or equal to zero. This is the +number of elements in the [arg set]. In other words, its cardinality. + +[call [cmd ::struct::set] [method contains] [arg set] [arg item]] + +Returns a boolean value indicating if the [arg set] contains the +element [arg item] ([const true]), or not ([const false]). + +[call [cmd ::struct::set] [method union] [opt [arg set1]...]] + +Computes the set containing the union of [arg set1], [arg set2], +etc., i.e. "[arg set1] + [arg set2] + ...", and returns this set +as the result of the command. + +[call [cmd ::struct::set] [method intersect] [opt [arg set1]...]] + +Computes the set containing the intersection of [arg set1], +[arg set2], etc., i.e. "[arg set1] * [arg set2] * ...", and +returns this set as the result of the command. + +[call [cmd ::struct::set] [method difference] [arg set1] [arg set2]] + +Computes the set containing the difference of [arg set1] and +[arg set2], i.e. ("[arg set1] - [arg set2]") and returns this +set as the result of the command. + +[call [cmd ::struct::set] [method symdiff] [arg set1] [arg set2]] + +Computes the set containing the symmetric difference of [arg set1] and +[arg set2], i.e. ("([arg set1] - [arg set2]) + ([arg set2] - [arg set1])") +and returns this set as the result of the command. + +[call [cmd ::struct::set] [method intersect3] [arg set1] [arg set2]] + +This command is a combination of the methods [method intersect] and +[method difference]. + +It returns a three-element list containing "[arg set1]*[arg set2]", +"[arg set1]-[arg set2]", and "[arg set2]-[arg set1]", in this +order. In other words, the intersection of the two parameter sets, and +their differences. + +[call [cmd ::struct::set] [method equal] [arg set1] [arg set2]] + +Returns a boolean value indicating if the two sets are equal +([const true]) or not ([const false]). + +[call [cmd ::struct::set] [method include] [arg svar] [arg item]] + +The element [arg item] is added to the set specified by the variable +name in [arg svar]. The return value of the command is empty. This is +the equivalent of [cmd lappend] for sets. If the variable named by +[arg svar] does not exist it will be created. + +[call [cmd ::struct::set] [method exclude] [arg svar] [arg item]] + +The element [arg item] is removed from the set specified by the +variable name in [arg svar]. The return value of the command is +empty. This is a near-equivalent of [cmd lreplace] for sets. + +[call [cmd ::struct::set] [method add] [arg svar] [arg set]] + +All the element of [arg set] are added to the set specified by the +variable name in [arg svar]. The return value of the command is +empty. This is like the method [method include], but for the addition +of a whole set. If the variable named by [arg svar] does not exist it +will be created. + +[call [cmd ::struct::set] [method subtract] [arg svar] [arg set]] + +All the element of [arg set] are removed from the set specified by the +variable name in [arg svar]. The return value of the command is +empty. This is like the method [method exclude], but for the removal +of a whole set. + +[call [cmd ::struct::set] [method subsetof] [arg A] [arg B]] + +Returns a boolean value indicating if the set [arg A] is a true +subset of or equal to the set [arg B] ([const true]), or not +([const false]). + +[list_end] + +[section REFERENCES] + +[vset CATEGORY {struct :: set}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/struct_tree.man b/tcllib/modules/struct/struct_tree.man new file mode 100644 index 0000000..a1aae95 --- /dev/null +++ b/tcllib/modules/struct/struct_tree.man @@ -0,0 +1,792 @@ +[comment {-*- tcl -*-}] +[manpage_begin struct::tree n 2.1.1] +[keywords breadth-first] +[keywords depth-first] +[keywords in-order] +[keywords node] +[keywords post-order] +[keywords pre-order] +[keywords serialization] +[keywords tree] +[copyright {2002-2004,2012 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate tree objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::tree [opt 2.1.1]] +[require struct::list [opt 1.5]] +[description] +[para] + +A tree is a collection of named elements, called nodes, one of which is +distinguished as a root, along with a relation ("parenthood") that +places a hierarchical structure on the nodes. (Data Structures and +Algorithms; Aho, Hopcroft and Ullman; Addison-Wesley, 1987). In +addition to maintaining the node relationships, this tree +implementation allows any number of keyed values to be associated with +each node. + +[para] + +The element names can be arbitrary strings. + +[para][comment {This comparison (C) 2007 Lars Bergstrom, Bug 1687902}] + +A tree is thus similar to an array, but with three important +differences: + +[list_begin enumerated] +[enum] Trees are accessed through an object command, whereas arrays are +accessed as variables. (This means trees cannot be local to a procedure.) + +[enum] Trees have a hierarchical structure, whereas an array is just an +unordered collection. + +[enum] Each node of a tree has a separate collection of attributes and +values. This is like an array where every value is a dictionary. + +[list_end] + +[para] + +[emph Note:] The major version of the package [package struct] has +been changed to version 2.0, due to backward incompatible changes in +the API of this module. Please read the section + +[sectref {Changes for 2.0}] for a full list of all changes, +incompatible and otherwise. + +[para] + +[section API] +[subsection {Tree CLASS API}] + +The main commands of the package are: + +[list_begin definitions] + +[call [cmd ::struct::tree] [opt [arg treeName]] \ + [opt "[const =]|[const :=]|[const as]|[const deserialize] [arg source]"]] + +The command creates a new tree object with an associated global Tcl +command whose name is [arg treeName]. This command may be used to +invoke various operations on the tree. + +It has the following general form: + +[list_begin definitions] +[call [cmd treeName] [method option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] +[para] + +If [arg treeName] is not specified a unique name will be generated by +the package itself. If a [arg source] is specified the new tree will +be initialized to it. For the operators [const =], [const :=], and +[const as] [arg source] is interpreted as the name of another tree +object, and the assignment operator [method =] will be executed. For +[const deserialize] the [arg source] is a serialized tree object and +[method deserialize] will be executed. + +[para] + +In other words +[para] +[example { + ::struct::tree mytree = b +}] +[para] +is equivalent to +[para] +[example { + ::struct::tree mytree + mytree = b +}] +[para] +and +[para] +[example { + ::struct::tree mytree deserialize $b +}] +[para] +is equivalent to +[para] +[example { + ::struct::tree mytree + mytree deserialize $b +}] + +[call [cmd ::struct::tree::prune]] + +This command is provided outside of the tree methods, as it is not a +tree method per se. It however interacts tightly with the method +[method walk]. When used in the walk script it causes the traversal to +ignore the children of the node we are currently at. + +This command cannot be used with the traversal modes which look at +children before their parent, i.e. [const post] and [const in]. The +only applicable orders of traversal are [const pre] and +[const both]. An error is thrown if the command and chosen order of +traversal do not fit. + +[list_end] +[para] + +[subsection {Tree OBJECT API}] + +Two general observations beforehand: + +[list_begin enumerated] +[enum] + +The root node of the tree can be used in most places where a node is +asked for. The default name of the rootnode is "root", but this can be +changed with the method [method rename] (see below). Whatever the +current name for the root node of the tree is, it can be retrieved by +calling the method [method rootname]. + +[enum] + +The method [method insert] is the only way to create new nodes, and +they are automatically added to a parent. A tree object cannot have +nodes without a parent, save the root node. + +[list_end] +[para] + +And now the methods supported by tree objects created by this package: + +[list_begin definitions] + +[call [arg treeName] [method =] [arg sourcetree]] + +This is the assignment operator for tree objects. It copies the tree +contained in the tree object [arg sourcetree] over the tree data in +[arg treeName]. The old contents of [arg treeName] are deleted by this +operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg treeName] [method deserialize] [lb][arg sourcetree] [method serialize][rb] +[example_end] + +[call [arg treeName] [method -->] [arg desttree]] + +This is the reverse assignment operator for tree objects. It copies the tree +contained in the tree object [arg treeName] over the tree data in the object +[arg desttree]. The old contents of [arg desttree] are deleted by this +operation. + +[para] + +This operation is in effect equivalent to +[para] +[example_begin] + [arg desttree] [method deserialize] [lb][arg treeName] [method serialize][rb] +[example_end] + +[call [arg treeName] [method ancestors] [arg node]] + +This method extends the method [method parent] and returns a list +containing all ancestor nodes to the specified [arg node]. The +immediate ancestor, in other words, parent node, is the first element +in that list, its parent the second element, and so on until the root +node is reached, making it the last element of the returned list. + +[call [arg treeName] [method append] [arg node] [arg key] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +node. Returns the new value given to the attribute [arg key]. + +[call [arg treeName] [method attr] [arg key]] +[call [arg treeName] [method attr] [arg key] [option -nodes] [arg list]] +[call [arg treeName] [method attr] [arg key] [option -glob] [arg globpattern]] +[call [arg treeName] [method attr] [arg key] [option -regexp] [arg repattern]] + +This method retrieves the value of the attribute named [arg key], for +all nodes in the tree (matching the restriction specified via one of +the possible options) and having the specified attribute. + +[para] + +The result is a dictionary mapping from node names to the value of +attribute [arg key] at that node. + +Nodes not having the attribute [arg key], or not passing a +specified restriction, are not listed in the result. + +[para] + +The possible restrictions are: + +[list_begin options] +[opt_def -nodes] + +The value is a list of nodes. Only the nodes mentioned in this list +are searched for the attribute. + +[opt_def -glob] + +The value is a glob pattern. Only the nodes in the tree whose names +match this pattern are searched for the attribute. + +[opt_def -regexp] + +The value is a regular expression. Only the nodes in the tree whose +names match this pattern are searched for the attribute. + +[list_end] +[para] + +[call [arg treeName] [method children] [opt [option -all]] [arg node] [opt "[const filter] [arg cmdprefix]"]] + +Return a list of the children of [arg node]. + +If the option [option -all] is specified, then not only the direct +children, but their children, and so on are returned in the result. + +If a filter command is specified only those nodes are listed in the +final result which pass the test. The command in [arg cmdprefix] is +called with two arguments, the name of the tree object, and the name +of the node in question. It is executed in the context of the caller +and has to return a boolean value. Nodes for which the command returns +[const false] are removed from the result list before it is returned +to the caller. + +[para] +Some examples: +[para] +[example { + mytree insert root end 0 ; mytree set 0 volume 30 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + mytree insert 4 end 5 ; mytree set 5 volume 50 + mytree insert 4 end 6 + + proc vol {t n} { + $t keyexists $n volume + } + proc vgt40 {t n} { + if {![$t keyexists $n volume]} {return 0} + expr {[$t get $n volume] > 40} + } + + tclsh> lsort [mytree children -all root filter vol] + 0 5 + + tclsh> lsort [mytree children -all root filter vgt40] + 5 + + tclsh> lsort [mytree children root filter vol] + 0 + + tclsh> puts ([lsort [mytree children root filter vgt40]]) + () +}] + +[call [arg treeName] [method cut] [arg node]] + +Removes the node specified by [arg node] from the tree, but not its +children. The children of [arg node] are made children of the parent +of the [arg node], at the index at which [arg node] was located. + +[call [arg treeName] [method delete] [arg node] [opt "[arg node] ..."]] + +Removes the specified nodes from the tree. All of the nodes' children +will be removed as well to prevent orphaned nodes. + +[call [arg treeName] [method depth] [arg node]] + +Return the number of steps from node [arg node] to the root node. + +[call [arg treeName] [method descendants] [arg node] [opt "[const filter] [arg cmdprefix]"]] + +This method extends the method [method children] and returns a list +containing all nodes descending from [arg node], and passing the +filter, if such was specified. + +[para] + +This is actually the same as +"[arg treeName] [method children] [option -all]". +[method descendants] should be prefered, and "children -all" +will be deprecated sometime in the future. + +[call [arg treeName] [method deserialize] [arg serialization]] + +This is the complement to [method serialize]. It replaces tree data in +[arg treeName] with the tree described by the [arg serialization] +value. The old contents of [arg treeName] are deleted by this +operation. + +[call [arg treeName] [method destroy]] + +Destroy the tree, including its storage space and associated command. + +[call [arg treeName] [method exists] [arg node]] + +Returns true if the specified node exists in the tree. + +[call [arg treeName] [method get] [arg node] [arg key]] + +Returns the value associated with the key [arg key] for the node +[arg node]. + +[call [arg treeName] [method getall] [arg node] [opt [arg pattern]]] + +Returns a dictionary (suitable for use with [lb][cmd {array set}][rb]) +containing the attribute data for the [arg node]. + +If the glob [arg pattern] is specified only the attributes whose names +match the pattern will be part of the dictionary. + +[call [arg treeName] [method keys] [arg node] [opt [arg pattern]]] + +Returns a list of keys for the [arg node]. + +If the [arg pattern] is specified only the attributes whose names +match the pattern will be part of the returned list. The pattern is a +[cmd glob] pattern. + +[call [arg treeName] [method keyexists] [arg node] [arg key]] + +Return true if the specified [arg key] exists for the [arg node]. + +[call [arg treeName] [method index] [arg node]] + +Returns the index of [arg node] in its parent's list of children. For +example, if a node has [term nodeFoo], [term nodeBar], and + +[term nodeBaz] as children, in that order, the index of + +[term nodeBar] is 1. + +[call [arg treeName] [method insert] [arg parent] [arg index] [opt "[arg child] [opt "[arg child] ..."]"]] + +Insert one or more nodes into the tree as children of the node + +[arg parent]. The nodes will be added in the order they are given. If +[arg parent] is [const root], it refers to the root of the tree. The +new nodes will be added to the [arg parent] node's child list at the +index given by [arg index]. The [arg index] can be [const end] in +which case the new nodes will be added after the current last child. +Indices of the form "end-[var n]" are accepted as well. + +[para] + +If any of the specified children already exist in [arg treeName], +those nodes will be moved from their original location to the new +location indicated by this command. + +[para] + +If no [arg child] is specified, a single node will be added, and a +name will be generated for the new node. The generated name is of the +form [emph node][var x], where [var x] is a number. If names are +specified they must neither contain whitespace nor colons (":"). + +[para] + +The return result from this command is a list of nodes added. + +[call [arg treeName] [method isleaf] [arg node]] + +Returns true if [arg node] is a leaf of the tree (if [arg node] has no +children), false otherwise. + +[call [arg treeName] [method lappend] [arg node] [arg key] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg node]. Returns the new value given to the +attribute [arg key]. + +[call [arg treeName] [method leaves]] + +Return a list containing all leaf nodes known to the tree. + +[call [arg treeName] [method move] [arg parent] [arg index] [arg node] [opt "[arg node] ..."]] + +Make the specified nodes children of [arg parent], inserting them into +the parent's child list at the index given by [arg index]. Note that +the command will take all nodes out of the tree before inserting them +under the new parent, and that it determines the position to place +them into after the removal, before the re-insertion. This behaviour +is important when it comes to moving one or more nodes to a different +index without changing their parent node. + +[call [arg treeName] [method next] [arg node] ] + +Return the right sibling of [arg node], or the empty string if + +[arg node] was the last child of its parent. + +[call [arg treeName] [method numchildren] [arg node]] + +Return the number of immediate children of [arg node]. + +[call [arg treeName] [method nodes]] + +Return a list containing all nodes known to the tree. + +[call [arg treeName] [method parent] [arg node]] + +Return the parent of [arg node]. + +[call [arg treeName] [method previous] [arg node] ] + +Return the left sibling of [arg node], or the empty string if + +[arg node] was the first child of its parent. + +[call [arg treeName] [method rename] [arg node] [arg newname]] + +Renames the node [arg node] to [arg newname]. An error is thrown if +either the node does not exist, or a node with name [arg newname] does +exist. The result of the command is the new name of the node. + +[call [arg treeName] [method rootname]] + +Returns the name of the root node of the tree. + +[call [arg treeName] [method serialize] [opt [arg node]]] + +This method serializes the sub-tree starting at [arg node]. In other +words it returns a tcl [emph value] completely describing the tree +starting at [arg node]. + +This allows, for example, the transfer of tree objects (or parts +thereof) over arbitrary channels, persistence, etc. + +This method is also the basis for both the copy constructor and +the assignment operator. + +[para] + +The result of this method has to be semantically identical over all +implementations of the tree interface. This is what will enable us to +copy tree data between different implementations of the same +interface. + +[para] + +The result is a list containing containing a multiple of three +elements. It is like a serialized array except that there are two +values following each key. They are the names of the nodes in the +serialized tree. The two values are a reference to the parent node and +the attribute data, in this order. + +[para] + +The reference to the parent node is the empty string for the root node +of the tree. For all other nodes it is the index of the parent node in +the list. This means that they are integers, greater than or equal to +zero, less than the length of the list, and multiples of three. + +The order of the nodes in the list is important insofar as it is used +to reconstruct the lists of children for each node. The children of a +node have to be listed in the serialization in the same order as they +are listed in their parent in the tree. + +[para] + +The attribute data of a node is a dictionary, i.e. a list of even +length containing a serialized array. For a node without attribute +data the dictionary is the empty list. + +[para] + +[emph Note:] While the current implementation returns the root node as +the first element of the list, followed by its children and their +children in a depth-first traversal this is not necessarily true for +other implementations. + +The only information a reader of the serialized data can rely on for +the structure of the tree is that the root node is signaled by the +empty string for the parent reference, that all other nodes refer to +their parent through the index in the list, and that children occur in +the same order as in their parent. + +[para] +[example { + A possible serialization for the tree structure + + +- d + +- a -+ + root -+- b +- e + +- c + is + + {root {} {} a 0 {} d 3 {} e 3 {} b 0 {} c 0 {}} + + The above assumes that none of the nodes have attributes. +}] + +[call [arg treeName] [method set] [arg node] [arg key] [opt [arg value]]] + +Set or get one of the keyed values associated with a node. A node may +have any number of keyed values associated with it. If [arg value] is +not specified, this command returns the current value assigned to the +key; if [arg value] is specified, this command assigns that value to +the key, and returns it. + +[call [arg treeName] [method size] [opt [arg node]]] + +Return a count of the number of descendants of the node [arg node]; if +no node is specified, [const root] is assumed. + +[call [arg treeName] [method splice] [arg parent] [arg from] [opt [arg to]] [opt [arg child]]] + +Insert a node named [arg child] into the tree as a child of the node +[arg parent]. If [arg parent] is [const root], it refers to the root +of the tree. The new node will be added to the parent node's child +list at the index given by [arg from]. The children of [arg parent] +which are in the range of the indices [arg from] and [arg to] are made +children of [arg child]. If the value of [arg to] is not specified it +defaults to [const end]. If no name is given for [arg child], a name +will be generated for the new node. The generated name is of the form +[emph node][var x], where [var x] is a number. The return result +from this command is the name of the new node. + +[para] + +The arguments [arg from] and [arg to] are regular list indices, i.e. +the form "end-[var n]" is accepted as well. + +[call [arg treeName] [method swap] [arg node1] [arg node2]] + +Swap the position of [arg node1] and [arg node2] in the tree. + +[call [arg treeName] [method unset] [arg node] [arg key]] + +Removes a keyed value from the node [arg node]. The method will do +nothing if the [arg key] does not exist. + +[call [arg treeName] [method walk] [arg node] [opt "[option -order] [arg order]"] [opt "[option -type] [arg type]"] [arg loopvar] [arg script]] + +Perform a breadth-first or depth-first walk of the tree starting at +the node [arg node]. The type of walk, breadth-first or depth-first, +is determined by the value of [arg type]; [const bfs] indicates +breadth-first, [const dfs] indicates depth-first. Depth-first is the +default. The order of the walk, pre-, post-, both- or in-order is +determined by the value of [arg order]; [const pre] indicates +pre-order, [const post] indicates post-order, [const both] indicates +both-order and [const in] indicates in-order. Pre-order is the +default. + +[para] + +Pre-order walking means that a parent node is visited before any of +its children. For example, a breadth-first search starting from the +root will visit the root, followed by all of the root's children, +followed by all of the root's grandchildren. Post-order walking means +that a parent node is visited after any of its children. Both-order +walking means that a parent node is visited before [emph and] after +any of its children. In-order walking means that a parent node is +visited after its first child and before the second. This is a +generalization of in-order walking for binary trees and will do the +right thing if a binary tree is walked. The combination of a breadth-first +walk with in-order is illegal. + +[para] + +As the walk progresses, the [arg script] will be evaluated at each +node. The evaluation takes place in the context of the caller of the +method. + +Regarding loop variables, these are listed in [arg loopvar]. If one +only one variable is specified it will be set to the id of the +node. When two variables are specified, i.e. [arg loopvar] is a true +list, then the first variable will be set to the action performed at +the node, and the other to the id of the node itself. + +All loop variables are created in the context of the caller. + +[para] + +There are three possible actions: [const enter], [const leave], +or [const visit]. [const enter] actions occur during pre-order +walks; [const leave] actions occur during post-order walks; + +[const visit] actions occur during in-order walks. In a both-order +walk, the command will be evaluated twice for each node; the action is +[const enter] for the first evaluation, and [const leave] for the +second. + +[para] + +[emph Note]: The [const enter] action for a node is always performed +before the walker will look at the children of that node. This means +that changes made by the [arg script] to the children of the node +will immediately influence the walker and the steps it will take. + +[para] + +Any other manipulation, for example of nodes higher in the tree (i.e +already visited), or upon leaving will have undefined results. They +may succeed, error out, silently compute the wrong result, or anything +in between. + +[para] + +At last a small table showing the relationship between the various +options and the possible actions. + +[para] +[example { + order type actions notes + ----- ---- ----- ----- + pre dfs enter parent before children + post dfs leave parent after children + in dfs visit parent between first and second child. + both dfs enter, leave parent before and after children + ----- ---- ----- ----- + pre bfs enter parent before children + post bfs leave parent after children + in bfs -- illegal -- + both bfs enter, leave parent before and after children + ----- ---- ----- ----- +}] + +[para] + +Note the command [cmd ::struct::tree::prune]. This command can be used +in the walk script to force the command to ignore the children of the +node we are currently at. It will throw an error if the order of +traversal is either [const post] or [const in] as these modes visit +the children before their parent, making pruning non-sensical. + +[call [arg treeName] [method walkproc] [arg node] [opt "[option -order] [arg order]"] [opt "[option -type] [arg type]"] [arg cmdprefix]] + +This method is like method [method walk] in all essentials, except the +interface to the user code. This method invokes a command prefix with +three additional arguments (tree, node, and action), instead of +evaluating a script and passing the node via a loop variable. + +[list_end] + +[subsection {Changes for 2.0}] + +The following noteworthy changes have occurred: + +[list_begin enumerated] +[enum] + +The API for accessing attributes and their values has been +simplified. + +[para] + +All functionality regarding the default attribute "data" has been +removed. This default attribute does not exist anymore. All accesses +to attributes have to specify the name of the attribute in +question. This backward [emph incompatible] change allowed us to +simplify the signature of all methods handling attributes. + +[para] + +Especially the flag [option -key] is not required anymore, even more, +its use is now forbidden. Please read the documentation for the +methods [method set], [method get], [method getall], [method unset], +[method append], [method lappend], [method keyexists] + +and [method keys] for a description of the new API's. + +[enum] + +The methods [method keys] and [method getall] now take an optional +pattern argument and will return only attribute data for keys matching +this pattern. + +[enum] + +Nodes can now be renamed. See the documentation for the method +[method rename]. + +[enum] + +The structure has been extended with API's for the serialization and +deserialization of tree objects, and a number of operations based on +them (tree assignment, copy construction). + +[para] + +Please read the documentation for the methods [method serialize], +[method deserialize], [method =], and [method -->], and the +documentation on the construction of tree objects. + +[para] + +Beyond the copying of whole tree objects these new API's also enable +the transfer of tree objects over arbitrary channels and for easy +persistence. + +[enum] + +The walker API has been streamlined and made more similar to the +command [cmd foreach]. In detail: + +[list_begin itemized] + +[item] + +The superfluous option [option -command] has been removed. + +[item] + +Ditto for the place holders. Instead of the placeholders two loop +variables have to be specified to contain node and action information. + +[item] + +The old command argument has been documented as a script now, which it +was in the past too. + +[item] + +The fact that [const enter] actions are called before the walker looks +at the children of a node has been documented now. In other words it +is now officially allowed to manipulate the list of children for a +node under [emph these] circumstances. It has been made clear that +changes under any other circumstances will have undefined results, +from silently computing the wrong result to erroring out. + +[list_end] + +[enum] + +A new method, [method attr], was added allowing the query and +retrieval of attribute data without regard to the node relationship. + +[enum] + +The method [method children] has been extended with the ability to +select from the children of the node based on an arbitrary filtering +criterium. Another extension is the ability to look not only at the +immediate children of the node, but the whole tree below it. + +[list_end] + +[section EXAMPLES] + +The following example demonstrates the creation of new nodes: + +[example { + mytree insert root end 0 ; # Create node 0, as child of the root + mytree insert root end 1 2 ; # Ditto nodes 1 & 2 + mytree insert 0 end 3 ; # Now create node 3 as child of node 0 + mytree insert 0 end ; # Create another child of 0, with a + # generated name. The name is returned + # as the result of the command. +}] + +[vset CATEGORY {struct :: tree}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/struct_tree1.man b/tcllib/modules/struct/struct_tree1.man new file mode 100644 index 0000000..0839dfc --- /dev/null +++ b/tcllib/modules/struct/struct_tree1.man @@ -0,0 +1,292 @@ +[comment {-*- tcl -*-}] +[manpage_begin {struct::tree_v1} n 1.2.2] +[keywords tree] +[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Tcl Data Structures}] +[titledesc {Create and manipulate tree objects}] +[category {Data structures}] +[require Tcl 8.2] +[require struct::tree [opt 1.2.2]] +[description] +[para] + +The [cmd ::struct::tree] command creates a new tree object with an +associated global Tcl command whose name is [arg treeName]. This +command may be used to invoke various operations on the tree. It has +the following general form: + +[list_begin definitions] +[call [cmd treeName] [method option] [opt [arg "arg arg ..."]]] + +[arg Option] and the [arg arg]s determine the exact behavior of the +command. + +[list_end] + +[para] + +A tree is a collection of named elements, called nodes, one of which is +distinguished as a root, along with a relation ("parenthood") that +places a hierarchical structure on the nodes. (Data Structures and +Algorithms; Aho, Hopcroft and Ullman; Addison-Wesley, 1987). In +addition to maintaining the node relationships, this tree +implementation allows any number of keyed values to be associated with +each node. + +[para] + +The element names can be arbitrary strings. + +[para][comment {This comparison (C) 2007 Lars Bergstrom, Bug 1687902}] + +A tree is thus similar to an array, but with three important +differences: + +[list_begin enumerated] +[enum] Trees are accessed through an object command, whereas arrays are +accessed as variables. (This means trees cannot be local to a procedure.) + +[enum] Trees have a hierarchical structure, whereas an array is just an +unordered collection. + +[enum] Each node of a tree has a separate collection of attributes and +values. This is like an array where every value is a dictionary. + +[list_end] + +[para] + +The following commands are possible for tree objects: + +[list_begin definitions] + +[call [arg treeName] [method append] [arg node] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] to one of the keyed values associated with an +node. If no [arg key] is specified, the key [const data] is assumed. + +[call [arg treeName] [method children] [arg node]] + +Return a list of the children of [arg node]. + +[call [arg treeName] [method cut] [arg node]] + +Removes the node specified by [arg node] from the tree, but not its +children. The children of [arg node] are made children of the parent +of the [arg node], at the index at which [arg node] was located. + +[call [arg treeName] [method delete] [arg node] [opt "[arg node] ..."]] + +Removes the specified nodes from the tree. All of the nodes' children +will be removed as well to prevent orphaned nodes. + +[call [arg treeName] [method depth] [arg node]] + +Return the number of steps from node [arg node] to the root node. + +[call [arg treeName] [method destroy]] + +Destroy the tree, including its storage space and associated command. + +[call [arg treeName] [method exists] [arg node]] + +Returns true if the specified node exists in the tree. + +[call [arg treeName] [method get] [arg node] [opt "[option -key] [arg key]"]] + +Return the value associated with the key [arg key] for the node + +[arg node]. If no key is specified, the key [const data] is assumed. + +[call [arg treeName] [method getall] [arg node]] + +Returns a serialized list of key/value pairs (suitable for use with +[lb][cmd {array set}][rb]) for the [arg node]. + +[call [arg treeName] [method keys] [arg node]] + +Returns a list of keys for the [arg node]. + +[call [arg treeName] [method keyexists] [arg node] [opt "-key [arg key]"]] + +Return true if the specified [arg key] exists for the [arg node]. If +no [arg key] is specified, the key [const data] is assumed. + +[call [arg treeName] [method index] [arg node]] + +Returns the index of [arg node] in its parent's list of children. For +example, if a node has [term nodeFoo], [term nodeBar], and + +[term nodeBaz] as children, in that order, the index of + +[term nodeBar] is 1. + +[call [arg treeName] [method insert] [arg parent] [arg index] [opt "[arg child] [opt "[arg child] ..."]"]] + +Insert one or more nodes into the tree as children of the node + +[arg parent]. The nodes will be added in the order they are given. If +[arg parent] is [const root], it refers to the root of the tree. The +new nodes will be added to the [arg parent] node's child list at the +index given by [arg index]. The [arg index] can be [const end] in +which case the new nodes will be added after the current last child. + +[para] + +If any of the specified children already exist in [arg treeName], +those nodes will be moved from their original location to the new +location indicated by this command. + +[para] + +If no [arg child] is specified, a single node will be added, and a +name will be generated for the new node. The generated name is of the +form [emph node][var x], where [var x] is a number. If names are +specified they must neither contain whitespace nor colons (":"). + +[para] + +The return result from this command is a list of nodes added. + +[call [arg treeName] [method isleaf] [arg node]] + +Returns true if [arg node] is a leaf of the tree (if [arg node] has no +children), false otherwise. + +[call [arg treeName] [method lappend] [arg node] [opt "-key [arg key]"] [arg value]] + +Appends a [arg value] (as a list) to one of the keyed values +associated with an [arg node]. If no [arg key] is specified, the key +[const data] is assumed. + +[call [arg treeName] [method move] [arg parent] [arg index] [arg node] [opt "[arg node] ..."]] + +Make the specified nodes children of [arg parent], inserting them into +the parent's child list at the index given by [arg index]. Note that +the command will take all nodes out of the tree before inserting them +under the new parent, and that it determines the position to place +them into after the removal, before the re-insertion. This behaviour +is important when it comes to moving one or more nodes to a different +index without changing their parent node. + +[call [arg treeName] [method next] [arg node] ] + +Return the right sibling of [arg node], or the empty string if + +[arg node] was the last child of its parent. + +[call [arg treeName] [method numchildren] [arg node]] + +Return the number of immediate children of [arg node]. + +[call [arg treeName] [method parent] [arg node]] + +Return the parent of [arg node]. + +[call [arg treeName] [method previous] [arg node] ] + +Return the left sibling of [arg node], or the empty string if + +[arg node] was the first child of its parent. + +[call [arg treeName] [method set] [arg node] [opt "[option -key] [arg key]"] [opt [arg value]]] + +Set or get one of the keyed values associated with a node. If no key +is specified, the key [const data] is assumed. Each node that is +added to a tree has the value "" assigned to the key [const data] +automatically. A node may have any number of keyed values associated +with it. If [arg value] is not specified, this command returns the +current value assigned to the key; if [arg value] is specified, this +command assigns that value to the key. + +[call [arg treeName] [method size] [opt [arg node]]] + +Return a count of the number of descendants of the node [arg node]; if +no node is specified, [const root] is assumed. + +[call [arg treeName] [method splice] [arg parent] [arg from] [opt [arg to]] [opt [arg child]]] + +Insert a node named [arg child] into the tree as a child of the node +[arg parent]. If [arg parent] is [const root], it refers to the root +of the tree. The new node will be added to the parent node's child +list at the index given by [arg from]. The children of [arg parent] +which are in the range of the indices [arg from] and [arg to] are made +children of [arg child]. If the value of [arg to] is not specified it +defaults to [const end]. If no name is given for [arg child], a name +will be generated for the new node. The generated name is of the form +[emph node][var x], where [var x] is a number. The return result +from this command is the name of the new node. + +[call [arg treeName] [method swap] [arg node1] [arg node2]] + +Swap the position of [arg node1] and [arg node2] in the tree. + +[call [arg treeName] [method unset] [arg node] [opt "[option -key] [arg key]"]] + +Removes a keyed value from the node [arg node]. If no key is +specified, the key [const data] is assumed. + +[call [arg treeName] [method walk] [arg node] [opt "[option -order] [arg order]"] [opt "[option -type] [arg type]"] [option -command] [arg cmd]] + +Perform a breadth-first or depth-first walk of the tree starting at +the node [arg node]. The type of walk, breadth-first or depth-first, +is determined by the value of [arg type]; [const bfs] indicates +breadth-first, [const dfs] indicates depth-first. Depth-first is the +default. The order of the walk, pre-, post-, both- or in-order is +determined by the value of [arg order]; [const pre] indicates +pre-order, [const post] indicates post-order, [const both] indicates +both-order and [const in] indicates in-order. Pre-order is the +default. + +[para] + +Pre-order walking means that a parent node is visited before any of +its children. For example, a breadth-first search starting from the +root will visit the root, followed by all of the root's children, +followed by all of the root's grandchildren. Post-order walking means +that a parent node is visited after any of its children. Both-order +walking means that a parent node is visited before [emph and] after +any of its children. In-order walking means that a parent node is +visited after its first child and before the second. This is a +generalization of in-order walking for binary trees and will do the +right thing if a binary is walked. The combination of a breadth-first +walk with in-order is illegal. + +[para] + +As the walk progresses, the command [arg cmd] will be evaluated at +each node. Percent substitution will be performed on [arg cmd] before +evaluation, just as in a [cmd bind] script. The following +substitutions are recognized: + +[list_begin definitions] + +[def [const %%]] + +Insert the literal % character. + +[def [const %t]] + +Name of the tree object. + +[def [const %n]] + +Name of the current node. + +[def [const %a]] + +Name of the action occurring; one of [const enter], [const leave], +or [const visit]. [const enter] actions occur during pre-order +walks; [const leave] actions occur during post-order walks; + +[const visit] actions occur during in-order walks. In a both-order +walk, the command will be evaluated twice for each node; the action is +[const enter] for the first evaluation, and [const leave] for the +second. + +[list_end] +[list_end] + +[vset CATEGORY {struct :: tree}] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/struct/tree.bench b/tcllib/modules/struct/tree.bench new file mode 100644 index 0000000..00ca6b8 --- /dev/null +++ b/tcllib/modules/struct/tree.bench @@ -0,0 +1,548 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'struct::tree' +# data structure to allow developers to monitor package performance. +# +# (c) 2003 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + +# We need at least version 8.2 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.2]} { + return +} + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +set moddir [file dirname [file dirname [info script]]] +lappend auto_path $moddir + +package forget cmdline +catch {namespace delete ::cmdline} +source [file join $moddir cmdline cmdline.tcl] + +package forget struct::list +catch {namespace delete ::struct::list} +source [file join [file dirname [info script]] list.tcl] + +package forget struct::tree +catch {namespace delete ::struct::tree} +source [file join [file dirname [info script]] tree.tcl] + +namespace import struct::tree + +set code tcl +if {![catch {package present tcllibc}]} { + set code {C } +} +#set code $struct::tree::loaded +#set code $auto_path + +proc makeNcmd {n} { + return [linsert [struct::list iota $n] 0 t insert root end] +} + +proc makeN {n} { + tree t + eval [makeNcmd $n] + return +} + +proc makeChainN {n} { + tree t + set p root + for {set i 0} {$i < $n} {incr i} { + set p [t insert $p end $i] + } + return $p +} + +proc makeAttr {n} { + tree t + for {set i 0} {$i < $n} {incr i} { + t set root $i . + } + return +} + + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +# Tree operations fall into four distinctive classes, described +# below. Each have different expected performance characteristics. The +# benchmarks indicate the class of the tested operation in their +# description. + +# [Ns] - At a single node +# Computes data relevant to or associated with a single +# node. They are expected to run in constant time. +# +# For some this is something we have to check, as a bad +# implementation may actually cause its performance to match +# operations in [Ne]. +# +# [N+] - At a single node, needing data from either or below +# Similar to Ns, however to compute the result data from either +# children or ancestors is required. They are expected to have +# linear performance in general, across some parameter. Examples +# of such parameters are: Depth of node in the tree, number of +# (in)direct children, etc. +# +# They may have constant performance if the implementation +# takes measures like caching of results, or using special +# algorithms. The effectiveness of such measures may be limited +# to unchanging trees. I.e. changing the structure of the tree +# may invalidate cached data, forcing costly recomputation. +# +# [Tr] - Over the whole tree +# +# These operations have to access the whole tree to compute +# their result, making them linear in the size of the tree in +# general. Only caching may yield better performance, however +# only for unchanging trees. +# +# [Mo] - Structure modifiers +# +# These operations change the tree, making them difficult to +# measure as they are not idempotent like the operations in all +# the other classes. Their performance is dependent on internal +# data structures and memory allocation strategies. Dependence +# on data structures implies that use of structures optimized +# for the three preceding classes can affect the modifiers +# negatively. + +# **Note ** +# At least the critcl implementation caches some of the structural +# information when computed (depth, height, size), and invalidates it +# after changes to the tree structure. The */redo benchmarks use a +# small operation (swap of two independent nodes) to perturb the cache +# and force recomputation of the data every time. The comparison to +# the equivalent non-redo benchmark gives us a best-to-worst estimate +# of the effect the cache has. + +# ### ### ### ######### ######### ######### ########################### +## [Ns] + +bench -desc "\[Ns\] tree exists ok" -pre { + tree t +} -body { + t exists root +} -post { + t destroy +} + +bench -desc "\[Ns\] tree exists miss" -pre { + tree t +} -body { + t exists miss +} -post { + t destroy +} + +# Navigation - Parent, Left/Right sibling + +bench -desc "\[Ns\] tree parent" -pre { + tree t + t insert root end 0 +} -body { + t parent 0 +} -post { + t destroy +} + +bench -desc "\[Ns\] tree next" -pre { + tree t + t insert root end 0 +} -body { + t next 0 +} -post { + t destroy +} + +bench -desc "\[Ns\] tree previous" -pre { + tree t + t insert root end 0 +} -body { + t previous 0 +} -post { + t destroy +} + +bench -desc "\[Ns\] tree isleaf" -pre { + tree t + t insert root end 0 +} -body { + t isleaf 0 +} -post { + t destroy +} + +bench -desc "\[Ns\] tree index" -pre { + tree t + t insert root end 0 +} -body { + t index 0 +} -post { + t destroy +} + +bench -desc "\[Ns\] tree rootname" -pre { + tree t +} -body { + t rootname +} -post { + t destroy +} + +foreach n {1 10 100 1000 10000} { + bench -desc "\[Ns\] tree numchildren $n" -pre { + makeN $n + } -body { + t numchildren root + } -post { + t destroy + } +} + +foreach n {1 10 100 1000 10000} { + bench -desc "\[Ns\] tree getall $n" -pre { + makeAttr $n + } -body { + t getall root + } -post { + t destroy + } + + bench -desc "\[Ns\] tree keys $n" -pre { + makeAttr $n + } -body { + t keys root + } -post { + t destroy + } + + bench -desc "\[Ns\] tree set $n" -pre { + makeAttr $n + } -body { + t set root attr test + } -post { + t destroy + } + + bench -desc "\[Ns\] tree get $n" -pre { + makeAttr $n + t set root attr . + } -body { + t get root attr + } -post { + t destroy + } + + bench -desc "\[Ns\] tree keyexists miss $n" -pre { + makeAttr $n + } -body { + t keyexists root attr + } -post { + t destroy + } + + bench -desc "\[Ns\] tree keyexists has $n" -pre { + makeAttr $n + t set root attr . + } -body { + t keyexists root attr + } -post { + t destroy + } +} + +# ### ### ### ######### ######### ######### ########################### +## [Ne] + +foreach n {1 10 100 1000 10000} { + # Notes on results: + # - Tcl implementation of 'children' is basically constant. + # It simply has to return an already constructed list. + # + # - The critcl implementation currently has to generate a Tcl_Obj + # from the internal node array, and is thus linear. + # + # Break even for Tcl happens somewhere after 1000 nodes. I.e from + # then on the C impl. is slower. + + bench -desc "\[Ne\] tree children $n" -pre { + makeN $n + } -body { + t children root + } -post { + t destroy + } +} + +foreach n {1 10 100 1000 10000} { + # root size is trivial + bench -desc "\[Ne\] tree size root $n" -pre { + makeChainN $n + } -body { + t size root + } -post { + t destroy + } -post { + t destroy + } + + # non-root size requires descendants + bench -desc "\[Ne\] tree size any $n" -pre { + makeChainN $n + } -body { + t size 0 + } -post { + t destroy + } -post { + t destroy + } + + bench -desc "\[Ne\] tree size/redo root $n" -pre { + makeChainN $n + t insert root end a b + } -body { + t swap a b ; t size root + } -post { + t destroy + } -post { + t destroy + } + + # non-root size requires descendants + bench -desc "\[Ne\] tree size/redo any $n" -pre { + makeChainN $n + t insert root end a b + } -body { + t swap a b ; t size 0 + } -post { + t destroy + } -post { + t destroy + } + + bench -desc "\[Ne\] tree ancestors $n" -pre { + set p [makeChainN $n] + } -body { + t ancestors $p + } -post { + t destroy + } + + bench -desc "\[Ne\] tree depth $n" -pre { + set p [makeChainN $n] + } -body { + t depth $p + } -post { + t destroy + } + + bench -desc "\[Ne\] tree depth/redo $n" -pre { + set p [makeChainN $n] + t insert root end a b + } -body { + t swap a b ; t depth $p + } -post { + t destroy + } +} + +foreach n {1 10 100 1000} { + bench -desc "\[Ne\] tree descendants $n" -pre { + makeChainN $n + } -body { + t descendants root + } -post { + t destroy + } + + bench -desc "\[Ne\] tree children -all $n" -pre { + makeN $n + } -body { + t children -all root + } -post { + t destroy + } +} + +foreach n {1 10 100 1000} { + bench -desc "\[Ne\] tree height $n" -pre { + makeChainN $n + } -body { + t height root + } -post { + t destroy + } + + bench -desc "\[Ne\] tree height/redo $n" -pre { + makeChainN $n + t insert root end a b + } -body { + t swap a b ; t height root + } -post { + t destroy + } +} + +# ### ### ### ######### ######### ######### ########################### +## [Tr] + +foreach n {1 10 100 1000 10000} { + bench -desc "\[Tr\] tree nodes $n" -pre { + makeN $n + } -body { + t nodes + } -post { + t destroy + } + + bench -desc "\[Tr\] tree leaves $n" -pre { + makeN $n + } -body { + t leaves + } -post { + t destroy + } +} + +foreach n {1 10 100 1000} { + bench -desc "\[Tr\] tree serialize flat $n" -pre { + makeN $n + } -body { + t serialize + } -post { + t destroy + } + + bench -desc "\[Tr\] tree deserialize flat $n" -pre { + makeN $n + set v [t serialize] + } -body { + t deserialize $v + } -post { + t destroy + } +} + +foreach n {1 10 100 1000} { + bench -desc "\[Tr\] tree serialize deep $n" -pre { + makeChainN $n + } -body { + t serialize + } -post { + t destroy + } + + bench -desc "\[Tr\] tree deserialize deep $n" -pre { + makeChainN $n + set v [t serialize] + } -body { + t deserialize $v + } -post { + t destroy + } +} + +# ### ### ### ######### ######### ######### ########################### +## [Mo] + +bench -desc "\[Mo\] tree create/destroy" -body { + [tree] destroy +} + +bench -desc "\[Mo\] tree swap" -pre { + tree t ; t insert root end 0 1 +} -body { + t swap 0 1 +} -post { + t destroy +} + +foreach n {1 10 100 1000} { + # Note: We precompute a command which inserts n + # nodes into the root, instead of doing the loop + # as part of the benchmark. I.e. the only loop is + # in the implementation of tree. + + bench -desc "\[Mo\] tree create/destroy $n" -pre { + set cmd [makeNcmd $n] + } -body { + tree t ; eval $cmd ; t destroy + } +} + +foreach n {1 10 100 1000 10000} { + # Note: the -iter argument. + # We add a node n times, one per iteration, and + # then see how much the operation took on average. + # In a C implementation this exercises the re- + # allocation code and strategy. + # + # A different way would be to insert n nodes once. This + # is actually done in the create/destroy benchmarks. This + # exercises the internal node insertion loop instead. + + bench -desc "\[Mo\] tree insert end $n" -pre { + tree t + } -body { + t insert root end + } -post { + t destroy + } -iter $n + + bench -desc "\[Mo\] tree insert front $n" -pre { + tree t + } -body { + t insert root 0 + } -post { + t destroy + } -iter $n + + bench -desc "\[Mo\] tree insert middle1 $n" -pre { + tree t ; t insert root end 0 1 2 3 4 + } -body { + t insert root 5 + } -post { + t destroy + } -iter $n + + bench -desc "\[Mo\] tree insert middle2 $n" -pre { + tree t ; t insert root end 0 1 2 3 4 + } -body { + t insert root end-5 + } -post { + t destroy + } -iter $n +} + +# ### ### ### ######### ######### ######### ########################### +## Complete + +return + +# ### ### ### ######### ######### ######### ########################### +## Notes ... + +# :=, -->, = +# +# attr - filtered attr over all nodes +# +# walk, walkproc +# +# attr modifiers - append, lappend, unset +# modifiers - cut, delete, move, rename, splice, swap (insert) + +# Notes on optimizations we can do. +# +# Tcl - Cache structural data - depth, ancestors ... +# C - Cache results, like child lists (Tcl_Obj's!) +# Maybe use Tcl_Obj/List for child arrays instead +# of N* ? Effect on modification performance ? diff --git a/tcllib/modules/struct/tree.tcl b/tcllib/modules/struct/tree.tcl new file mode 100644 index 0000000..d3430f4 --- /dev/null +++ b/tcllib/modules/struct/tree.tcl @@ -0,0 +1,183 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree.tcl,v 1.45 2009/06/22 18:21:59 andreas_kupries Exp $ + +# @mdgen EXCLUDE: tree_c.tcl + +package require Tcl 8.2 +package require struct::list + +namespace eval ::struct::tree {} + +# ### ### ### ######### ######### ######### +## Management of tree implementations. + +# ::struct::tree::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::tree::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of tree requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::tree_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir tree_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::tree::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::tree::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::tree ::struct::tree_$loaded + rename ::struct::tree::prune ::struct::tree::prune_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::tree_$key ::struct::tree + rename ::struct::tree::prune_$key ::struct::tree::prune + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::tree::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::tree::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::tree::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::tree::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::tree::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::tree { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::tree { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export tree +} + +package provide struct::tree 2.1.2 diff --git a/tcllib/modules/struct/tree.test b/tcllib/modules/struct/tree.test new file mode 100644 index 0000000..3a23d01 --- /dev/null +++ b/tcllib/modules/struct/tree.test @@ -0,0 +1,73 @@ +# tree.test: tests for the tree structure. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: tree.test,v 1.46 2007/04/12 03:01:54 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +support { + useLocal list.tcl struct::list + useLocalFile tree/tests/Xsupport +} +testing { + useAccel [useTcllibC] struct/tree.tcl struct::tree + TestAccelInit struct::tree +} + +#---------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in tree.testsuite) can expect from the environment. + +TestAccelDo struct::tree impl { + namespace import -force struct::tree + + switch -exact -- $impl { + critcl { + set MY mytree + + proc tmWrong {m loarg n {xarg {}}} { + return [tcltest::wrongNumArgs "mytree $m" $loarg $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + return [tcltest::tooManyArgs "mytree $m" $loarg] + } + } + tcl { + set MY ::mytree + + proc tmWrong {m loarg n {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + incr n + return [tcltest::wrongNumArgs "::struct::tree::_$m" "name$xarg" $n] + } + + proc tmTooMany {m loarg {xarg {}}} { + if {$xarg == {}} {set xarg $loarg} + if {$xarg != {}} {set xarg " $xarg"} + return [tcltest::tooManyArgs "::struct::tree::_$m" "name$xarg"] + } + } + } + + source [localPath tree.testsuite] +} + +#---------------------------------------------------------------------- +TestAccelExit struct::tree +testsuiteCleanup diff --git a/tcllib/modules/struct/tree.testsuite b/tcllib/modules/struct/tree.testsuite new file mode 100644 index 0000000..8422150 --- /dev/null +++ b/tcllib/modules/struct/tree.testsuite @@ -0,0 +1,3811 @@ +# tree.test: tests for the tree structure. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2000-2008 by Andreas Kupries +# All rights reserved. +# +# RCS: @(#) $Id: tree.testsuite,v 1.9 2009/09/24 22:22:28 andreas_kupries Exp $ + +::tcltest::testConstraint tree_critcl [string equal $impl critcl] + +############################################################ +# I. Tree object construction and destruction ... +############################################################ + +test tree-${impl}-1.1 {tree errors} { + tree mytree + catch {tree mytree} msg + mytree destroy + set msg +} {command "::mytree" already exists, unable to create tree} + +test tree-${impl}-1.2 {tree errors} { + tree mytree + catch {mytree} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY option ?arg arg ...?\"" + +test tree-${impl}-1.3 {tree errors} { + tree mytree + catch {mytree foo} msg + mytree destroy + set msg +} {bad option "foo": must be -->, =, ancestors, append, attr, children, cut, delete, depth, descendants, deserialize, destroy, exists, get, getall, height, index, insert, isleaf, keyexists, keys, lappend, leaves, move, next, nodes, numchildren, parent, previous, rename, rootname, serialize, set, size, splice, swap, unset, walk, or walkproc} + +test tree-${impl}-1.4 {tree errors} { + catch {tree set} msg + set msg +} {command "::set" already exists, unable to create tree} + +test tree-${impl}-1.5 {tree construction errors} { + catch {tree mytree foo} msg + set msg +} {wrong # args: should be "tree ?name ?=|:=|as|deserialize source??"} + +test tree-${impl}-1.6 {tree construction errors} { + catch {tree mytree foo far} msg + set msg +} {wrong # args: should be "tree ?name ?=|:=|as|deserialize source??"} + +# Copy constructor errors are tested as part of 'deserialize'. +# See 5.5.x at the bottom. + +test tree-${impl}-1.7 {create} { + tree mytree + set result [string equal [info commands ::mytree] "::mytree"] + mytree destroy + set result +} 1 +test tree-${impl}-1.8 {create} { + set name [tree] + set result [list \ + [regexp {^::tree\d+$} $name] \ + [string equal [info commands $name] "$name"]] + $name destroy + set result +} {1 1} + +test tree-${impl}-1.9 {destroy} { + tree mytree + mytree destroy + string equal [info commands ::mytree] "" +} 1 + +############################################################ +# II. Node attributes ... +# - set, append, lappend +# - get, getall +# - unset +# - keys, keyexists +# +# All operations on the root node, there is no +# special case to think about. +############################################################ + +############################################################ + +test tree-${impl}-2.1.1 {set, wrong # args} { + tree mytree + catch {mytree set root data foo far} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY set node key ?value?\"" + +test tree-${impl}-2.1.2 {set gives error on bogus node} { + tree mytree + catch {mytree set snarf data} msg + mytree destroy + set msg +} "node \"snarf\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.1.3 {set retrieves and/or sets value} { + tree mytree + mytree set root baz foobar + set result [mytree set root baz] + mytree destroy + set result +} foobar + +test tree-${impl}-2.1.4 {set with bad key gives error} { + tree mytree + catch {mytree set root foo} msg + mytree destroy + set msg +} {invalid key "foo" for node "root"} + +test tree-${impl}-2.1.5 {set with bad key gives error} { + tree mytree + mytree set root data "" + catch {mytree set root foo} msg + mytree destroy + set msg +} {invalid key "foo" for node "root"} + +############################################################ + +test tree-${impl}-2.2.1 {append with too many args gives error} { + tree mytree + catch {mytree append root foo bar baz boo} msg + mytree destroy + set msg +} [tmTooMany append {node key value}] + +test tree-${impl}-2.2.2 {append gives error on bogus node} { + tree mytree + catch {mytree append {IT::EM 0} data foo} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.2.3 {append creates missing attribute} { + tree mytree + set result [list] + lappend result [mytree keyexists root data] + lappend result [mytree append root data bar] + lappend result [mytree keyexists root data] + lappend result [mytree get root data] + mytree destroy + set result +} {0 bar 1 bar} + +test tree-${impl}-2.2.4 {append appends to attribute value} { + tree mytree + set result [list] + lappend result [mytree set root data foo] + lappend result [mytree append root data bar] + lappend result [mytree get root data] + mytree destroy + set result +} {foo foobar foobar} + +############################################################ + +test tree-${impl}-2.3.1 {lappend with too many args gives error} { + tree mytree + catch {mytree lappend root foo bar baz boo} msg + mytree destroy + set msg +} [tmTooMany lappend {node key value}] + +test tree-${impl}-2.3.2 {lappend gives error on bogus node} { + tree mytree + catch {mytree lappend {IT::EM 0} data foo} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.3.3 {lappend creates missing attribute} { + tree mytree + set result [list] + lappend result [mytree keyexists root data] + lappend result [mytree lappend root data bar] + lappend result [mytree keyexists root data] + lappend result [mytree get root data] + mytree destroy + set result +} {0 bar 1 bar} + +test tree-${impl}-2.3.4 {lappend appends to attribute value} { + tree mytree + set result [list] + lappend result [mytree set root data foo] + lappend result [mytree lappend root data bar] + lappend result [mytree get root data] + mytree destroy + set result +} {foo {foo bar} {foo bar}} + +############################################################ + +test tree-${impl}-2.4.1 {get gives error on bogus node} { + tree mytree + catch {mytree get {IT::EM 0} data} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.4.2 {get gives error on bogus key} { + tree mytree + catch {mytree get root bogus} msg + mytree destroy + set msg +} {invalid key "bogus" for node "root"} + +test tree-${impl}-2.4.3 {get gives error on bogus key} { + tree mytree + mytree set root foo far + catch {mytree get root bogus} msg + mytree destroy + set msg +} {invalid key "bogus" for node "root"} + +test tree-${impl}-2.4.4 {get} { + tree mytree + mytree set root boom foobar + set result [mytree get root boom] + mytree destroy + set result +} foobar + +############################################################ + +test tree-${impl}-2.5.1 {getall, wrong # args} { + tree mytree + catch {mytree getall root data foo} msg + mytree destroy + set msg +} [tmTooMany getall {node ?pattern?}] + +test tree-${impl}-2.5.2 {getall gives error on bogus node} { + tree mytree + catch {mytree getall {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.5.3 {getall without attributes returns empty string} { + tree mytree + set results [mytree getall root] + mytree destroy + set results +} {} + +test tree-${impl}-2.5.4 {getall returns dictionary} { + tree mytree + mytree set root data foobar + mytree set root other thing + set results [dictsort [mytree getall root]] + mytree destroy + set results +} {data foobar other thing} + +test tree-${impl}-2.5.5 {getall matches key pattern} { + tree mytree + mytree set root data foobar + mytree set root other thing + set results [dictsort [mytree getall root d*]] + mytree destroy + set results +} {data foobar} + +############################################################ + +test tree-${impl}-2.6.1 {unset, wrong # args} { + tree mytree + catch {mytree unset root flaboozle foobar} msg + mytree destroy + set msg +} [tmTooMany unset {node key}] + +test tree-${impl}-2.6.2 {unset gives error on bogus node} { + tree mytree + catch {mytree unset {IT::EM 0} data} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.6.3 {unset does not give error on bogus key} { + tree mytree + set result [catch {mytree unset root bogus}] + mytree destroy + set result +} 0 + +test tree-${impl}-2.6.4 {unset does not give error on bogus key} { + tree mytree + mytree set root foo "" + set result [catch {mytree unset root bogus}] + mytree destroy + set result +} 0 + +test tree-${impl}-2.6.5 {unset removes attribute from node} { + tree mytree + set result [list] + lappend result [mytree keyexists root foobar] + mytree set root foobar foobar + lappend result [mytree keyexists root foobar] + mytree unset root foobar + lappend result [mytree keyexists root foobar] + mytree destroy + set result +} {0 1 0} + +test tree-${impl}-2.6.6 {unset followed by node delete} { + tree mytree + set result [list] + set n [mytree insert root end] + mytree set $n foo bar + mytree unset $n foo + mytree delete $n + set result [mytree exists $n] + mytree destroy + set result +} 0 + +############################################################ + +test tree-${impl}-2.7.1 {keys, wrong # args} { + tree mytree + catch {mytree keys root flaboozle foobar} msg + mytree destroy + set msg +} [tmTooMany keys {node ?pattern?}] + +test tree-${impl}-2.7.2 {keys gives error on bogus node} { + tree mytree + catch {mytree keys {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.7.3 {keys returns empty list for nodes without attributes} { + tree mytree + set results [mytree keys root] + mytree destroy + set results +} {} + +test tree-${impl}-2.7.4 {keys returns list of keys} { + tree mytree + mytree set root data foobar + mytree set root other thing + set results [mytree keys root] + mytree destroy + lsort $results +} {data other} + +test tree-${impl}-2.7.5 {keys matches pattern} { + tree mytree + mytree set root data foobar + mytree set root other thing + set results [mytree keys root d*] + mytree destroy + set results +} data + +############################################################ + +test tree-${impl}-2.8.1 {keyexists, wrong # args} { + tree mytree + catch {mytree keyexists root} msg + mytree destroy + set msg +} [tmWrong keyexists {node key} 1] + +test tree-${impl}-2.8.2 {keyexists, wrong # args} { + tree mytree + catch {mytree keyexists root foo far} msg + mytree destroy + set msg +} [tmTooMany keyexists {node key}] + +test tree-${impl}-2.8.3 {keyexists gives error on bogus node} { + tree mytree + catch {mytree keyexists {IT::EM 0} foo} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-2.8.4 {keyexists returns false on non-existant key} { + tree mytree + set result [mytree keyexists root bogus] + mytree destroy + set result +} 0 + +test tree-${impl}-2.8.5 {keyexists returns false on non-existant key} { + tree mytree + mytree set root ok "" + set result [mytree keyexists root bogus] + mytree destroy + set result +} 0 + +test tree-${impl}-2.8.6 {keyexists returns true for existing key} { + tree mytree + mytree set root ok "" + set result [mytree keyexists root ok] + mytree destroy + set result +} 1 + +############################################################ +# III. Structural operations ... +# - isleaf, parent, children, numchildren, ancestors, descendants +# - nodes, leaves +# - exists, size, depth, height +# - insert, delete, move, cut, splice, swap +# - rename, rootname +############################################################ + +############################################################ + +test tree-${impl}-3.1.1 {isleaf, wrong # args} { + tree mytree + catch {mytree isleaf {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany isleaf {node}] + +test tree-${impl}-3.1.2 {isleaf} { + tree mytree + catch {mytree isleaf {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.1.3 {isleaf} { + tree mytree + set result [mytree isleaf root] + + mytree insert root end {IT::EM 0} + lappend result [mytree isleaf root] + lappend result [mytree isleaf {IT::EM 0}] + mytree destroy + set result +} {1 0 1} + +############################################################ + +test tree-${impl}-3.2.1 {parent, wrong # args} { + tree mytree + catch {mytree parent {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany parent {node}] + +test tree-${impl}-3.2.2 {parent gives error on fake node} { + tree mytree + catch {mytree parent {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.2.3 {parent gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + set result [mytree parent {IT::EM 0}] + mytree destroy + set result +} {root} + +test tree-${impl}-3.2.4 {parent of root is empty string} { + tree mytree + set result [mytree parent root] + mytree destroy + set result +} {} + +############################################################ + +test tree-${impl}-3.3.1 {children, wrong # args} { + tree mytree + catch {mytree children {IT::EM 0} foo} result + mytree destroy + set result +} "wrong # args: should be \"$MY children ?-all? node ?filter cmd?\"" + +test tree-${impl}-3.3.2 {children, bad node} { + tree mytree + catch {mytree children {IT::EM 0}} result + mytree destroy + set result +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.3.3 {children of root, initial} { + tree mytree + set result [mytree children root] + mytree destroy + set result +} {} + +test tree-${impl}-3.3.4 {children} { + tree mytree + set result [list] + + lappend result [mytree children root] + + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} + + lappend result [mytree children root] + lappend result [mytree children {IT::EM 0}] + lappend result [mytree children {IT::EM 1}] + mytree destroy + set result +} {{} {{IT::EM 0} {IT::EM 1} {IT::EM 2}} {{IT::EM 3} {IT::EM 4}} {}} + +test tree-${impl}-3.3.5 {children, -all} { + tree mytree + set result [list] + + mytree insert root end 0 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + mytree insert 4 end 5 + mytree insert 4 end 6 + + set result {} + lappend result [lsort [mytree children -all root]] + lappend result [lsort [mytree children -all 0]] + mytree destroy + set result +} {{0 1 2 3 4 5 6} {3 4 5 6}} + +test tree-${impl}-3.3.6 {children, filtering} { + tree mytree + set result [list] + + mytree insert root end 0 ; mytree set 0 volume 30 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + mytree insert 4 end 5 ; mytree set 5 volume 50 + mytree insert 4 end 6 + + proc vol {t n} { + $t keyexists $n volume + } + proc vgt40 {t n} { + if {![$t keyexists $n volume]} {return 0} + expr {[$t get $n volume] > 40} + } + + set result {} + lappend result [lsort [mytree children -all root filter vol]] + lappend result [lsort [mytree children -all root filter vgt40]] + lappend result [lsort [mytree children root filter vol]] + lappend result [lsort [mytree children root filter vgt40]] + mytree destroy + rename vol {} + rename vgt40 {} + set result +} {{0 5} 5 0 {}} + +test tree-${impl}-3.3.7 {children, bad filter keyword} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return 1} + + catch {mytree children root snarf ff} msg + + mytree destroy + rename ff {} + set msg +} "wrong # args: should be \"$MY children ?-all? node ?filter cmd?\"" + +test tree-${impl}-3.3.8 {children, bad filter keyword, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return 1} + + catch {mytree children -all root snarf ff} msg + + mytree destroy + rename ff {} + set msg +} "wrong # args: should be \"$MY children ?-all? node ?filter cmd?\"" + +test tree-${impl}-3.3.9 {children, empty filter} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children root filter {}} msg + + mytree destroy + set msg +} "wrong # args: should be \"$MY children ?-all? node ?filter cmd?\"" + +test tree-${impl}-3.3.10 {children, empty filter, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children -all root filter {}} msg + + mytree destroy + set msg +} "wrong # args: should be \"$MY children ?-all? node ?filter cmd?\"" + +test tree-${impl}-3.3.11 {children, filter cmdprefix not a list} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children root filter "\{"} msg + + mytree destroy + set msg +} {unmatched open brace in list} + +test tree-${impl}-3.3.12 {children, filter cmdprefix not a list, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children -all root filter "\{"} msg + + mytree destroy + set msg +} {unmatched open brace in list} + +test tree-${impl}-3.3.13 {children, filter, unknown command} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children root filter ::bogus} msg + + mytree destroy + set msg +} {invalid command name "::bogus"} + +test tree-${impl}-3.3.14 {children, filter, unknown command, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree children -all root filter ::bogus} msg + + mytree destroy + set msg +} {invalid command name "::bogus"} + +test tree-${impl}-3.3.15 {children, filter returning error} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return -code error "boo"} + + catch {mytree children root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {boo} + +test tree-${impl}-3.3.16 {children, filter returning error, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return -code error "boo"} + + catch {mytree children -all root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {boo} + +test tree-${impl}-3.3.17 {children, filter result not boolean} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return "boo"} + + catch {mytree children root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {expected boolean value but got "boo"} + +test tree-${impl}-3.3.18 {children, filter result not boolean, -all case} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return "boo"} + + catch {mytree children -all root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {expected boolean value but got "boo"} + +############################################################ + +test tree-${impl}-3.4.1 {numchildren, wrong #args} { + tree mytree + catch {mytree numchildren {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany numchildren {node}] + +test tree-${impl}-3.4.2 {numchildren, bogus node} { + tree mytree + catch {mytree numchildren {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.4.3 {numchildren} { + tree mytree + set result [mytree numchildren root] + mytree insert root end {IT::EM 0} + lappend result [mytree numchildren root] + lappend result [mytree numchildren {IT::EM 0}] + mytree destroy + set result +} {0 1 0} + +test tree-${impl}-3.4.4 {numchildren} { + tree mytree + set result [list] + lappend result [mytree numchildren root] + + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} + + lappend result [mytree numchildren root] + lappend result [mytree numchildren {IT::EM 0}] + lappend result [mytree numchildren {IT::EM 1}] + mytree destroy + set result +} {0 3 2 0} + +############################################################ + +test tree-${impl}-3.5.1 {exists, wrong #args} { + tree mytree + catch {mytree exists {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany exists {node}] + +test tree-${impl}-3.5.2 {exists} { + tree mytree + set result [list] + lappend result [mytree exists root] + lappend result [mytree exists {IT::EM 0}] + + mytree insert root end {IT::EM 0} + lappend result [mytree exists {IT::EM 0}] + + mytree delete {IT::EM 0} + lappend result [mytree exists {IT::EM 0}] + + mytree destroy + set result +} {1 0 1 0} + +############################################################ + +test tree-${impl}-3.6.1 {size, wrong # args} { + tree mytree + catch {mytree size foo far} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY size ?node?\"" + +test tree-${impl}-3.6.2 {size gives error on bogus node} { + tree mytree + catch {mytree size {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.6.3 {size uses root node as default} { + tree mytree + set result [mytree size] + mytree destroy + set result +} 0 + +test tree-${impl}-3.6.4 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert root end {IT::EM 3} + mytree insert root end {IT::EM 4} + mytree insert root end {IT::EM 5} + set result [mytree size] + mytree destroy + set result +} 6 + +test tree-${impl}-3.6.5 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 1} end {IT::EM 4} + mytree insert {IT::EM 1} end {IT::EM 5} + set result [mytree size {IT::EM 0}] + mytree destroy + set result +} 5 + +test tree-${impl}-3.6.6 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 1} end {IT::EM 4} + mytree insert {IT::EM 1} end {IT::EM 5} + set result [mytree size {IT::EM 1}] + mytree destroy + set result +} 2 + +############################################################ + +test tree-${impl}-3.7.1 {depth, wrong # args} { + tree mytree + catch {mytree depth {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany depth {node}] + +test tree-${impl}-3.7.2 {depth} { + tree mytree + catch {mytree depth {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.7.3 {depth of root is 0} { + tree mytree + set result [mytree depth root] + mytree destroy + set result +} 0 + +test tree-${impl}-3.7.4 {depth is computed correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree insert {IT::EM 2} end {IT::EM 3} + set result [mytree depth {IT::EM 3}] + mytree destroy + set result +} 4 + +############################################################ + +test tree-${impl}-3.8.1 {height, wrong # args} { + tree mytree + catch {mytree height {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany height {node}] + +test tree-${impl}-3.8.2 {height for bogus node fails} { + tree mytree + catch {mytree height {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.8.3 {height of root alone is 0} { + tree mytree + set result [mytree height root] + mytree destroy + set result +} 0 + +test tree-${impl}-3.8.4 {height is computed correctly} { + tree mytree + mytree insert root end 0 + mytree insert 0 end 1 + mytree insert 1 end 2 + mytree insert 2 end 3 + set result [mytree height root] + mytree destroy + set result +} 4 + +############################################################ + +test tree-${impl}-3.9.1 {insert creates and initializes node} { + tree mytree + mytree insert root end {IT::EM 0} + set result [list ] + lappend result [mytree exists {IT::EM 0}] + lappend result [mytree parent {IT::EM 0}] + lappend result [mytree children {IT::EM 0}] + lappend result [mytree set {IT::EM 0} data ""] + lappend result [mytree children root] + mytree destroy + set result +} {1 root {} {} {{IT::EM 0}}} + +test tree-${impl}-3.9.2 {insert insert nodes in correct location} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root 0 {IT::EM 2} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 2} {IT::EM 0} {IT::EM 1}} + +test tree-${impl}-3.9.3 {insert gives error when trying to insert to a fake parent} { + tree mytree + catch {mytree insert {IT::EM 0} end {IT::EM 1}} msg + mytree destroy + set msg +} "parent node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.9.4 {insert generates node name when none is given} { + tree mytree + set result [list [mytree insert root end]] + lappend result [mytree insert root end] + mytree insert root end {IT::EM 3} + lappend result [mytree insert root end] + mytree destroy + set result +} {node1 node2 node3} + +test tree-${impl}-3.9.5 {insert inserts multiple nodes properly} { + tree mytree + mytree insert root end a b c d e f + set result [mytree children root] + mytree destroy + set result +} {a b c d e f} + +test tree-${impl}-3.9.6 {insert moves nodes that exist} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree insert root end {IT::EM 4} + set result [list [mytree children root] [mytree children {IT::EM 0}]] + mytree destroy + set result +} [list [list {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} {IT::EM 4}] [list {IT::EM 5} {IT::EM 6}]] + +test tree-${impl}-3.9.7 {insert moves nodes that already exist properly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree insert root end {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + [mytree children {IT::EM 0}] \ + [mytree children {IT::EM 1}] \ + [mytree parent {IT::EM 1}] \ + [mytree parent {IT::EM 2}] \ + ] + mytree destroy + set result +} [list [list {IT::EM 0} {IT::EM 1} {IT::EM 2}] {} {} root root] + +test tree-${impl}-3.9.8 {insert moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree insert root 0 {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + ] + mytree destroy + set result +} {{{IT::EM 1} {IT::EM 2} {IT::EM 0}}} + +test tree-${impl}-3.9.9 {insert moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree insert root 1 {IT::EM 0} {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 0} {IT::EM 1} {IT::EM 2}} + +test tree-${impl}-3.9.10 {insert moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert root 2 {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3}} + +test tree-${impl}-3.9.11 {insert moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 3} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree insert root 2 {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} {IT::EM 2} {IT::EM 3}} + +test tree-${impl}-3.9.12 {insert moves node in parent properly when oldInd < newInd} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert root 2 {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 0} {IT::EM 2} {IT::EM 3}} + +test tree-${impl}-3.9.13 {insert gives error when trying to move root} { + tree mytree + catch {mytree insert root end root} msg + mytree destroy + set msg +} {cannot move root node} + +test tree-${impl}-3.9.14 {insert gives error when trying to make node its descendant} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree insert {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} {node "IT::EM 0" cannot be its own descendant} + +test tree-${impl}-3.9.15 {insert gives error when trying to make node its descendant} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + catch {mytree insert {IT::EM 2} end {IT::EM 0}} msg + mytree destroy + set msg +} {node "IT::EM 0" cannot be its own descendant} + +test tree-${impl}-3.9.17 {check node names with spaces} { + tree mytree + catch {mytree insert root end ":\n\t "} msg + mytree destroy + set msg +} [list ":\n\t "] + +test tree-${impl}-3.9.18 {extended node names with spaces check} { + tree mytree + set node ":\n\t " + set msg [mytree insert root end $node] + lappend msg [mytree isleaf $node] + mytree insert $node end yummy + lappend msg [mytree size $node] + lappend msg [mytree isleaf $node] + mytree set $node data foo + set ::FOO {} + mytree walk root n {walker $n} + lappend msg $::FOO + lappend msg [mytree keys $node] + lappend msg [mytree parent $node] + lappend msg [mytree set $node data] + mytree destroy + set msg +} [list ":\n\t " 1 1 0 [list root ":\n\t " yummy] data root foo] + +test tree-${impl}-3.9.19a {insert fails for a bad index} {!tcl8.5plus||tree_critcl} { + tree mytree + catch {mytree insert root foo new-node} msg + mytree destroy + set msg +} {bad index "foo": must be integer or end?-integer?} + +test tree-${impl}-3.9.19b {insert fails for a bad index} {tcl8.5plus&&!tree_critcl} { + tree mytree + catch {mytree insert root foo new-node} msg + mytree destroy + set msg +} {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} + +test tree-${impl}-3.9.20 {insert insert nodes in correct location} { + tree mytree + mytree insert root end a + mytree insert root end b + mytree insert root 0 c + mytree insert root end-1 d + set result [mytree children root] + mytree destroy + set result +} {c a d b} + +############################################################ + +test tree-${impl}-3.10.1 {delete} { + tree mytree + catch {mytree delete root} msg + mytree destroy + set msg +} {cannot delete root node} + +test tree-${impl}-3.10.2 {delete} { + tree mytree + catch {mytree delete {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.10.3 {delete, only this node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree delete {IT::EM 0} + set result [list [mytree exists {IT::EM 0}] [mytree children root]] + mytree destroy + set result +} {0 {}} + +test tree-${impl}-3.10.4 {delete, node and children} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree delete {IT::EM 0} + set result [list [mytree exists {IT::EM 0}] \ + [mytree exists {IT::EM 1}] \ + [mytree exists {IT::EM 2}]] + mytree destroy + set result +} {0 0 0} + +############################################################ + +test tree-${impl}-3.11.1 {move gives error when trying to move root} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree move {IT::EM 0} end root} msg + mytree destroy + set msg +} {cannot move root node} + +test tree-${impl}-3.11.2 {move gives error when trying to move non existant node} { + tree mytree + catch {mytree move root end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.11.3 {move gives error when trying to move to non existant parent} { + tree mytree + catch {mytree move {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} "parent node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.11.4 {move gives error when trying to make node its own descendant} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree move {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} {node "IT::EM 0" cannot be its own descendant} + +test tree-${impl}-3.11.5 {move gives error when trying to make node its own descendant} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + catch {mytree move {IT::EM 2} end {IT::EM 0}} msg + mytree destroy + set msg +} {node "IT::EM 0" cannot be its own descendant} + +test tree-${impl}-3.11.6 {move correctly moves a node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree move {IT::EM 0} end {IT::EM 2} + set result [list [mytree children {IT::EM 0}] [mytree children {IT::EM 1}]] + lappend result [mytree parent {IT::EM 2}] + mytree destroy + set result +} {{{IT::EM 1} {IT::EM 2}} {} {IT::EM 0}} + +test tree-${impl}-3.11.7 {move moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree move root 0 {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + ] + mytree destroy + set result +} {{{IT::EM 1} {IT::EM 2} {IT::EM 0}}} + +test tree-${impl}-3.11.8 {move moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree move root 1 {IT::EM 0} {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 2} {IT::EM 0} {IT::EM 1}} + +test tree-${impl}-3.11.9 {move moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root 2 {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 0} {IT::EM 2} {IT::EM 1} {IT::EM 3}} + +test tree-${impl}-3.11.10 {move moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 3} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree move root 2 {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 2} {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} {IT::EM 3}} + +test tree-${impl}-3.11.11 {move moves node in parent properly when oldInd < newInd} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root 2 {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 2} {IT::EM 0} {IT::EM 3}} + +test tree-${impl}-3.11.12 {move node up one} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root [mytree index [mytree next {IT::EM 0}]] {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 0} {IT::EM 2} {IT::EM 3}} + +test tree-${impl}-3.11.13 {move node down one} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root [mytree index [mytree previous {IT::EM 2}]] {IT::EM 2} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 0} {IT::EM 2} {IT::EM 1} {IT::EM 3}} + +test tree-${impl}-3.11.14a {move fails for a bad index} {!tcl8.5plus||tree_critcl} { + tree mytree + mytree insert root end node-to-move + catch {mytree move root foo node-to-move} msg + mytree destroy + set msg +} {bad index "foo": must be integer or end?-integer?} + +test tree-${impl}-3.11.14b {move fails for a bad index} {tcl8.5plus&&!tree_critcl} { + tree mytree + mytree insert root end node-to-move + catch {mytree move root foo node-to-move} msg + mytree destroy + set msg +} {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} + +test tree-${impl}-3.11.15 {move correctly moves a node} { + tree mytree + mytree insert root end a + mytree insert a end b + mytree insert a end d + mytree insert a end e + mytree insert b end c + + mytree move a end-1 c + set result {} + lappend result [mytree children a] + lappend result [mytree children b] + lappend result [mytree parent c] + mytree destroy + set result +} {{b d c e} {} a} + +############################################################ + +test tree-${impl}-3.12.1 {cutting nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set t [list ] + mytree walk root {a n} {lappend t $a $n} + mytree destroy + set t +} {enter root enter {IT::EM 0} enter {IT::EM 1.0} enter {IT::EM 1.1} enter {IT::EM 1.2} enter {IT::EM 2}} + +test tree-${impl}-3.12.2 {cutting nodes} { + tree mytree + catch {mytree cut root} msg + mytree destroy + set msg +} {cannot cut root node} + +test tree-${impl}-3.12.3 {cut sets parent values of relocated nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set res [list \ + [mytree parent {IT::EM 1.0}] \ + [mytree parent {IT::EM 1.1}] \ + [mytree parent {IT::EM 1.2}]] + mytree destroy + set res +} {root root root} + +test tree-${impl}-3.12.4 {cut removes node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set res [mytree exists {IT::EM 1}] + mytree destroy + set res +} 0 + +test tree-${impl}-3.12.5 {cut removes node} { + tree mytree + catch {mytree cut {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +############################################################ + +test tree-${impl}-3.13.0 {splicing nodes with bad parent node} { + tree mytree + catch {mytree splice foo 0 end} msg + mytree destroy + set msg +} "node \"foo\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.13.1 {splicing nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # * 1.0 - 1 + # * 1.1 - 1.0 + # * 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root 1 3 {IT::EM 1} + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1} \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave root \ + ] + +test tree-${impl}-3.13.2 {splicing nodes with no node name given} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # * 1.0 - node1 + # * 1.1 - 1.0 + # * 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + set res [mytree splice root 1 3] + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + list $res $t +} [list node1 [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave node1 \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave root \ + ]] + +test tree-${impl}-3.13.3 {splicing nodes errors on duplicate node name} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + catch {mytree splice root 1 3 {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" already exists in tree \"$MY\"" + +test tree-${impl}-3.13.4 {splicing node sets parent values correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # * 1.0 - 1 + # * 1.1 - 1.0 + # * 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root 1 3 {IT::EM 1} + set res [list \ + [mytree parent {IT::EM 1}] \ + [mytree parent {IT::EM 1.0}] \ + [mytree parent {IT::EM 1.1}] \ + [mytree parent {IT::EM 1.2}]] + mytree destroy + set res +} {root {IT::EM 1} {IT::EM 1} {IT::EM 1}} + +test tree-${impl}-3.13.5 {splicing node works with strange index} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 1 + # * 1.0 - 0 + # * 1.1 - 1.0 + # * 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root -5 12 {IT::EM 1} + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 1} \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave {IT::EM 1} \ + leave root \ + ] + +test tree-${impl}-3.13.6 {splicing nodes with no node name and no "to" index given} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # - 1.0 - node1 + # - 1.1 - 1.0 + # - 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root 1 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave node1 \ + leave root \ + ] + +test tree-${impl}-3.13.7 {splicing nodes with to == end} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # - 1.0 - node1 + # - 1.1 - 1.0 + # - 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root 1 end + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave node1 \ + leave root \ + ] + +test tree-${impl}-3.13.8 {splicing nodes with to == end-1} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # - 1.0 - node1 + # - 1.1 - 1.0 + # - 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root 1 end-1 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave node1 \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave root \ + ] + +test tree-${impl}-3.13.9 {splicing nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # - 1.0 - node1 + # - 1.1 - 1.0 + # - 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root end-3 end + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave node1 \ + leave root \ + ] + +test tree-${impl}-3.13.10 {splicing nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + + # root --> root + # - 0 - 0 + # - 1.0 - node1 + # - 1.1 - 1.0 + # - 1.2 - 1.1 + # - 2 - 1.2 + # - 2 + + mytree splice root end-3 end-1 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list \ + enter root \ + enter {IT::EM 0} \ + leave {IT::EM 0} \ + enter node1 \ + enter {IT::EM 1.0} \ + leave {IT::EM 1.0} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave node1 \ + enter {IT::EM 2} \ + leave {IT::EM 2} \ + leave root \ + ] + +############################################################ + +test tree-${impl}-3.14.1 {swap gives error when trying to swap root} { + tree mytree + catch {mytree swap root {IT::EM 0}} msg + mytree destroy + set msg +} {cannot swap root node} + +test tree-${impl}-3.14.2 {swap gives error when trying to swap non existant node} { + tree mytree + catch {mytree swap {IT::EM 0} {IT::EM 1}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.14.3 {swap gives error when trying to swap non existant node} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree swap {IT::EM 0} {IT::EM 1}} msg + mytree destroy + set msg +} "node \"IT::EM 1\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.14.4 {swap gives error when trying to swap node with self} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree swap {IT::EM 0} {IT::EM 0}} msg + mytree destroy + set msg +} {cannot swap node "IT::EM 0" with itself} + +test tree-${impl}-3.14.5 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end 0 + mytree insert 0 end 0.1 + mytree insert 0 end 0.2 + mytree insert 0.1 end 0.1.1 + mytree insert 0.1 end 0.1.2 + + # root --> root + # * 0 * 0.1 + # * 0.1 * 0 + # - 0.1.1 - 0.1.1 + # - 0.1.2 - 0.1.2 + # - 0.2 - 0.2 + + mytree swap 0 0.1 + set t [list] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter 0.1 \ + enter 0 \ + enter 0.1.1 \ + leave 0.1.1 \ + enter 0.1.2 \ + leave 0.1.2 \ + leave 0 \ + enter 0.2 \ + leave 0.2 \ + leave 0.1 \ + leave root \ + ] + +test tree-${impl}-3.14.6 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end 0 + mytree insert 0 end 0.1 + mytree insert 0 end 0.2 + mytree insert 0.1 end 0.1.1 + mytree insert 0.1 end 0.1.2 + + # root --> root + # * 0 * 0.1.1 + # - 0.1 - 0.1 + # * 0.1.1 * 0 + # - 0.1.2 - 0.1.2 + # - 0.2 - 0.2 + + mytree swap 0 0.1.1 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter 0.1.1 \ + enter 0.1 \ + enter 0 \ + leave 0 \ + enter 0.1.2 \ + leave 0.1.2 \ + leave 0.1 \ + enter 0.2 \ + leave 0.2 \ + leave 0.1.1 \ + leave root \ + ] + +test tree-${impl}-3.14.7 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end 0 + mytree insert root end 1 + mytree insert 0 end 0.1 + mytree insert 1 end 1.1 + + # root --> root + # * 0 * 1 + # - 0.1 - 0.1 + # * 1 * 0 + # - 1.1 - 1.1 + + mytree swap 0 1 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter 1 \ + enter 0.1 \ + leave 0.1 \ + leave 1 \ + enter 0 \ + enter 1.1 \ + leave 1.1 \ + leave 0 \ + leave root \ + ] + +test tree-${impl}-3.14.8 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end 0 + mytree insert 0 end 0.1 + mytree insert 0 end 0.2 + mytree insert 0.1 end 0.1.1 + mytree insert 0.1 end 0.1.2 + + # root --> root + # * 0 * 0.1 + # * 0.1 * 0 + # - 0.1.1 - 0.1.1 + # - 0.1.2 - 0.1.2 + # - 0.2 - 0.2 + + mytree swap 0.1 0 + set t [list ] + mytree walk root -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter 0.1 \ + enter 0 \ + enter 0.1.1 \ + leave 0.1.1 \ + enter 0.1.2 \ + leave 0.1.2 \ + leave 0 \ + enter 0.2 \ + leave 0.2 \ + leave 0.1 \ + leave root \ + ] + +test tree-${impl}-3.14.9 {swap keeps attributes with their nodes} { + tree mytree + mytree insert root end 0 1 2 3 + mytree set 0 attr a + mytree set 1 attr b + mytree set 2 attr c + mytree set 3 attr d + + mytree swap 0 3 + + set res [list \ + [mytree children root] \ + [mytree get 0 attr] \ + [mytree get 1 attr] \ + [mytree get 2 attr] \ + [mytree get 3 attr]] + + mytree destroy + set res +} {{3 1 2 0} a b c d} + +############################################################ + +test tree-${impl}-3.15.1 {rootname, wrong # args} { + tree mytree + catch {mytree rootname foo far} result + mytree destroy + set result +} [tmTooMany rootname {}] + +test tree-${impl}-3.15.2 {rootname} { + tree mytree + set result [mytree rootname] + mytree destroy + set result +} root + +############################################################ + +test tree-${impl}-3.16.1 {rename, wrong # args} { + tree mytree + catch {mytree rename foo far fox} result + mytree destroy + set result +} [tmTooMany rename {node newname}] + +test tree-${impl}-3.16.2 {rename of bogus node fails} { + tree mytree + catch {mytree rename 0 foo} result + mytree destroy + set result +} "node \"0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.16.3 {rename, setting to existing node fails} { + tree mytree + mytree insert root end 0 + catch {mytree rename root 0} result + mytree destroy + set result +} "unable to rename node to \"0\", node of that name already present in the tree \"$MY\"" + +test tree-${impl}-3.16.4 {rename root, setting} { + tree mytree + set result [list] + lappend result [mytree rootname] + lappend result [mytree rename root foo] + lappend result [mytree rootname] + mytree destroy + set result +} {root foo foo} + +test tree-${impl}-3.16.5 {rename root, parents} { + tree mytree + mytree insert root end 0 + set result [list] + lappend result [mytree parent 0] + mytree rename root foo + lappend result [mytree parent 0] + mytree destroy + set result +} {root foo} + +test tree-${impl}-3.16.6 {rename root, existence} { + tree mytree + set result [list] + lappend result [mytree exists root] + lappend result [mytree exists 0] + mytree rename root 0 + lappend result [mytree exists root] + lappend result [mytree exists 0] + mytree destroy + set result +} {1 0 0 1} + +test tree-${impl}-3.16.7 {rename root, children} { + tree mytree + mytree insert root end xx + set result [list] + lappend result [mytree children root] + lappend result [catch {mytree children foo}] + mytree rename root foo + lappend result [mytree children foo] + lappend result [catch {mytree children root}] + mytree destroy + set result +} {xx 1 xx 1} + +test tree-${impl}-3.16.8 {rename root, attributes} { + tree mytree + mytree set root data foo + set result [list] + lappend result [mytree getall root] + lappend result [catch {mytree getall foo}] + mytree rename root foo + lappend result [mytree getall foo] + lappend result [catch {mytree getall root}] + mytree destroy + set result +} {{data foo} 1 {data foo} 1} + +test tree-${impl}-3.16.9 {rename node, index} { + tree mytree + set result [list] + mytree insert root end 0 + mytree insert root end 1 + mytree insert root end 2 + lappend result [mytree index 1] + lappend result [mytree rename 1 foo] + lappend result [mytree index foo] + mytree destroy + set result +} {1 foo 1} + +############################################################ + +test tree-${impl}-3.17.1 {ancestors, wrong # args} { + tree mytree + catch {mytree ancestors {IT::EM 0} foo} msg + mytree destroy + set msg +} [tmTooMany ancestors {node}] + +test tree-${impl}-3.17.2 {ancestors gives error on fake node} { + tree mytree + catch {mytree ancestors {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-3.17.3 {ancestors gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + set result [mytree ancestors {IT::EM 2}] + mytree destroy + set result +} {{IT::EM 1} {IT::EM 0} root} + +test tree-${impl}-3.17.4 {ancestors of root is empty string} { + tree mytree + set result [mytree ancestors root] + mytree destroy + set result +} {} + +############################################################ + +test tree-${impl}-3.18.1 {descendants} { + tree mytree + set result [list] + + mytree insert root end 0 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + mytree insert 4 end 5 + mytree insert 4 end 6 + + set result {} + lappend result [lsort [mytree descendants root]] + lappend result [lsort [mytree descendants 0]] + mytree destroy + set result +} {{0 1 2 3 4 5 6} {3 4 5 6}} + +test tree-${impl}-3.18.2 {descendants, filtering} { + tree mytree + set result [list] + + mytree insert root end 0 ; mytree set 0 volume 30 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + mytree insert 4 end 5 ; mytree set 5 volume 50 + mytree insert 4 end 6 + + proc vol {t n} { + $t keyexists $n volume + } + proc vgt40 {t n} { + if {![$t keyexists $n volume]} {return 0} + expr {[$t get $n volume] > 40} + } + + set result {} + lappend result [lsort [mytree descendants root filter vol]] + lappend result [lsort [mytree descendants root filter vgt40]] + mytree destroy + set result +} {{0 5} 5} + +test tree-${impl}-3.18.3 {descendants, bad filter keyword} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return 1} + + catch {mytree descendants root snarf ff} msg + + mytree destroy + rename ff {} + set msg +} "wrong # args: should be \"$MY descendants node ?filter cmd?\"" + +test tree-${impl}-3.18.4 {descendants, empty filter} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree descendants root filter {}} msg + + mytree destroy + set msg +} "wrong # args: should be \"$MY descendants node ?filter cmd?\"" + +test tree-${impl}-3.18.5 {descendants, filter cmdprefix not a list} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree descendants root filter "\{"} msg + + mytree destroy + set msg +} {unmatched open brace in list} + +test tree-${impl}-3.18.6 {descendants, filter, unknown command} { + tree mytree + mytree insert root end a + mytree insert root end b + + catch {mytree descendants root filter ::bogus} msg + + mytree destroy + set msg +} {invalid command name "::bogus"} + +test tree-${impl}-3.18.7 {descendants, filter returning error} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return -code error "boo"} + + catch {mytree descendants root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {boo} + +test tree-${impl}-3.18.8 {descendants, filter result not boolean} { + tree mytree + mytree insert root end a + mytree insert root end b + proc ff {t n} {return "boo"} + + catch {mytree descendants root filter ::ff} msg + + mytree destroy + rename ff {} + set msg +} {expected boolean value but got "boo"} + +############################################################ + +test tree-${impl}-3.19.1a {nodes, wrong # args} {tcl8.4plus} { + tree mytree + catch {mytree nodes {IT::EM 0} foo} result + mytree destroy + set result +} [tmWrong nodes {} 0] + +test tree-${impl}-3.19.1b {nodes, wrong # args} {!tcl8.4plus} { + tree mytree + catch {mytree nodes {IT::EM 0} foo} result + mytree destroy + set result +} [tmTooMany nodes {node}] + +test tree-${impl}-3.19.2 {nodes of initial tree} { + tree mytree + set result [mytree nodes] + mytree destroy + set result +} {root} + +test tree-${impl}-3.19.3 {nodes} { + tree mytree + set result [list] + + lappend result [mytree nodes] + + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} + + lappend result [lsort [mytree nodes]] + mytree destroy + set result +} {root {{IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} {IT::EM 4} root}} + + +############################################################ + +test tree-${impl}-3.20.1a {leaves, wrong # args} {tcl8.4plus} { + tree mytree + catch {mytree leaves {IT::EM 0} foo} result + mytree destroy + set result +} [tmWrong leaves {} 0] + +test tree-${impl}-3.20.1b {leaves, wrong # args} {!tcl8.4plus} { + tree mytree + catch {mytree leaves {IT::EM 0} foo} result + mytree destroy + set result +} [tmTooMany leaves {node}] + +test tree-${impl}-3.20.2 {leaves of initial tree} { + tree mytree + set result [mytree leaves] + mytree destroy + set result +} {root} + +test tree-${impl}-3.20.3 {leaves} { + tree mytree + set result [list] + + lappend result [mytree leaves] + + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} + + lappend result [lsort [mytree leaves]] + mytree destroy + set result +} {root {{IT::EM 1} {IT::EM 2} {IT::EM 3} {IT::EM 4}}} + +############################################################ +# IV. Navigation in the tree +# - index, next, previous, walk +############################################################ + +############################################################ + +test tree-${impl}-4.1.1 {index, wrong # args} { + tree mytree + catch {mytree index root foo} msg + mytree destroy + set msg +} [tmTooMany index {node}] + +test tree-${impl}-4.1.2 {index of non-existant node} { + tree mytree + catch {mytree index {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-4.1.3 {index of root fails} { + tree mytree + catch {mytree index root} msg + mytree destroy + set msg +} {cannot determine index of root node} + +test tree-${impl}-4.1.4 {index} { + tree mytree + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 0} + set result [list] + lappend result [mytree index {IT::EM 0}] + lappend result [mytree index {IT::EM 1}] + mytree destroy + set result +} {1 0} + +############################################################ + +test tree-${impl}-4.2.1 {next, wrong # args} { + tree mytree + mytree insert root end 0 + catch {mytree next 0 foo} msg + mytree destroy + set msg +} [tmTooMany next {node}] + +test tree-${impl}-4.2.2 {next for bogus node} { + tree mytree + catch {mytree next {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-4.2.3 {next from root} { + tree mytree + set res [mytree next root] + mytree destroy + set res +} {} + +test tree-${impl}-4.2.4 {next} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + set res [list [mytree next {IT::EM 0}] [mytree next {IT::EM 1}]] + mytree destroy + set res +} {{IT::EM 1} {}} + +############################################################ + +test tree-${impl}-4.3.1 {previous, wrong # args} { + tree mytree + mytree insert root end 0 + catch {mytree previous 0 foo} msg + mytree destroy + set msg +} [tmTooMany previous {node}] + +test tree-${impl}-4.3.2 {previous for bogus node} { + tree mytree + catch {mytree previous {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-4.3.3 {previous from root} { + tree mytree + set res [mytree previous root] + mytree destroy + set res +} {} + +test tree-${impl}-4.3.4 {previous} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + set res [list [mytree previous {IT::EM 0}] [mytree previous {IT::EM 1}]] + mytree destroy + set res +} {{} {IT::EM 0}} + +############################################################ + +test tree-${impl}-4.4.1 {walk with too few args} {badTest} { + tree mytree + catch {mytree walk} msg + mytree destroy + set msg +} {no value given for parameter "node" to "::struct::tree::_walk"} + +test tree-${impl}-4.4.2 {walk with too few args} { + tree mytree + catch {mytree walk root} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script\"" + +test tree-${impl}-4.4.3 {walk with too many args} { + tree mytree + catch {mytree walk root -foo bar -baz boo -foo2 boo -foo3 baz -foo4 gnar -foo5 schnurr} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script\"" + +test tree-${impl}-4.4.4 {walk with fake node} { + tree mytree + catch {mytree walk {IT::EM 0} {a n} foo} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-4.4.5 {walk gives error on invalid search type} { + tree mytree + catch {mytree walk root -type foo {a n} foo} msg + mytree destroy + set msg +} {bad search type "foo": must be bfs or dfs} + +test tree-${impl}-4.4.6 {walk gives error on invalid search order} { + tree mytree + catch {mytree walk root -order foo {a n} foo} msg + mytree destroy + set msg +} {bad search order "foo": must be both, in, pre, or post} + +test tree-${impl}-4.4.7 {walk gives error on invalid combination of order and type} { + tree mytree + catch {mytree walk root -order in -type bfs {a n} foo} msg + mytree destroy + set msg +} {unable to do a in-order breadth first walk} + +test tree-${impl}-4.4.8 {walk with unknown options} { + tree mytree + catch {mytree walk root -foo bar {a n} foo} msg + mytree destroy + set msg +} {unknown option "-foo"} + +test tree-${impl}-4.4.9 {walk, option without value} { + tree mytree + catch {mytree walk root -type dfs -order} msg + mytree destroy + set msg +} {value for "-order" missing} + +test tree-${impl}-4.4.10 {walk without command} { + tree mytree + catch {mytree walk root -order pre} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script\"" + +test tree-${impl}-4.4.10.1 {walk with too many loop variables} { + tree mytree + catch {mytree walk root {a n d} {foo}} msg + mytree destroy + set msg +} {too many loop variables, at most two allowed} + +test tree-${impl}-4.4.10.2 {walk with empty script} { + tree mytree + catch {mytree walk root {a n} {}} msg + mytree destroy + set msg +} {no script specified, or empty} + +test tree-${impl}-4.4.11.1 {pre dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type dfs {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +test tree-${impl}-4.4.11.2 {post dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order post -type dfs {a n} {lappend t $a $n} + mytree destroy + set t +} [list leave {IT::EM 0.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0} \ + leave {IT::EM 1.1} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1} \ + leave root] + +test tree-${impl}-4.4.11.3 {both dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order both -type dfs {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + leave {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1} \ + leave root] + +test tree-${impl}-4.4.11.4 {in dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order in -type dfs {a n} {lappend t $a $n} + mytree destroy + set t +} [list visit {IT::EM 0.1} \ + visit {IT::EM 0} \ + visit {IT::EM 0.2} \ + visit root \ + visit {IT::EM 1.1} \ + visit {IT::EM 1} \ + visit {IT::EM 1.2}] + +test tree-${impl}-4.4.11.7 {pre dfs walk, nodes with spaces in names} { + tree mytree + set t [list ] + mytree insert root end "node 0" + mytree insert root end "node 1" + mytree insert "node 0" end "node 0 1" + mytree insert "node 0" end "node 0 2" + mytree insert "node 1" end "node 1 1" + mytree insert "node 1" end "node 1 2" + mytree walk root -type dfs {a n} {lappend t $n} + mytree destroy + set t +} {root {node 0} {node 0 1} {node 0 2} {node 1} {node 1 1} {node 1 2}} + +test tree-${impl}-4.4.12.1 {pre bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +test tree-${impl}-4.4.12.2 {post bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs -order post {a n} {lappend t $a $n} + mytree destroy + set t +} [list leave {IT::EM 1.2} \ + leave {IT::EM 1.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0.1} \ + leave {IT::EM 1} \ + leave {IT::EM 0} \ + leave root] + +test tree-${impl}-4.4.12.3 {both bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs -order both {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0.1} \ + leave {IT::EM 1} \ + leave {IT::EM 0} \ + leave root] + +test tree-${impl}-4.4.13 {pre dfs is default walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root {a n} {lappend t $a $n} + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . enter c enter 1 enter 2 ==} + 1 dfs post {== leave a . leave c leave 0 leave 1 leave 2 leave root ==} + 2 dfs both {== enter root enter 0 enter a leave a . . enter c leave c leave 0 enter 1 leave 1 enter 2 leave 2 leave root ==} + 3 dfs in {== visit a visit 0 . visit c visit root visit 1 visit 2 ==} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter a . enter c ==} + 5 bfs post {== leave c . leave a leave 2 leave 1 leave 0 leave root ==} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter a . enter c leave c . leave a leave 2 leave 1 leave 0 leave root ==} +} { + test tree-${impl}-4.4.14.$n "continue in walk $type/$order" { + tree mytree + set t [list ] + mytree insert root end 0 1 2 + mytree insert 0 end a b c + lappend t == + mytree walk root -type $type -order $order {a n} { + if {[string equal $n "b"]} {lappend t . ; continue} + lappend t $a $n + } + lappend t == + mytree destroy + set t + } $log +} + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . ==} + 1 dfs post {== leave a . ==} + 2 dfs both {== enter root enter 0 enter a leave a . ==} + 3 dfs in {== visit a visit 0 . ==} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a . ==} + 5 bfs post {== leave c . ==} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a . leave c . ==} +} { + test tree-${impl}-4.4.15.$n "break in walk $type/$order" { + tree mytree + set t [list ] + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walk root -type $type -order $order {a n} { + if {[string equal $n "b"]} {lappend t . ; break} + lappend t $a $n + } + lappend t == + mytree destroy + set t + } $log +} + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . good-return} + 1 dfs post {== leave a . good-return} + 2 dfs both {== enter root enter 0 enter a leave a . good-return} + 3 dfs in {== visit a visit 0 . good-return} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a . good-return} + 5 bfs post {== leave c . good-return} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a . leave c . good-return} +} { + test tree-${impl}-4.4.16.$n "return in walk $type/$order" { + set t [list ] + proc foo {} { + global t type order + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walk root -type $type -order $order {a n} { + if {[string equal $n "b"]} { + lappend t . + return good-return + } + lappend t $a $n + } + lappend t == + return bad-return + } + lappend t [foo] + mytree destroy + set t + } $log +} + +if {[package vcompare [package provide Tcl] 8.3] < 0} { + # before 8.4 + set t4417estack [viewFile tree.testsuite.4417b84.txt] + +} elseif {[package vcompare [package provide Tcl] 8.4] == 0} { + # 8.4 + switch -exact -- $impl { + tcl { + set t4417estack [viewFile [localPath tree.testsuite.4417=84tcl.txt]] + } + critcl { + set t4417estack [viewFile [localPath tree.testsuite.4417a83critcl.txt]] + } + } +} else { + # 8.5+ + switch -exact -- $impl { + tcl { + set t4417estack [viewFile [localPath tree.testsuite.4417a84tcl.txt]] + } + critcl { + set t4417estack [viewFile [localPath tree.testsuite.4417a83critcl.txt]] + } + } +} + +test tree-${impl}-4.4.17 {error in walk} { + set t [list ] + proc foo {} { + global t + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walk root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + } + lappend t == + return bad-return + } + catch {lappend t [foo]} result + mytree destroy + list $t $result $::errorInfo +} [list {== enter root enter 0 enter a .} fubar $t4417estack] + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a .} + 1 dfs post {== leave a .} + 2 dfs both {== enter root enter 0 enter a leave a .} + 3 dfs in {== visit a visit 0 .} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a .} + 5 bfs post {== leave c .} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a .} +} { + test tree-${impl}-4.4.17.$n "error in walk $type/$order" { + set t [list ] + proc foo {} { + global t type order + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walk root -type $type -order $order {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + } + lappend t == + return bad-return + } + catch {lappend t [foo]} result + mytree destroy + list $t $result + } [list $log fubar] +} + +foreach {n prune type order log} { + 0 0 dfs pre {enter 0 enter 1 enter 2 enter 4 enter 5 enter 6 enter 3} + 1 1 dfs pre {enter 0 enter 1 enter 2 enter 3} + 2 0 dfs both {enter 0 enter 1 leave 1 enter 2 enter 4 leave 4 enter 5 leave 5 enter 6 leave 6 leave 2 enter 3 leave 3 leave 0} + 3 1 dfs both {enter 0 enter 1 leave 1 enter 2 leave 2 enter 3 leave 3 leave 0} + 4 0 bfs pre {enter 0 enter 1 enter 2 enter 3 enter 4 enter 5 enter 6} + 5 1 bfs pre {enter 0 enter 1 enter 2 enter 3} + 6 0 bfs both {enter 0 enter 1 enter 2 enter 3 enter 4 enter 5 enter 6 leave 6 leave 5 leave 4 leave 3 leave 2 leave 1 leave 0} + 7 1 bfs both {enter 0 enter 1 enter 2 enter 3 leave 3 leave 2 leave 1 leave 0} +} { + test tree-${impl}-4.5.$n {pruning} { + # (0 (1 2 (4 5 6) 3)) + tree mytree deserialize {0 {} {} 1 0 {} 2 0 {} 4 6 {} 5 6 {} 6 6 {} 3 0 {}} + set t {} + mytree walk 0 -type $type -order $order {a n} { + lappend t $a $n + if {$prune && ($n == 2)} {struct::tree::prune} + } + mytree destroy + set t + } $log ;# {} +} + +foreach {n type order} { + 8 dfs post + 9 bfs post + 10 dfs in +} { + test tree-${impl}-4.5.$n {prune errors} { + # (0 (1 2 (4 5))) + tree mytree deserialize {0 {} {} 1 0 {} 2 0 {} 4 6 {} 5 6 {}} + set t {} + catch { + mytree walk 0 -type $type -order $order {a n} { + lappend t $a $n + if {($n == 2)} {struct::tree::prune} + } + } res ; # {} + mytree destroy + set res + } "Illegal attempt to prune ${order}-order walking" ;# {} +} + + +test tree-${impl}-4.6.1 {walkproc with too few args} {badTest} { + tree mytree + catch {mytree walkproc} msg + mytree destroy + set msg +} {no value given for parameter "node" to "::struct::tree::_walkproc"} + +test tree-${impl}-4.6.2 {walkproc with too few args} { + tree mytree + catch {mytree walkproc root} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix\"" + +test tree-${impl}-4.6.3 {walkproc with too many args} { + tree mytree + catch {mytree walkproc root -foo bar -baz boo -foo2 boo -foo3 baz -foo4 gnar -foo5 schnurr} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix\"" + +test tree-${impl}-4.6.4 {walkproc with fake node} { + tree mytree + catch {mytree walkproc {IT::EM 0} foo} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"$MY\"" + +test tree-${impl}-4.6.5 {walkproc gives error on invalid search type} { + tree mytree + catch {mytree walkproc root -type foo foo} msg + mytree destroy + set msg +} {bad search type "foo": must be bfs or dfs} + +test tree-${impl}-4.6.6 {walkproc gives error on invalid search order} { + tree mytree + catch {mytree walkproc root -order foo foo} msg + mytree destroy + set msg +} {bad search order "foo": must be both, in, pre, or post} + +test tree-${impl}-4.6.7 {walkproc gives error on invalid combination of order and type} { + tree mytree + catch {mytree walkproc root -order in -type bfs foo} msg + mytree destroy + set msg +} {unable to do a in-order breadth first walk} + +test tree-${impl}-4.6.8 {walkproc with unknown options} { + tree mytree + catch {mytree walkproc root -foo bar foo} msg + mytree destroy + set msg +} {unknown option "-foo"} + +test tree-${impl}-4.6.9 {walkproc, option without value} { + tree mytree + catch {mytree walkproc root -type dfs -order} msg + mytree destroy + set msg +} {value for "-order" missing} + +test tree-${impl}-4.6.10 {walkproc without command} { + tree mytree + catch {mytree walkproc root -order pre} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix\"" + +test tree-${impl}-4.6.10.1 {walkproc with empty command} { + tree mytree + catch {mytree walkproc root -order pre {}} msg + mytree destroy + set msg +} {no script specified, or empty} + +test tree-${impl}-4.6.10.2 {walkproc, cmdprefix is not a list} { + tree mytree + catch {mytree walkproc root -order pre "\{"} msg + mytree destroy + set msg +} {unmatched open brace in list} + +test tree-${impl}-4.6.10.3 {walkproc with unknown command} { + tree mytree + catch {mytree walkproc root -order pre ::bogus} msg + mytree destroy + set msg +} {invalid command name "::bogus"} + +test tree-${impl}-4.6.11.1 {pre dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -type dfs pwalker + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +test tree-${impl}-4.6.11.2 {post dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -order post -type dfs pwalker + mytree destroy + set t +} [list leave {IT::EM 0.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0} \ + leave {IT::EM 1.1} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1} \ + leave root] + +test tree-${impl}-4.6.11.3 {both dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -order both -type dfs pwalker + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + leave {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + leave {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1} \ + leave root] + +test tree-${impl}-4.6.11.4 {in dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -order in -type dfs pwalker + mytree destroy + set t +} [list visit {IT::EM 0.1} \ + visit {IT::EM 0} \ + visit {IT::EM 0.2} \ + visit root \ + visit {IT::EM 1.1} \ + visit {IT::EM 1} \ + visit {IT::EM 1.2}] + +test tree-${impl}-4.6.11.7 {pre dfs walk, nodes with spaces in names} { + tree mytree + set t [list ] + mytree insert root end "node 0" + mytree insert root end "node 1" + mytree insert "node 0" end "node 0 1" + mytree insert "node 0" end "node 0 2" + mytree insert "node 1" end "node 1 1" + mytree insert "node 1" end "node 1 2" + mytree walkproc root -type dfs pwalkern + mytree destroy + set t +} {root {node 0} {node 0 1} {node 0 2} {node 1} {node 1 1} {node 1 2}} + +test tree-${impl}-4.6.12.1 {pre bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -type bfs pwalker + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +test tree-${impl}-4.6.12.2 {post bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -type bfs -order post pwalker + mytree destroy + set t +} [list leave {IT::EM 1.2} \ + leave {IT::EM 1.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0.1} \ + leave {IT::EM 1} \ + leave {IT::EM 0} \ + leave root] + +test tree-${impl}-4.6.12.3 {both bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root -type bfs -order both pwalker + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 1} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2} \ + leave {IT::EM 1.2} \ + leave {IT::EM 1.1} \ + leave {IT::EM 0.2} \ + leave {IT::EM 0.1} \ + leave {IT::EM 1} \ + leave {IT::EM 0} \ + leave root] + +test tree-${impl}-4.6.13 {pre dfs is default walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walkproc root pwalker + mytree destroy + set t +} [list enter root \ + enter {IT::EM 0} \ + enter {IT::EM 0.1} \ + enter {IT::EM 0.2} \ + enter {IT::EM 1} \ + enter {IT::EM 1.1} \ + enter {IT::EM 1.2}] + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . enter c enter 1 enter 2 ==} + 1 dfs post {== leave a . leave c leave 0 leave 1 leave 2 leave root ==} + 2 dfs both {== enter root enter 0 enter a leave a . . enter c leave c leave 0 enter 1 leave 1 enter 2 leave 2 leave root ==} + 3 dfs in {== visit a visit 0 . visit c visit root visit 1 visit 2 ==} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter a . enter c ==} + 5 bfs post {== leave c . leave a leave 2 leave 1 leave 0 leave root ==} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter a . enter c leave c . leave a leave 2 leave 1 leave 0 leave root ==} +} { + test tree-${impl}-4.6.14.$n "continue in walk $type/$order" { + tree mytree + set t [list ] + mytree insert root end 0 1 2 + mytree insert 0 end a b c + lappend t == + mytree walkproc root -type $type -order $order pwalkercont + lappend t == + mytree destroy + set t + } $log +} + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . ==} + 1 dfs post {== leave a . ==} + 2 dfs both {== enter root enter 0 enter a leave a . ==} + 3 dfs in {== visit a visit 0 . ==} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a . ==} + 5 bfs post {== leave c . ==} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a . leave c . ==} +} { + test tree-${impl}-4.6.15.$n "break in walk $type/$order" { + tree mytree + set t [list ] + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walkproc root -type $type -order $order pwalkerbreak + lappend t == + mytree destroy + set t + } $log +} + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a . good-return} + 1 dfs post {== leave a . good-return} + 2 dfs both {== enter root enter 0 enter a leave a . good-return} + 3 dfs in {== visit a visit 0 . good-return} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a . good-return} + 5 bfs post {== leave c . good-return} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a . leave c . good-return} +} { + test tree-${impl}-4.6.16.$n "return in walk $type/$order" { + set t [list ] + proc foo {} { + global t type order + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walkproc root -type $type -order $order pwalkerret + lappend t == + return bad-return + } + lappend t [foo] + mytree destroy + set t + } $log +} + +switch -exact -- $impl { + tcl { + set t4617estack {fubar + while executing +"error fubar" + (procedure "pwalkererr" line 4) + invoked from within +"pwalkererr ::mytree b enter" + ("WalkCallProc" body line 1) + invoked from within +"WalkCallProc $name $node "enter" $script" + (procedure "::struct::tree::_walkproc" line 79) + invoked from within +"::struct::tree::_walkproc ::mytree root pwalkererr" + ("_walkproc" body line 1) + invoked from within +"mytree walkproc root pwalkererr" + (procedure "foo" line 7) + invoked from within +"foo"} +} + critcl { + set t4617estack {fubar + while executing +"error fubar" + (procedure "pwalkererr" line 4) + invoked from within +"pwalkererr mytree b enter" + invoked from within +"mytree walkproc root pwalkererr" + (procedure "foo" line 7) + invoked from within +"foo"} +} +} + +test tree-${impl}-4.6.17 {error in walk} { + set t [list ] + proc foo {} { + global t + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walkproc root pwalkererr + lappend t == + return bad-return + } + catch {lappend t [foo]} result + mytree destroy + list $t $result $::errorInfo +} [list {== enter root enter 0 enter a .} fubar $t4617estack] + +foreach {n type order log} { + 0 dfs pre {== enter root enter 0 enter a .} + 1 dfs post {== leave a .} + 2 dfs both {== enter root enter 0 enter a leave a .} + 3 dfs in {== visit a visit 0 .} + 4 bfs pre {== enter root enter 0 enter 1 enter 2 enter 3 enter a .} + 5 bfs post {== leave c .} + 6 bfs both {== enter root enter 0 enter 1 enter 2 enter 3 enter a .} +} { + test tree-${impl}-4.6.17.$n "error in walk $type/$order" { + set t [list ] + proc foo {} { + global t type order + tree mytree + mytree insert root end 0 1 2 3 + mytree insert 0 end a b c + lappend t == + mytree walkproc root -type $type -order $order pwalkererr + lappend t == + return bad-return + } + catch {lappend t [foo]} result + mytree destroy + list $t $result + } [list $log fubar] +} + +foreach {n prune type order log} { + 0 0 dfs pre {enter 0 enter 1 enter 2 enter 4 enter 5 enter 6 enter 3} + 1 1 dfs pre {enter 0 enter 1 enter 2 enter 3} + 2 0 dfs both {enter 0 enter 1 leave 1 enter 2 enter 4 leave 4 enter 5 leave 5 enter 6 leave 6 leave 2 enter 3 leave 3 leave 0} + 3 1 dfs both {enter 0 enter 1 leave 1 enter 2 leave 2 enter 3 leave 3 leave 0} + 4 0 bfs pre {enter 0 enter 1 enter 2 enter 3 enter 4 enter 5 enter 6} + 5 1 bfs pre {enter 0 enter 1 enter 2 enter 3} + 6 0 bfs both {enter 0 enter 1 enter 2 enter 3 enter 4 enter 5 enter 6 leave 6 leave 5 leave 4 leave 3 leave 2 leave 1 leave 0} + 7 1 bfs both {enter 0 enter 1 enter 2 enter 3 leave 3 leave 2 leave 1 leave 0} +} { + test tree-${impl}-4.7.$n {pruning} { + # (0 (1 2 (4 5 6) 3)) + tree mytree deserialize {0 {} {} 1 0 {} 2 0 {} 4 6 {} 5 6 {} 6 6 {} 3 0 {}} + set t {} + mytree walkproc 0 -type $type -order $order pwalkerprune + mytree destroy + set t + } $log ;# {} +} + +foreach {n type order} { + 8 dfs post + 9 bfs post + 10 dfs in +} { + test tree-${impl}-4.7.$n {prune errors} { + # (0 (1 2 (4 5))) + tree mytree deserialize {0 {} {} 1 0 {} 2 0 {} 4 6 {} 5 6 {}} + set t {} + catch { + mytree walkproc 0 -type $type -order $order pwalkerpruneb + } res ; # {} + mytree destroy + set res + } "Illegal attempt to prune ${order}-order walking" ;# {} +} + +############################################################ +# V. Objects to values and back ... +# - serialize deserialize = --> +############################################################ + +############################################################ + +test tree-${impl}-5.1.1 {serialization, wrong #args} { + tree mytree + catch {mytree serialize foo bar} result + mytree destroy + set result +} "wrong # args: should be \"$MY serialize ?node?\"" + +test tree-${impl}-5.1.2 {serialization, bogus node} { + tree mytree + catch {mytree serialize foo} result + mytree destroy + set result +} "node \"foo\" does not exist in tree \"$MY\"" + +test tree-${impl}-5.1.3 {serialization} { + tree mytree + mytree insert root end %0 + mytree insert root end %1 + mytree insert root end %2 + mytree insert %0 end %3 + mytree insert %0 end %4 + + set serial [mytree serialize] + set result [validate_serial mytree $serial] + mytree destroy + set result + # {{root {} %0 0 %3 2 %4 2 %1 0 %2 0} {}} +} ok + +test tree-${impl}-5.1.4 {serialization} { + tree mytree + mytree insert root end %0 + mytree insert root end %1 + mytree insert root end %2 + mytree insert %0 end %3 + mytree insert %0 end %4 + mytree set %4 foo far + + set serial [mytree serialize %0] + set result [validate_serial mytree $serial %0] + mytree destroy + set result + # {%0 {} {} %3 0 {} %4 0 {foo far data {}}} +} ok + +test tree-${impl}-5.1.5 {serialization, empty tree} { + tree mytree + set serial [mytree serialize] + set result [validate_serial mytree $serial] + mytree destroy + set result + # serial = {root {} {}} +} ok + +############################################################ + +test tree-${impl}-5.2.1 {deserialization, wrong #args} { + tree mytree + catch {mytree deserialize foo bar} result + mytree destroy + set result +} [tmTooMany deserialize {serial}] + +test tree-${impl}-5.2.2 {deserialization} { + tree mytree + set serial {. %0 {} {} %3 0 {} %4 0 {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: list length not a multiple of 3.}} + +test tree-${impl}-5.2.3 {deserialization} { + tree mytree + set serial {%3 {} {} %4 0 {foo far . data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: malformed attribute dictionary.}} + +test tree-${impl}-5.2.4 {deserialization} { + tree mytree + set serial {%3 -1 {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "-1".}} + +test tree-${impl}-5.2.5 {deserialization} { + tree mytree + set serial {%3 .. {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "..".}} + +test tree-${impl}-5.2.6 {deserialization} { + tree mytree + set serial {%3 .. {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "..".}} + +test tree-${impl}-5.2.7 {deserialization} { + tree mytree + set serial {%3 1 {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "1".}} + +test tree-${impl}-5.2.8 {deserialization} { + tree mytree + set serial {%3 2 {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "2".}} + +test tree-${impl}-5.2.9 {deserialization} { + tree mytree + set serial {%3 8 {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "8".}} + +test tree-${impl}-5.2.10 {deserialization} { + tree mytree + set serial {%3 6 {} %4 {} {foo far data {}}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: bad parent reference "6".}} + +test tree-${impl}-5.2.11 {deserialization} { + tree mytree + set serial {%3 3 {} %4 0 {}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: no root specified.}} + +test tree-${impl}-5.2.12 {deserialization} { + tree mytree + set serial {%3 {} {} %4 {} {} %x 0 {}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: multiple root nodes.}} + +test tree-${impl}-5.2.13 {deserialization} { + tree mytree + set serial {%3 3 {} %3 {} {} %x 0 {}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: duplicate node names.}} + +test tree-${impl}-5.2.14 {deserialization} { + tree mytree + set serial {%3 0 {} %4 {} {} %x 0 {}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: cycle detected.}} + +test tree-${impl}-5.2.15 {deserialization} { + tree mytree + set serial {%3 3 {} %4 0 {} %x {} {}} + set fail [catch {mytree deserialize $serial} result] + mytree destroy + list $fail $result +} {1 {error in serialization: cycle detected.}} + +test tree-${impl}-5.2.16 {deserialization} { + tree mytree + + # Our check of the success of the deserialization + # is to validate the generated tree against the + # serialized data. + + set serial {%0 {} {} %3 0 {} %4 0 {foo far data {}}} + + set result [list] + lappend result [validate_serial mytree $serial] + + mytree deserialize $serial + lappend result [validate_serial mytree $serial] + lappend result [mytree rootname] + + mytree destroy + set result +} {node/%0/unknown ok %0} + +test tree-${impl}-5.2.17 {deserialization} { + tree mytree + + # Our check of the success of the deserialization + # is to validate the generated tree against the + # serialized data. + + # Applying to serialization one after the + # other. Checking that the second operation + # completely squashes the data from the first. + + set seriala {root {} {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + set serialb {%0 {} {} %3 0 {} %4 0 {foo far data {}}} + + set result [list] + lappend result [validate_serial mytree $seriala] + lappend result [validate_serial mytree $serialb] + lappend result [mytree rootname] + + mytree deserialize $seriala + lappend result [validate_serial mytree $seriala] + lappend result [validate_serial mytree $serialb] + lappend result [mytree rootname] + + mytree deserialize $serialb + lappend result [validate_serial mytree $seriala] + lappend result [validate_serial mytree $serialb] + lappend result [mytree rootname] + + mytree destroy + set result +} [list node/%0/unknown node/%0/unknown root \ + ok attr/%4/mismatch root \ + node/root/unknown ok %0] + +test tree-${impl}-5.2.18 {deserialization, empty tree} { + tree mytree + set serial {root {} {}} + mytree deserialize $serial + set result [validate_serial mytree $serial] + mytree destroy + set result +} ok + +test tree-${impl}-5.2.19 {deserialization, not a list} { + tree mytree + catch {mytree deserialize "\{"} result + mytree destroy + set result +} {unmatched open brace in list} + +############################################################ + +test tree-${impl}-5.3.1 {tree assignment} { + tree mytree + catch {mytree = foo bar} result + mytree destroy + set result +} [tmTooMany = {source}] + +test tree-${impl}-5.3.2 {tree assignment} { + set serial {root {} {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + + tree mytree + tree btree + + mytree deserialize $serial + + set result [validate_serial btree $serial] + btree = mytree + lappend result [validate_serial btree $serial] + + mytree destroy + btree destroy + set result +} {node/%0/unknown ok} + +test tree-${impl}-5.3.3 {tree assignment, bogus cmd} { + tree mytree + catch {mytree = "\{"} result + mytree destroy + set result +} "invalid command name \"\{\"" + +test tree-${impl}-5.3.4 {tree assignment, unknown command} { + tree mytree + catch {mytree = ::bogus} result + mytree destroy + set result +} {invalid command name "::bogus"} + +############################################################ + +test tree-${impl}-5.4.1 {reverse tree assignment} { + tree mytree + catch {mytree --> foo bar} result + mytree destroy + set result +} [tmTooMany --> {dest}] + +test tree-${impl}-5.4.2 {reverse tree assignment} { + + set serial {root {} {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + + tree mytree + tree btree + + mytree deserialize $serial + + set result [validate_serial btree $serial] + mytree --> btree + lappend result [validate_serial btree $serial] + + mytree destroy + btree destroy + set result +} {node/%0/unknown ok} + +test tree-${impl}-5.4.3 {reverse tree assignment, bogus cmd} { + tree mytree + catch {mytree --> "\{"} result + mytree destroy + set result +} "invalid command name \"\{\"" + +test tree-${impl}-5.4.4 {reverse tree assignment, unknown command} { + tree mytree + catch {mytree --> ::bogus} result + mytree destroy + set result +} {invalid command name "::bogus"} + +############################################################ + +test tree-${impl}-5.5.1 {copy construction, wrong # args} { + catch {tree mytree = a b} result + set result +} {wrong # args: should be "tree ?name ?=|:=|as|deserialize source??"} + +test tree-${impl}-5.5.2 {copy construction, unknown operator} { + catch {tree mytree foo a} result + set result +} {wrong # args: should be "tree ?name ?=|:=|as|deserialize source??"} + +test tree-${impl}-5.5.3 {copy construction, value} { + set serial {root {} {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + + tree mytree deserialize $serial + set result [validate_serial mytree $serial] + mytree destroy + + set result +} ok + +test tree-${impl}-5.5.4 {copy construction, tree} { + set serial {root {} {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + + tree mytree deserialize $serial + tree btree = mytree + + set result [validate_serial btree $serial] + mytree destroy + btree destroy + + set result +} ok + +test tree-${impl}-5.5.5 {copy construction, unknown command} { + catch {tree mytree = ::bogus} msg + catch {mytree destroy} res + list $msg $res +} {{invalid command name "::bogus"} {invalid command name "mytree"}} + +test tree-${impl}-5.5.6 {copy construction, bad value} { + set serial {root 6 {} %0 0 {} %3 3 {} %4 3 {} %1 0 {} %2 0 {}} + + catch {tree mytree deserialize $serial} msg + catch {mytree destroy} res + list $msg $res +} {{error in serialization: no root specified.} {invalid command name "mytree"}} + +############################################################ + +proc gentree {t} { + tree $t + $t insert root end 0 ; $t set 0 volume 30 + $t insert root end 1 + $t insert root end 2 + $t insert 0 end 3 + $t insert 0 end 4 + $t insert 4 end 5 ; $t set 5 volume 50 + $t insert 4 end 6 +} + +test tree-${impl}-6.0 {attribute search} { + gentree mytree + catch {mytree attr} msg + mytree destroy + set msg +} [tmWrong attr {key ?-nodes list|-glob pattern|-regexp pattern?} 0 {key args}] + +test tree-${impl}-6.1 {attribute search} { + gentree mytree + catch {mytree attr a b} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + +test tree-${impl}-6.2 {attribute search} { + gentree mytree + catch {mytree attr a b c d} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + +test tree-${impl}-6.3 {attribute search} { + gentree mytree + catch {mytree attr a b c} msg + mytree destroy + set msg +} "wrong # args: should be \"$MY attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + +test tree-${impl}-6.4 {attribute search} { + gentree mytree + set result [mytree attr vol] + mytree destroy + set result +} {} + +test tree-${impl}-6.5 {attribute search} { + gentree mytree + set result [dictsort [mytree attr volume]] + mytree destroy + set result +} {0 30 5 50} + +test tree-${impl}-6.6 {attribute search} { + gentree mytree + set result [mytree attr volume -nodes {0 3}] + mytree destroy + set result +} {0 30} + +test tree-${impl}-6.7 {attribute search} { + gentree mytree + set result [mytree attr volume -glob {[0-3]}] + mytree destroy + set result +} {0 30} + +test tree-${impl}-6.8 {attribute search} { + gentree mytree + set result [mytree attr volume -regexp {[0-3]}] + mytree destroy + set result +} {0 30} + +test tree-${impl}-6.9 {attribute search} { + gentree mytree + set result [mytree attr volume -nodes {}] + mytree destroy + set result +} {} + +test tree-${impl}-6.10 {attribute search} { + gentree mytree + mytree unset 0 volume + mytree unset 5 volume + set result [mytree attr volume] + mytree destroy + set result +} {} + +test tree-${impl}-6.11 {attribute search, duplicates} { + gentree mytree + set result [mytree attr volume -nodes {0 3 0}] + mytree destroy + set result +} {0 30 0 30} + +test tree-${impl}-6.12 {attribute search, duplicates beyond tree size} { + gentree mytree + set result [mytree attr volume -nodes {0 3 0 5 0 5 0 5 0 5 0 5}] + mytree destroy + set result +} {0 30 0 30 5 50 0 30 5 50 0 30 5 50 0 30 5 50 0 30 5 50} + +############################################################ + +# deserialization, and the creation of new nodes with automatic names. + +test tree-${impl}-7.0 {deserialization & automatic node names} { + tree mytree + mytree deserialize {root {} {} node1 0 {}} + mytree insert root end + set result [lsort [mytree nodes]] + mytree destroy + set result +} {node1 node2 root} diff --git a/tcllib/modules/struct/tree.testsuite.4417=84tcl.txt b/tcllib/modules/struct/tree.testsuite.4417=84tcl.txt new file mode 100644 index 0000000..6d84f8f --- /dev/null +++ b/tcllib/modules/struct/tree.testsuite.4417=84tcl.txt @@ -0,0 +1,32 @@ +fubar + while executing +"error fubar" + invoked from within +"if {[string equal $n "b"]} { + lappend t . + error fubar + }" + ("WalkCall" body line 2) + invoked from within +"WalkCall $avar $nvar $name $node "enter" $script" + (procedure "::struct::tree::_walk" line 88) + invoked from within +"::struct::tree::_walk ::mytree root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + ("_walk" body line 1) + invoked from within +"mytree walk root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + (procedure "foo" line 7) + invoked from within +"foo" diff --git a/tcllib/modules/struct/tree.testsuite.4417a83critcl.txt b/tcllib/modules/struct/tree.testsuite.4417a83critcl.txt new file mode 100644 index 0000000..0252457 --- /dev/null +++ b/tcllib/modules/struct/tree.testsuite.4417a83critcl.txt @@ -0,0 +1,14 @@ +fubar + while executing +"error fubar" + invoked from within +"mytree walk root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + (procedure "foo" line 7) + invoked from within +"foo" diff --git a/tcllib/modules/struct/tree.testsuite.4417a84tcl.txt b/tcllib/modules/struct/tree.testsuite.4417a84tcl.txt new file mode 100644 index 0000000..a3f88c4 --- /dev/null +++ b/tcllib/modules/struct/tree.testsuite.4417a84tcl.txt @@ -0,0 +1,27 @@ +fubar + while executing +"error fubar" + ("WalkCall" body line 4) + invoked from within +"WalkCall $avar $nvar $name $node "enter" $script" + (procedure "::struct::tree::_walk" line 88) + invoked from within +"::struct::tree::_walk ::mytree root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + ("_walk" body line 1) + invoked from within +"mytree walk root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + (procedure "foo" line 7) + invoked from within +"foo" diff --git a/tcllib/modules/struct/tree.testsuite.4417b84.txt b/tcllib/modules/struct/tree.testsuite.4417b84.txt new file mode 100644 index 0000000..a3f88c4 --- /dev/null +++ b/tcllib/modules/struct/tree.testsuite.4417b84.txt @@ -0,0 +1,27 @@ +fubar + while executing +"error fubar" + ("WalkCall" body line 4) + invoked from within +"WalkCall $avar $nvar $name $node "enter" $script" + (procedure "::struct::tree::_walk" line 88) + invoked from within +"::struct::tree::_walk ::mytree root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + ("_walk" body line 1) + invoked from within +"mytree walk root {a n} { + if {[string equal $n "b"]} { + lappend t . + error fubar + } + lappend t $a $n + }" + (procedure "foo" line 7) + invoked from within +"foo" diff --git a/tcllib/modules/struct/tree/ds.h b/tcllib/modules/struct/tree/ds.h new file mode 100644 index 0000000..8da4771 --- /dev/null +++ b/tcllib/modules/struct/tree/ds.h @@ -0,0 +1,111 @@ +/* struct::tree - critcl - layer 1 declarations + * (a) Data structures. + */ + +#ifndef _DS_H +#define _DS_H 1 + +#include "tcl.h" + +/* Forward declarations of references to trees & nodes. + */ + +typedef struct T* TPtr; +typedef struct TN* TNPtr; + +/* Node structure. + */ + +typedef struct TN { + /* Node identity / handle */ + /* Internal rep should be of type */ + /* 'tcllib::struct::tree/critcl::node'. */ + /* See below. */ + + Tcl_Obj* name; + Tcl_HashEntry* he; + + /* Basic linkage of node to its tree */ + + TPtr tree; /* Tree the node belongs to */ + TNPtr nextleaf; /* Double linked list of all */ + TNPtr prevleaf; /* leaf nodes */ + TNPtr nextnode; /* Double linked list of all */ + TNPtr prevnode; /* nodes */ + + /* Node navigation. Parent/Children/Siblings */ + + TNPtr parent; /* Parent node */ + + TNPtr* child; /* Array of children. Can + * be NULL. leaf node implies + * NULL, and vice versa */ + int nchildren; /* # nodes used in previous array */ + int maxchildren; /* Size of previous array */ + + TNPtr left; /* Sibling to the left, NULL if no such */ + TNPtr right; /* Sibling to the right, NULL if no such */ + + /* Node attributes */ + + Tcl_HashTable* attr; /* Node attributes. NULL if the + * node has none */ + + /* Cache for properties of the node based on the tree + * structure + */ + + int index; /* Index of node in 'child' array of its + * parent */ + int depth; /* Distance to root node. + * 0 <=> root */ + int height; /* Distance to deepest child. + * 0 <=> Leaf. */ + int desc; /* #Descendants */ + +} TN; + +/* Tree structure + */ + +typedef struct T { + Tcl_Command cmd; /* Token of the object command for + * the tree */ + + Tcl_HashTable node; /* Mapping + * Node names -> Node structure */ + + int counter; /* Counter used by the generator + * of node names */ + + TN* root; /* Root node of the tree. */ + + TN* leaves; /* List of all leaf nodes */ + int nleaves; /* List length */ + + TN* nodes; /* List of all nodes */ + int nnodes; /* List length */ + + int structure; /* Boolean flag. Set to true if the + * depth/height/desc information + * in the nodes is valid. Reset to + * false by all operations changing + * the structure of the tree. */ + + /* Generation of node handles. Tree local storage, makes code thread + * oblivious. + */ + + char handle [50]; + +} T; + +#endif /* _DS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/m.c b/tcllib/modules/struct/tree/m.c new file mode 100644 index 0000000..d593b8a --- /dev/null +++ b/tcllib/modules/struct/tree/m.c @@ -0,0 +1,2908 @@ +/* struct::tree - critcl - layer 3 definitions. + * + * -> Method functions. + * Implementations for all tree methods. + */ + +#include <string.h> +#include "util.h" +#include "m.h" +#include "t.h" +#include "tn.h" +#include "ms.h" + +/* .................................................. + * Handling of all indices, numeric and 'end-x' forms. Copied straight out of + * the Tcl core as this is not exported through the public API. + */ + +static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, + int endValue, int* indexPtr); + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * tm_TASSIGN -- + * + * Copies the argument tree over into this tree object. Uses direct + * access to internal data structures for matching tree objects, and + * goes through a serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +tm_TASSIGN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree = source + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "source"); + return TCL_ERROR; + } + + return tms_assign (interp, t, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * tm_TSET -- + * + * Copies this tree over into the argument tree. Uses direct access to + * internal data structures for matching tree objects, and goes through a + * serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +tm_TSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree --> dest(ination) + * [0] [1] [2] + */ + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "dest"); + return TCL_ERROR; + } + + return tms_set (interp, t, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * tm_ANCESTORS -- + * + * Returns a list containing the ancestors of the named node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_ANCESTORS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree ancestors node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + int depth; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + depth = tn_depth (tn); + if (depth == 0) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } else { + int i; + Tcl_Obj** anc = NALLOC (depth, Tcl_Obj*); + + for (i = 0; + tn->parent != NULL; + i++, tn = tn->parent) { + + ASSERT_BOUNDS (i, depth); + + anc [i] = tn->parent->name; + /* RefCount++ happens in NewList */ + /*Tcl_IncrRefCount (anc [i]);*/ + } + + Tcl_SetObjResult (interp, Tcl_NewListObj (i, anc)); + ckfree ((char*) anc); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_APPEND -- + * + * Appends a value to an attribute of the named node. + * May create the attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_APPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree append node key value + * [0] [1] [2] [3] [4] + */ + + TN* tn; + Tcl_HashEntry* he; + CONST char* key; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 2, objv, "node key value"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + tn_extend_attr (tn); + + he = Tcl_FindHashEntry (tn->attr, key); + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(tn->attr, key, &new); + + Tcl_IncrRefCount (objv [4]); + Tcl_SetHashValue (he, (ClientData) objv [4]); + Tcl_SetObjResult (interp, objv [4]); + } else { + Tcl_Obj* av = (Tcl_Obj*) Tcl_GetHashValue(he); + + if (Tcl_IsShared (av)) { + Tcl_DecrRefCount (av); + av = Tcl_DuplicateObj (av); + Tcl_IncrRefCount (av); + + Tcl_SetHashValue (he, (ClientData) av); + } + + Tcl_AppendObjToObj (av, objv [4]); + Tcl_SetObjResult (interp, av); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_ATTR -- + * + * Returns a dictionary mapping from nodes to attribute values, for a + * named attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_ATTR (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree attr key ?-query queryarg? + * : -nodes nodelist + * : -glob nodepattern + * : -regexp nodepattern + * [0] [1] [2] [3] [4] + */ + + CONST char* key; + int type; + Tcl_Obj* detail = NULL; + int listc = 0; + Tcl_Obj** listv = NULL; + + static CONST char* types [] = { + "-glob", "-nodes","-regexp", NULL + }; + enum types { + T_GLOB, T_NODES, T_REGEXP, T_NONE + }; + + if ((objc != 3) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 2, objv, + "key ?-nodes list|-glob pattern|-regexp pattern?"); + return TCL_ERROR; + } + + key = Tcl_GetString (objv [2]); + + if (objc != 5) { + type = T_NONE; + } else { + detail = objv [4]; + if (Tcl_GetIndexFromObj (interp, objv [3], types, "type", + 0, &type) != TCL_OK) { + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 2, objv, + "key ?-nodes list|-glob pattern|-regexp pattern?"); + return TCL_ERROR; + } + } + + /* Allocate result space, max needed: All nodes */ + + ASSERT (t->node.numEntries == t->nnodes, "Inconsistent #nodes in tree"); + + switch (type) { + case T_GLOB: + { + /* Iterate over all nodes + * Ignore nodes without attributes + * Ignore nodes not matching the pattern (glob) + * Ignore nodes not having the attribute + */ + + int i; + TN* iter; + CONST char* pattern = Tcl_GetString (detail); + Tcl_HashEntry* he; + + listc = 2 * t->node.numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = t->nodes; + iter != NULL; + iter= iter->nextnode) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + if (!Tcl_StringMatch(Tcl_GetString (iter->name), pattern)) continue; + + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + + case T_NODES: + { + /* Iterate over the specified nodes + * Ignore nodes which are not known + * Ignore nodes without attributes + * Ignore nodes not having the attribute + * Many occurrences of the same node cause + * repeated results. + */ + + TN* iter; + int nodec; + Tcl_Obj** nodev; + int i, j; + Tcl_HashEntry* he; + + if (Tcl_ListObjGetElements (interp, detail, &nodec, &nodev) != TCL_OK) { + return TCL_ERROR; + } + + if (nodec > t->nnodes) { + listc = 2 * nodec; + } else { + listc = 2 * t->nnodes; + } + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, j = 0; i < nodec; i++) { + + ASSERT_BOUNDS (i, nodec); + iter = tn_get_node (t, nodev [i], NULL, NULL); + + if (iter == NULL) continue; + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (j, listc); + ASSERT_BOUNDS (j+1, listc); + + listv [j++] = iter->name; + listv [j++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = j; + } + break; + + case T_REGEXP: + { + /* Iterate over all nodes + * Ignore nodes without attributes + * Ignore nodes not matching the pattern (re) + * Ignore nodes not having the attribute + */ + + int i; + TN* iter; + CONST char* pattern = Tcl_GetString (detail); + Tcl_HashEntry* he; + + listc = 2 * t->node.numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = t->nodes; + iter != NULL; + iter= iter->nextnode) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + if (Tcl_RegExpMatch(interp, Tcl_GetString (iter->name), pattern) < 1) continue; + + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + + case T_NONE: + { + /* Iterate over all nodes + * Ignore nodes without attributes + * Ignore nodes not having the attribute + */ + + int i; + TN* iter; + Tcl_HashEntry* he; + + listc = 2 * t->node.numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for (i = 0, iter = t->nodes; + iter != NULL; + iter= iter->nextnode) { + + if (!iter->attr) continue; + if (!iter->attr->numEntries) continue; + + he = Tcl_FindHashEntry (iter->attr, key); + if (!he) continue; + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = iter->name; + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + listc = i; + } + break; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_CHILDREN -- + * + * Returns a list of all direct or indirect descendants of the named + * node, possibly run through a Tcl command prefix for filtering. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. Per the filter command prefix, if + * one has been specified. + * + *--------------------------------------------------------------------------- + */ + +int +tm_CHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree children ?-all? node ?filter cmdpfx? + * 3 tree children node + * 4 tree children -all node + * 5 tree children node filter cmdpfx + * 6 tree children -all node filter cmdpfx + * [0] [1] [2] [3] [4] [5] + */ + +#undef USAGE +#define USAGE "?-all? node ?filter cmd?" + + TN* tn; + int node = 2; + int all = 0; + int cmdc = 0; + Tcl_Obj** cmdv = NULL; + int listc = 0; + Tcl_Obj** listv; + + if ((objc < 3) || (objc > 6)) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + + ASSERT_BOUNDS (node, objc); + if (0 == strcmp ("-all", Tcl_GetString (objv [node]))) { + /* -all present */ + + if ((objc != 4) && (objc != 6)) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + + node ++; + all = 1; + } else { + /* -all missing */ + + if ((objc != 3) && (objc != 5)) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + } + + if (objc == (node+3)) { + ASSERT_BOUNDS (node+1, objc); + if (strcmp ("filter", Tcl_GetString (objv [node+1]))) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + + ASSERT_BOUNDS (node+2, objc); + if (Tcl_ListObjGetElements (interp, objv [node+2], &cmdc, &cmdv) != TCL_OK) { + return TCL_ERROR; + } + if (!cmdc) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + } + + ASSERT_BOUNDS (node, objc); + tn = tn_get_node (t, objv [node], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + return tms_getchildren (tn, all, + cmdc, cmdv, + objv [0], interp); +} + +/* + *--------------------------------------------------------------------------- + * + * tm_CUT -- + * + * Deletes the named nodes, but not its children. They are put into the + * place where the deleted node was. Complementary to tm_SPLICE. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_CUT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree cut node + * [0] [1] [2] + */ + + TN* tn; + TN* p; + Tcl_Obj* res; + int i, j; + TN** child; + int nchildren; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (tn == t->root) { + /* Node found, is root, cannot be cut */ + + Tcl_AppendResult (interp, "cannot cut root node", NULL); + return TCL_ERROR; + } + + tn_cut (tn); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_DELETE -- + * + * Deletes the named node and its children. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_DELETE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree delete node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (tn == t->root) { + /* Node found, is root, cannot be deleted */ + + Tcl_AppendResult (interp, "cannot delete root node", NULL); + return TCL_ERROR; + } + + tn_detach (tn); + tn_delete (tn); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_DEPTH -- + * + * Returns a non-negative integer number describing the distance between + * the named node and the root of the tree. A depth of 0 implies that + * the node is the root node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_DEPTH (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree depth node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_depth (tn))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_DESCENDANTS -- + * + * Returns a list of all descendants of the named node, possibly run + * through a Tcl command prefix for filtering. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. Per the filter command prefix, if + * one has been specified. + * + *--------------------------------------------------------------------------- + */ + +int +tm_DESCENDANTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree descendants node ?filter cmdprefix? + * [0] [1] [2] [3] [4] + */ + + TN* tn; + int cmdc = 0; + Tcl_Obj** cmdv = NULL; + + if ((objc < 2) || (objc > 5)) { + Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); + return TCL_ERROR; + } + + if (objc == 5) { + if (strcmp ("filter", Tcl_GetString (objv [3]))) { + Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); + return TCL_ERROR; + } + if (Tcl_ListObjGetElements (interp, objv [4], &cmdc, &cmdv) != TCL_OK) { + return TCL_ERROR; + } + if (!cmdc) { + Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); + return TCL_ERROR; + } + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + return tms_getchildren (tn, 1 /* all */, + cmdc, cmdv, + objv [0], interp); +} + +/* + *--------------------------------------------------------------------------- + * + * tm_DESERIALIZE -- + * + * Parses a Tcl value containing a serialized tree and copies it over + * he existing tree. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_DESERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree deserialize serial + * [0] [1] [2] + */ + + T* tser; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "serial"); + return TCL_ERROR; + } + + return t_deserialize (t, interp, objv [2]); +} + +/* + *--------------------------------------------------------------------------- + * + * tm_DESTROY -- + * + * Destroys the whole tree object. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Releases memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_DESTROY (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree destroy + * [0] [1] + */ + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DeleteCommandFromToken(interp, t->cmd); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_EXISTS -- + * + * Returns a boolean value signaling whether the named node exists in + * the tree. True implies existence, and false non-existence. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_EXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree exists node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], NULL, NULL); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn != NULL)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_GET -- + * + * Returns the value of the named attribute at the given node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_GET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree get node key + * [0] [1] [2] [3] + */ + + TN* tn; + Tcl_HashEntry* he = NULL; + CONST char* key; + Tcl_Obj* av; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "node key"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + if (tn->attr) { + he = Tcl_FindHashEntry (tn->attr, key); + } + + if ((tn->attr == NULL) || (he == NULL)) { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "invalid key \"", -1); + Tcl_AppendObjToObj (err, objv [3]); + Tcl_AppendToObj (err, "\" for node \"", -1); + Tcl_AppendObjToObj (err, objv [2]); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + av = (Tcl_Obj*) Tcl_GetHashValue(he); + Tcl_SetObjResult (interp, av); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_GETALL -- + * + * Returns a dictionary containing all attributes and their values of + * the specified node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_GETALL (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree getall node ?pattern? + * [0] [1] [2] [3] + */ + + TN* tn; + Tcl_HashEntry* he; + Tcl_HashSearch hs; + CONST char* key; + int i; + int listc; + Tcl_Obj** listv; + CONST char* pattern = NULL; + int matchall = 0; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return TCL_OK; + } + + if (objc == 4) { + pattern = Tcl_GetString (objv [3]); + matchall = (strcmp (pattern, "*") == 0); + } + + listc = 2 * tn->attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + if ((objc == 3) || matchall) { + /* Unpatterned retrieval, or pattern '*' */ + + for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (tn->attr, he); + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + + ASSERT (i == listc, "Bad attribute retrieval"); + } else { + /* Filtered retrieval, glob pattern */ + + for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (tn->attr, he); + + if (Tcl_StringMatch(key, pattern)) { + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); + } + } + + ASSERT (i <= listc, "Bad attribute glob retrieval"); + listc = i; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_HEIGHT -- + * + * Returns a non-negative integer number describing the distance between + * the given node and its farthest child. A value of 0 implies that the + * node is a leaf. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_HEIGHT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree height node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_height (tn))); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_INDEX -- + * + * Returns a non-negative integer number describing the location of the + * specified node within its parent's list of children. An index of 0 + * implies that the node is the left-most child of its parent. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_INDEX (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree index node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (tn == tn->tree->root) { + Tcl_AppendResult (interp, "cannot determine index of root node", NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->index)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_INSERT -- + * + * Creates/inserts/moves a node to specific location in its (new) parent. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_INSERT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree insert parent index ?name...? + * [0] [1] [2] [3] [4+] + */ + + TN* tn; + int idx; + Tcl_Obj* res; + + if (objc < 4) { + Tcl_WrongNumArgs (interp, 2, objv, "parent index ?name...?"); + return TCL_ERROR; + } + + Tcl_AppendResult (interp, "parent ", NULL); + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + Tcl_ResetResult (interp); + + if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) { + return TCL_ERROR; + } + + if (objc > 4) { + /* We have explicit node names. */ + /* Unknown nodes are created. */ + /* Existing nodes are moved. */ + /* Trying to move the root will fail. */ + + int i; + TN* n; + + for (i = 4; i < objc; i++) { + ASSERT_BOUNDS (i, objc); + n = tn_get_node (t, objv [i], NULL, NULL); + + if (n == NULL) { + /* No matching node found */ + /* Create node with specified name, */ + /* then insert it */ + + CONST char* name; + name = Tcl_GetString (objv [i]); + + tn_insert (tn, idx, tn_new (t, name)); + idx++; + + } else if (n == t->root) { + /* Node found, is root, immovable */ + + Tcl_AppendResult (interp, "cannot move root node", NULL); + return TCL_ERROR; + + } else if ((n == tn) || tn_isancestorof (n, tn)) { + /* Node found, not root, but move is irregular */ + + /* The chosen parent is actually a descendant of the */ + /* node to move. The move would create a circle. This */ + /* is not allowed. */ + + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, objv [i]); + Tcl_AppendToObj (err, "\" cannot be its own descendant", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + + } else { + /* Node found, move is ok */ + + /* If the node is moving within its parent, and its */ + /* old location was before the new location, then */ + /* decrement the new location, so that it gets put */ + /* into the right spot. */ + + if ((n->parent == tn) && (n->index < idx)) { + idx --; + } + + tn_detach (n); + tn_insert (tn, idx, n); + idx++; + } + } + + Tcl_SetObjResult (interp, Tcl_NewListObj (objc-4,objv+4)); + + } else { + /* Create a single new node with a generated name, */ + /* then insert it. */ + + CONST char* name = t_newnodename (t); + TN* nn = tn_new (t, name); + + tn_insert (tn, idx, nn); + Tcl_SetObjResult (interp, Tcl_NewListObj (1, &nn->name)); + } + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_ISLEAF -- + * + * Returns a boolean value signaling whether the given node is a leaf or + * not. True implies that the node is a leaf. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_ISLEAF (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree isleaf node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren == 0)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_KEYEXISTS -- + * + * Returns a boolean value signaling whether the given node has the + * named attribute or not. True implies that the attribute exists. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_KEYEXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree keyexists node [key] + * [0] [1] [2] [3] + */ + + TN* tn; + Tcl_HashEntry* he; + CONST char* key; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "node key"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewIntObj (0)); + return TCL_OK; + } + + he = Tcl_FindHashEntry (tn->attr, key); + + Tcl_SetObjResult (interp, Tcl_NewIntObj (he != NULL)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_KEYS -- + * + * Returns a list containing all attribute names matching the pattern + * for the attributes of the specified node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_KEYS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree keys node ?pattern? + * [0] [1] [2] [3] + */ + + TN* tn; + Tcl_HashEntry* he; + Tcl_HashSearch hs; + CONST char* key; + int i; + int listc; + Tcl_Obj** listv; + CONST char* pattern; + int matchall = 0; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return TCL_OK; + } + + listc = tn->attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + if (objc == 4) { + pattern = Tcl_GetString(objv[3]); + matchall = (strcmp (pattern, "*") == 0); + } + + if ((objc == 3) || matchall) { + /* Unpatterned retrieval, or pattern '*' */ + + for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + ASSERT_BOUNDS (i, listc); + listv [i++] = Tcl_NewStringObj (Tcl_GetHashKey (tn->attr, he), -1); + } + + ASSERT (i == listc, "Bad key retrieval"); + + } else { + /* Filtered retrieval, glob pattern */ + + for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (tn->attr, he); + if (Tcl_StringMatch(key, pattern)) { + ASSERT_BOUNDS (i, listc); + + listv [i++] = Tcl_NewStringObj (key, -1); + } + } + + ASSERT (i <= listc, "Bad key glob retrieval"); + listc = i; + } + + if (listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + + ckfree ((char*) listv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_LAPPEND -- + * + * Appends a value as list element to an attribute of the named node. + * May create the attribute. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_LAPPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree lappend node key value + * [0] [1] [2] [3] [4] + */ + + TN* tn; + Tcl_HashEntry* he; + CONST char* key; + Tcl_Obj* av; + + if (objc != 5) { + Tcl_WrongNumArgs (interp, 2, objv, "node key value"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + tn_extend_attr (tn); + + he = Tcl_FindHashEntry (tn->attr, key); + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(tn->attr, key, &new); + + av = Tcl_NewListObj (0,NULL); + Tcl_IncrRefCount (av); + Tcl_SetHashValue (he, (ClientData) av); + + } else { + av = (Tcl_Obj*) Tcl_GetHashValue(he); + + if (Tcl_IsShared (av)) { + Tcl_DecrRefCount (av); + av = Tcl_DuplicateObj (av); + Tcl_IncrRefCount (av); + + Tcl_SetHashValue (he, (ClientData) av); + } + } + + Tcl_ListObjAppendElement (interp, av, objv [4]); + + Tcl_SetObjResult (interp, av); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_LEAVES -- + * + * Returns a list containing all leaf nodes of the tree. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_LEAVES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree leaves + * [0] [1] + */ + + TN* tn; + int listc; + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + listc = t->nleaves; + + if (listc) { + int i; + Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*); + TN* iter; + + for (i = 0, iter = t->leaves; + iter != NULL; + iter = iter->nextleaf, i++) { + + ASSERT_BOUNDS (i, listc); + listv [i] = iter->name; + } + + ASSERT (i == listc, "Bad list of leaves"); + + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + ckfree ((char*) listv); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_MOVE -- + * + * Moves the specified node to a (new) parent. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_MOVE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree move parent index node ?node...? + * [0] [1] [2] [3] [4] [5+] + */ + + TN* tn; + int idx; + TN* n; + int listc; + TN** listv; + int i; + + if (objc < 5) { + Tcl_WrongNumArgs (interp, 2, objv, "parentNode index node ?node...?"); + return TCL_ERROR; + } + + Tcl_AppendResult (interp, "parent ", NULL); + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + Tcl_ResetResult (interp); + + if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) { + return TCL_ERROR; + } + + /* Validate all nodes to move before trying to rearrange + * tree in any way. */ + + listc = objc-4; + listv = NALLOC (listc, TN*); + + for (i=4; i < objc; i++) { + ASSERT_BOUNDS (i, objc); + ASSERT_BOUNDS (i-4, listc); + + n = tn_get_node (t, objv [i], interp, objv [0]); + listv [i-4] = n; + + if (n == NULL) { + /* Node not found, immovable */ + ckfree ((char*) listv); + return TCL_ERROR; + + } else if (n == t->root) { + /* Node found, is root, immovable */ + + Tcl_AppendResult (interp, "cannot move root node", NULL); + ckfree ((char*) listv); + return TCL_ERROR; + + } else if ((n == tn) || tn_isancestorof (n, tn)) { + /* Node found, not root, but move is irregular */ + + /* The chosen parent is actually a descendant of the */ + /* node to move. The move would create a circle. This */ + /* is not allowed. */ + + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, objv [i]); + Tcl_AppendToObj (err, "\" cannot be its own descendant", -1); + + Tcl_SetObjResult (interp, err); + ckfree ((char*) listv); + return TCL_ERROR; + } + } + + for (i=0; i < listc; i++) { + ASSERT_BOUNDS (i, listc); + tn_detach (listv [i]); + } + + tn_insertmany (tn, idx, listc, listv); + + ckfree ((char*) listv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_NEXT -- + * + * Returns the name of node which is the right sibling of the given node. + * The empty string is delivered if the node has no right sibling. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_NEXT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree next node + * [0] [1] [2] + */ + + TN* tn; + Tcl_Obj* res; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if ((tn->parent == NULL) || + (tn->right == NULL)) { + Tcl_SetObjResult (interp, Tcl_NewObj ()); + } else { + Tcl_SetObjResult (interp, tn->right->name); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_NODES -- + * + * Returns a list containing all nodes of the tree. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_NODES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree nodes + * [0] [1] + */ + + TN* tn; + int listc; + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + listc = t->nnodes; + if (listc) { + int i; + Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*); + TN* iter; + + for (i = 0, iter = t->nodes; + iter != NULL; + iter = iter->nextnode, i++) { + + ASSERT_BOUNDS (i, listc); + listv [i] = iter->name; + } + + ASSERT (i == listc, "Bad list of nodes"); + + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + ckfree ((char*) listv); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_NUMCHILDREN -- + * + * Returns a non-negative integer number, the number of direct children + * of the specified node. Zero children implies that the node is a leaf. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_NUMCHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree numchildren node + * [0] [1] [2] + */ + + TN* tn; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_PARENT -- + * + * Returns the name of the parent node for the specified node. Delivers + * an empty string if the node is the root of the tree. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_PARENT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree parent node + * [0] [1] [2] + */ + + TN* tn; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (tn->parent == NULL) { + Tcl_SetObjResult (interp, Tcl_NewObj ()); + } else { + Tcl_SetObjResult (interp, tn->parent->name); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_PREVIOUS -- + * + * Returns the name of node which is the left sibling of the given node. + * The empty string is delivered if the node has no left sibling. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_PREVIOUS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree previous node + * [0] [1] [2] + */ + + TN* tn; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "node"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if ((tn->parent == NULL) || + (tn->left == NULL)) { + Tcl_SetObjResult (interp, Tcl_NewObj ()); + } else { + Tcl_SetObjResult (interp, tn->left->name); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_RENAME -- + * + * Gives the specified node a new name. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_RENAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree rename node newname + * [0] [1] [2] [3] + */ + + TN* tn; + TN* new; + Tcl_Obj* res; + int nnew; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "node newname"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + new = tn_get_node (t, objv [3], NULL, NULL); + if (new != NULL) { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "unable to rename node to \"", -1); + Tcl_AppendObjToObj (err, objv [3]); + Tcl_AppendToObj (err, "\", node of that name already present in the tree \"", -1); + Tcl_AppendObjToObj (err, objv [0]); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + /* Release current name, ... */ + Tcl_DecrRefCount (tn->name); + + /* ... and create a new one, by taking the argument + * and shimmering it */ + + tn->name = objv [3]; + Tcl_IncrRefCount (tn->name); + tn_shimmer (tn->name, tn); + + /* Update the global name mapping as well */ + + Tcl_DeleteHashEntry (tn->he); + tn->he = Tcl_CreateHashEntry(&t->node, Tcl_GetString (tn->name), &nnew); + Tcl_SetHashValue (tn->he, (ClientData) tn); + + Tcl_SetObjResult (interp, objv [3]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_ROOTNAME -- + * + * Returns the name of the root node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_ROOTNAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree rootname + * [0] [1] + */ + + TN* tn; + + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_SetObjResult (interp, t->root->name); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_SERIALIZE -- + * + * Returns a Tcl value serializing the tree from the optional named node + * on downward. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_SERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree serialize ?node? + * [0] [1] [2] + */ + + TN* tn; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?node?"); + return TCL_ERROR; + } + + if (objc == 2) { + tn = t->root; + } else { + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + } + + Tcl_SetObjResult (interp, tms_serialize (tn)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_SET -- + * + * Adds an attribute and its value to a named node. May replace an + * existing value. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release and allocate memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_SET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree set node key ?value? + * [0] [1] [2] [3] [4] + */ + + TN* tn; + Tcl_HashEntry* he; + CONST char* key; + + if (objc == 4) { + return tm_GET (t, interp, objc, objv); + } + if (objc != 5) { + Tcl_WrongNumArgs (interp, 2, objv, "node key ?value?"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + tn_extend_attr (tn); + + he = Tcl_FindHashEntry (tn->attr, key); + + if (he == NULL) { + int new; + he = Tcl_CreateHashEntry(tn->attr, key, &new); + } else { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + } + + Tcl_IncrRefCount (objv [4]); + Tcl_SetHashValue (he, (ClientData) objv [4]); + + Tcl_SetObjResult (interp, objv [4]); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_SIZE -- + * + * Returns the number of descendants of a named optional node. Defaults + * to #descendants of root. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +tm_SIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree size ?node? + * [0] [1] [2] + */ + + int n; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs (interp, 2, objv, "?node?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* Descendants of root. Cheap. Is size of */ + /* tree minus root. No need to compute full */ + /* structural information. */ + + n = t->nnodes - 1; + } else { + TN* tn; + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + n = tn_ndescendants (tn); + } + + Tcl_SetObjResult (interp, Tcl_NewIntObj (n)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_SPLICE -- + * + * Replaces a series of nodes in a parent with o new node, and makes the + * replaced nodes the children of the new one. Complementary to tm_CUT. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Changes internal pointering of nodes. + * + *--------------------------------------------------------------------------- + */ + +int +tm_SPLICE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree splice parent from ?to ?node?? + * [0] [1] [2] [3] [4] [5] + */ + + TN* p; + TN* new; + int from, to, i; + int nc; + TN** nv; + CONST char* name; + + if ((objc < 4) || (objc > 6)) { + Tcl_WrongNumArgs (interp, 2, objv, "parent from ?to ?node??"); + return TCL_ERROR; + } + + p = tn_get_node (t, objv [2], interp, objv [0]); + if (p == NULL) { + return TCL_ERROR; + } + + if (TclGetIntForIndex (interp, objv [3], p->nchildren - 1, &from) != TCL_OK) { + return TCL_ERROR; + } + + if (objc > 4) { + if (TclGetIntForIndex (interp, objv [4], p->nchildren - 1, &to) != TCL_OK) { + return TCL_ERROR; + } + } else { + to = p->nchildren - 1; + } + + if (from < 0) {from = 0;} + if (to >= p->nchildren) {to = p->nchildren - 1;} + + if (objc > 5) { + new = tn_get_node (t, objv [5], NULL, NULL); + if (new != NULL) { + /* Already present, fail */ + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, objv [5]); + Tcl_AppendToObj (err, "\" already exists in tree \"", -1); + Tcl_AppendObjToObj (err, objv [0]); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + name = Tcl_GetString (objv [5]); + } else { + name = t_newnodename (t); + } + + new = tn_new (t, name); + + /* Move the chosen children to the new node. */ + /* Then insert the new node in their place. */ + + nc = to-from+1; + + if (nc > 0) { + nv = tn_detachmany (p->child [from], nc); + tn_appendmany (new, nc, nv); + ckfree ((char*) nv); + } + + tn_insert (p, from, new); + + Tcl_SetObjResult (interp, new->name); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_SWAP -- + * + * Swap the names of two nodes. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +tm_SWAP (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree swap a b + * [0] [1] [2] [3] + */ + + TN* tna; + TN* tnb; + CONST char* key; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "nodea nodeb"); + return TCL_ERROR; + } + + tna = tn_get_node (t, objv [2], interp, objv [0]); + if (tna == NULL) { + return TCL_ERROR; + } + if (tna == t->root) { + Tcl_AppendResult (interp, "cannot swap root node", NULL); + return TCL_ERROR; + } + + tnb = tn_get_node (t, objv [3], interp, objv [0]); + if (tnb == NULL) { + return TCL_ERROR; + } + if (tnb == t->root) { + Tcl_AppendResult (interp, "cannot swap root node", NULL); + return TCL_ERROR; + } + + if (tna == tnb) { + Tcl_Obj* err = Tcl_NewObj (); + + Tcl_AppendToObj (err, "cannot swap node \"", -1); + Tcl_AppendObjToObj (err, objv [2]); + Tcl_AppendToObj (err, "\" with itself", -1); + + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + { +#define SWAP(a,b,t) t = a; a = b ; b = t +#define SWAPS(x,t) SWAP(tna->x,tnb->x,t) + + /* The two nodes flip all structural information around to trade places */ + /* It might actually be easier to flip the non-structural data */ + /* name, he, attr, data in the node map */ + + Tcl_Obj* to; + Tcl_HashTable* ta; + Tcl_HashEntry* th; + + SWAPS (name, to); + SWAPS (attr, ta); + SWAPS (he, th); + + Tcl_SetHashValue (tna->he, (ClientData) tna); + Tcl_SetHashValue (tnb->he, (ClientData) tnb); + } + + tna->tree->structure = 0; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_UNSET -- + * + * Removes an attribute and its value from a named node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May release memory. + * + *--------------------------------------------------------------------------- + */ + +int +tm_UNSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + /* Syntax: tree unset node key + * [0] [1] [2] [3] + */ + + TN* tn; + Tcl_HashEntry* he; + CONST char* key; + + if (objc != 4) { + Tcl_WrongNumArgs (interp, 2, objv, "node key"); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + key = Tcl_GetString (objv [3]); + + if (tn->attr) { + he = Tcl_FindHashEntry (tn->attr, key); + + if (he != NULL) { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + Tcl_DeleteHashEntry (he); + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_WALK -- + * + * Walks over the tree as per the options and invokes a Tcl script per + * node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the Tcl procedure invoked by the method. + * + *--------------------------------------------------------------------------- + */ + +int +tm_WALK (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + int type, order, rem, res; + Tcl_Obj* avarname; + Tcl_Obj* nvarname; + int lvc; + Tcl_Obj** lvv; + TN* tn; + +#undef USAGE +#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" + + /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script + * [0] [1] [2] [3] [4] [5] [6] [7] [8] [9] + * + * Syntax: tree walk node loopvar script + * [0] [1] [2] [3] [4] + */ + + if ((objc < 5) || (objc > 10)) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (t_walkoptions (interp, 2, objc, objv, + &type, &order, &rem, USAGE) != TCL_OK) { + return TCL_ERROR; + } + + /* Remainder is 'loopvars script' */ + + if (Tcl_ListObjGetElements (interp, objv [rem], &lvc, &lvv) != TCL_OK) { + return TCL_ERROR; + } + if (lvc > 2) { + Tcl_AppendResult (interp, + "too many loop variables, at most two allowed", + NULL); + return TCL_ERROR; + } else if (lvc == 2) { + avarname = lvv [0]; + nvarname = lvv [1]; + + Tcl_IncrRefCount (avarname); + Tcl_IncrRefCount (nvarname); + } else { + avarname = NULL; + nvarname = lvv [0]; + + Tcl_IncrRefCount (nvarname); + } + + if (!strlen (Tcl_GetString (objv [rem+1]))) { + Tcl_AppendResult (interp, + "no script specified, or empty", + NULL); + return TCL_ERROR; + } + + res = t_walk (interp, tn, type, order, + t_walk_invokescript, + objv [rem+1], avarname, nvarname); + + if (avarname) { + Tcl_IncrRefCount (avarname); + } + if (nvarname) { + Tcl_IncrRefCount (nvarname); + } + return res; +} + +/* + *--------------------------------------------------------------------------- + * + * tm_WALKPROC -- + * + * Walks over the tree as per the options and invokes a named Tcl command + * prefix per node. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the Tcl procedure invoked by the method. + * + *--------------------------------------------------------------------------- + */ + +int +tm_WALKPROC (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + int type, order, rem, i, res; + TN* tn; + int cc; + Tcl_Obj** cv; + int ec; + Tcl_Obj** ev; + + /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix + * [0] [1] [2] [3] [4] [5] [6] [7] [8] + * + * Syntax: tree walk node cmdprefix + * [0] [1] [2] [3] + */ + +#undef USAGE +#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" + + if ((objc < 4) || (objc > 9)) { + Tcl_WrongNumArgs (interp, 2, objv, USAGE); + return TCL_ERROR; + } + + tn = tn_get_node (t, objv [2], interp, objv [0]); + if (tn == NULL) { + return TCL_ERROR; + } + + if (t_walkoptions (interp, 1, objc, objv, + &type, &order, &rem, USAGE) != TCL_OK) { + return TCL_ERROR; + } + + /* Remainder is 'cmd' */ + + if (!strlen (Tcl_GetString (objv [rem]))) { + Tcl_AppendResult (interp, + "no script specified, or empty", + NULL); + return TCL_ERROR; + } + if (Tcl_ListObjGetElements (interp, objv [rem], &cc, &cv) != TCL_OK) { + return TCL_ERROR; + } + + ec = cc + 3; + ev = NALLOC (ec, Tcl_Obj*); + + for (i = 0; i < cc; i++) { + ev [i] = cv [i]; + Tcl_IncrRefCount (ev [i]); + } + + res = t_walk (interp, tn, type, order, + t_walk_invokecmd, + (Tcl_Obj*) cc, (Tcl_Obj*) ev, objv [0]); + + ckfree ((char*) ev); + return res; +} + +/* .................................................. */ +/* .................................................. */ + +/* + * Handling of all indices, numeric and 'end-x' forms. Copied straight out of + * the Tcl core as this is not exported through the public API. + * + * I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several + * supporting functions and macros internal to the core. :( + * + * To avoid clashing with the object type in the core the object type here has + * been given a different name. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); +static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* objPtr)); + +Tcl_ObjType EndOffsetType = { + "tcllib/struct::tree/end-offset", /* name */ + (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ + UpdateStringOfEndOffset, /* updateStringProc */ + SetEndOffsetFromAny +}; + +static int +TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr) +{ + if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) { + return TCL_OK; + } + + if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { + /* + * If the object is already an offset from the end of the + * list, or can be converted to one, use it. + */ + + *indexPtr = endValue + objPtr->internalRep.longValue; + + } else { + /* + * Report a parse error. + */ + + if (interp != NULL) { + char *bytes = Tcl_GetString(objPtr); + /* + * The result might not be empty; this resets it which + * should be both a cheap operation, and of little problem + * because this is an error-generation path anyway. + */ + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); + if (!strncmp(bytes, "end-", 3)) { + bytes += 3; + } + TclCheckBadOctal(interp, bytes); + } + + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfEndOffset -- + * + * Update the string rep of a Tcl object holding an "end-offset" + * expression. + * + * Results: + * None. + * + * Side effects: + * Stores a valid string in the object's string rep. + * + * This procedure does NOT free any earlier string rep. If it is + * called on an object that already has a valid string rep, it will + * leak memory. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfEndOffset(objPtr) + register Tcl_Obj* objPtr; +{ + char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; + register int len; + + strcpy(buffer, "end"); + len = sizeof("end") - 1; + if (objPtr->internalRep.longValue != 0) { + buffer[len++] = '-'; + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + } + objPtr->bytes = ckalloc((unsigned) (len+1)); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * SetEndOffsetFromAny -- + * + * Look for a string of the form "end-offset" and convert it + * to an internal representation holding the offset. + * + * Results: + * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * + * Side effects: + * If interp is not NULL, stores an error message in the + * interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +SetEndOffsetFromAny(interp, objPtr) + Tcl_Interp* interp; /* Tcl interpreter or NULL */ + Tcl_Obj* objPtr; /* Pointer to the object to parse */ +{ + int offset; /* Offset in the "end-offset" expression */ + Tcl_ObjType* oldTypePtr = objPtr->typePtr; + /* Old internal rep type of the object */ + register char* bytes; /* String rep of the object */ + int length; /* Length of the object's string rep */ + + /* If it's already the right type, we're fine. */ + + if (objPtr->typePtr == &EndOffsetType) { + return TCL_OK; + } + + /* Check for a string rep of the right form. */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be end?-integer?", + (char*) NULL); + } + return TCL_ERROR; + } + + /* Convert the string rep */ + + if (length <= 3) { + offset = 0; + } else if ((length > 4) && (bytes[3] == '-')) { + /* + * This is our limited string expression evaluator. Pass everything + * after "end-" to Tcl_GetInt, then reverse for offset. + */ + if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + return TCL_ERROR; + } + offset = -offset; + } else { + /* + * Conversion failed. Report the error. + */ + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); + } + return TCL_ERROR; + } + + /* + * The conversion succeeded. Free the old internal rep and set + * the new one. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = offset; + objPtr->typePtr = &EndOffsetType; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckBadOctal -- + * + * This procedure checks for a bad octal value and appends a + * meaningful error to the interp's result. + * + * Results: + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckBadOctal(interp, value) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + CONST char *value; /* String to check. */ +{ + register CONST char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted + * leading zero. Try to generate a meaningful error message. + */ + + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + /* Reached end of string */ + if (interp != NULL) { + /* + * Don't reset the result here because we want this result + * to be added to an existing error message as extra info. + */ + Tcl_AppendResult(interp, " (looks like invalid octal number)", + (char *) NULL); + } + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclFormatInt -- + * + * This procedure formats an integer into a sequence of decimal digit + * characters in a buffer. If the integer is negative, a minus sign is + * inserted at the start of the buffer. A null character is inserted at + * the end of the formatted characters. It is the caller's + * responsibility to ensure that enough storage is available. This + * procedure has the effect of sprintf(buffer, "%d", n) but is faster. + * + * Results: + * An integer representing the number of characters formatted, not + * including the terminating \0. + * + * Side effects: + * The formatted characters are written into the storage pointer to + * by the "buffer" argument. + * + *---------------------------------------------------------------------- + */ + +int +TclFormatInt(buffer, n) + char *buffer; /* Points to the storage into which the + * formatted characters are written. */ + long n; /* The integer to format. */ +{ + long intVal; + int i; + int numFormatted, j; + char *digits = "0123456789"; + + /* + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } + + /* + * Check whether "n" is the maximum negative value. This is + * -2^(m-1) for an m-bit word, and has no positive equivalent; + * negating it produces the same value. + */ + + if (n == -n) { + sprintf(buffer, "%ld", n); + return strlen(buffer); + } + + /* + * Generate the characters of the result backwards in the buffer. + */ + + intVal = (n < 0? -n : n); + i = 0; + buffer[0] = '\0'; + do { + i++; + buffer[i] = digits[intVal % 10]; + intVal = intVal/10; + } while (intVal > 0); + if (n < 0) { + i++; + buffer[i] = '-'; + } + numFormatted = i; + + /* + * Now reverse the characters. + */ + + for (j = 0; j < i; j++, i--) { + char tmp = buffer[i]; + buffer[i] = buffer[j]; + buffer[j] = tmp; + } + return numFormatted; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/m.h b/tcllib/modules/struct/tree/m.h new file mode 100644 index 0000000..366b8de --- /dev/null +++ b/tcllib/modules/struct/tree/m.h @@ -0,0 +1,59 @@ +/* struct::tree - critcl - layer 3 declarations + * Method functions. + */ + +#ifndef _M_H +#define _M_H 1 + +#include "tcl.h" +#include <t.h> + +int tm_TASSIGN (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_TSET (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_ANCESTORS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_APPEND (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_ATTR (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_CHILDREN (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_CUT (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_DELETE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_DEPTH (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_DESCENDANTS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_DESERIALIZE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_DESTROY (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_EXISTS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_GET (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_GETALL (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_HEIGHT (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_INDEX (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_INSERT (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_ISLEAF (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_KEYEXISTS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_KEYS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_LAPPEND (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_LEAVES (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_MOVE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_NEXT (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_NODES (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_NUMCHILDREN (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_PARENT (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_PREVIOUS (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_RENAME (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_ROOTNAME (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_SERIALIZE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_SET (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_SIZE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_SPLICE (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_SWAP (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_UNSET (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_WALK (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); +int tm_WALKPROC (T* td, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +#endif /* _M_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/ms.c b/tcllib/modules/struct/tree/ms.c new file mode 100644 index 0000000..2ca9e9c --- /dev/null +++ b/tcllib/modules/struct/tree/ms.c @@ -0,0 +1,379 @@ +/* struct::tree - critcl - layer 2 definitions + * + * -> Support for the tree methods in layer 3. + */ + +#include <ms.h> +#include <m.h> +#include <t.h> +#include <tn.h> +#include <util.h> + +/* .................................................. */ + +/* + *--------------------------------------------------------------------------- + * + * tms_getchildren -- + * + * Retrieval of the children for a node, either only direct children or + * all, possibly filtering. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +tms_getchildren (TN* n, int all, + int cmdc, Tcl_Obj** cmdv, + Tcl_Obj* tree, Tcl_Interp* interp) +{ + int res; + int listc = 0; + Tcl_Obj** listv = NULL; + + if (all) { + listv = tn_getdescendants (n, &listc); + } else { + listv = tn_getchildren (n, &listc); + } + + if (!listc) { + /* => (listv == NULL) */ + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + return TCL_OK; + } + + res = tn_filternodes (&listc, listv, cmdc, cmdv, tree, interp); + + if (res != TCL_OK) { + ckfree ((char*) listv); + return TCL_ERROR; + } + + if (!listc) { + Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); + } else { + Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); + } + + ckfree ((char*) listv); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * tms_assign -- + * + * Copies the argument tree over into this one. Uses direct + * access to internal data structures for matching tree objects, and + * goes through a serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +tms_assign (Tcl_Interp* interp, T* t, Tcl_Obj* srccmd) +{ + Tcl_CmdInfo srcCmd; + + if (!Tcl_GetCommandInfo(interp, + Tcl_GetString (srccmd), + &srcCmd)) { + Tcl_AppendResult (interp, "invalid command name \"", + Tcl_GetString (srccmd), "\"", NULL); + return TCL_ERROR; + } + + if (srcCmd.objProc == tms_objcmd) { + /* The source tree object is managed by this code also. We can + * retrieve and copy the data directly. + */ + + T* src = (T*) srcCmd.objClientData; + + return t_assign (t, src); + + } else { + /* The source tree is not managed by this package Use + * (de)serialization to transfer the information We do not invoke the + * command proc directly + */ + + int res; + Tcl_Obj* ser; + Tcl_Obj* cmd [2]; + + /* Phase 1: Obtain serialization object by invoking the object method + */ + + cmd [0] = srccmd; + cmd [1] = Tcl_NewStringObj ("serialize", -1); + + Tcl_IncrRefCount (cmd [0]); + Tcl_IncrRefCount (cmd [1]); + + res = Tcl_EvalObjv (interp, 2, cmd, 0); + + Tcl_DecrRefCount (cmd [0]); + Tcl_DecrRefCount (cmd [1]); + + if (res != TCL_OK) { + return TCL_ERROR; + } + + ser = Tcl_GetObjResult (interp); + Tcl_IncrRefCount (ser); + Tcl_ResetResult (interp); + + /* Phase 2: Copy into ourselves using regular deserialization + */ + + res = t_deserialize (t, interp, ser); + Tcl_DecrRefCount (ser); + return res; + } +} + +/* + *--------------------------------------------------------------------------- + * + * tms_set -- + * + * Copies this tree over into the argument tree. Uses direct access to + * internal data structures for matching tree objects, and goes through a + * serialize/deserialize combination otherwise. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +int +tms_set (Tcl_Interp* interp, T* t, Tcl_Obj* dstcmd) +{ + Tcl_CmdInfo dstCmd; + + if (!Tcl_GetCommandInfo(interp, + Tcl_GetString (dstcmd), + &dstCmd)) { + Tcl_AppendResult (interp, "invalid command name \"", + Tcl_GetString (dstcmd), "\"", NULL); + return TCL_ERROR; + } + + if (dstCmd.objProc == tms_objcmd) { + /* The destination tree object is managed by this code also We can + * retrieve and copy the data directly. + */ + + T* dest = (T*) dstCmd.objClientData; + + return t_assign (dest, t); + + } else { + /* The destination tree is not managed by this package Use + * (de)serialization to transfer the information We do not invoke the + * command proc directly. + */ + + int res; + Tcl_Obj* ser; + Tcl_Obj* cmd [3]; + + /* Phase 1: Obtain our serialization */ + + ser = tms_serialize (t->root); + + /* Phase 2: Copy into destination by invoking its deserialization + * method + */ + + cmd [0] = dstcmd; + cmd [1] = Tcl_NewStringObj ("deserialize", -1); + cmd [2] = ser; + + Tcl_IncrRefCount (cmd [0]); + Tcl_IncrRefCount (cmd [1]); + Tcl_IncrRefCount (cmd [2]); + + res = Tcl_EvalObjv (interp, 3, cmd, 0); + + Tcl_DecrRefCount (cmd [0]); + Tcl_DecrRefCount (cmd [1]); + Tcl_DecrRefCount (cmd [2]); /* == ser, is gone now */ + + if (res != TCL_OK) { + return TCL_ERROR; + } + + Tcl_ResetResult (interp); + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * tms_serialize -- + * + * Generates Tcl value from tree, serialized tree data. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Only internal, memory allocation changes ... + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +tms_serialize (TN* n) +{ + Tcl_Obj* ser; + int end; + int listc; + Tcl_Obj** listv; + Tcl_Obj* empty; + + listc = 3 * (tn_ndescendants (n) + 1); + listv = NALLOC (listc, Tcl_Obj*); + empty = Tcl_NewObj (); + Tcl_IncrRefCount (empty); + + end = tn_serialize (n, listc, listv, 0, -1, empty); + + ASSERT (listc == end, "Bad serialization"); + + ser = Tcl_NewListObj (listc, listv); + + Tcl_DecrRefCount (empty); + ckfree((char*) listv); + + return ser; +} + +/* + *--------------------------------------------------------------------------- + * + * tms_objcmd -- + * + * Implementation of tree objects, the main dispatcher function. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Per the called methods. + * + *--------------------------------------------------------------------------- + */ + +int +tms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) +{ + T* t = (T*) cd; + int m; + + static CONST char* methods [] = { + "-->", "=", "ancestors", "append", "attr", + "children", "cut", "delete", "depth", "descendants", + "deserialize", "destroy", "exists", "get", "getall", + "height", "index", "insert", "isleaf", "keyexists", + "keys", "lappend", "leaves", "move", "next", + "nodes", "numchildren", "parent", "previous", "rename", + "rootname", "serialize", "set", "size", "splice", + "swap", "unset", "walk", "walkproc", + NULL + }; + enum methods { + M_TSET, M_TASSIGN, M_ANCESTORS, M_APPEND, M_ATTR, + M_CHILDREN, M_CUT, M_DELETE, M_DEPTH, M_DESCENDANTS, + M_DESERIALIZE, M_DESTROY, M_EXISTS, M_GET, M_GETALL, + M_HEIGHT, M_INDEX, M_INSERT, M_ISLEAF, M_KEYEXISTS, + M_KEYS, M_LAPPEND, M_LEAVES, M_MOVE, M_NEXT, + M_NODES, M_NUMCHILDREN, M_PARENT, M_PREVIOUS, M_RENAME, + M_ROOTNAME, M_SERIALIZE, M_SET, M_SIZE, M_SPLICE, + M_SWAP, M_UNSET, M_WALK, M_WALKPROC + }; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case M_TASSIGN: return tm_TASSIGN (t, interp, objc, objv); + case M_TSET: return tm_TSET (t, interp, objc, objv); + case M_ANCESTORS: return tm_ANCESTORS (t, interp, objc, objv); + case M_APPEND: return tm_APPEND (t, interp, objc, objv); + case M_ATTR: return tm_ATTR (t, interp, objc, objv); + case M_CHILDREN: return tm_CHILDREN (t, interp, objc, objv); + case M_CUT: return tm_CUT (t, interp, objc, objv); + case M_DELETE: return tm_DELETE (t, interp, objc, objv); + case M_DEPTH: return tm_DEPTH (t, interp, objc, objv); + case M_DESCENDANTS: return tm_DESCENDANTS (t, interp, objc, objv); + case M_DESERIALIZE: return tm_DESERIALIZE (t, interp, objc, objv); + case M_DESTROY: return tm_DESTROY (t, interp, objc, objv); + case M_EXISTS: return tm_EXISTS (t, interp, objc, objv); + case M_GET: return tm_GET (t, interp, objc, objv); + case M_GETALL: return tm_GETALL (t, interp, objc, objv); + case M_HEIGHT: return tm_HEIGHT (t, interp, objc, objv); + case M_INDEX: return tm_INDEX (t, interp, objc, objv); + case M_INSERT: return tm_INSERT (t, interp, objc, objv); + case M_ISLEAF: return tm_ISLEAF (t, interp, objc, objv); + case M_KEYEXISTS: return tm_KEYEXISTS (t, interp, objc, objv); + case M_KEYS: return tm_KEYS (t, interp, objc, objv); + case M_LAPPEND: return tm_LAPPEND (t, interp, objc, objv); + case M_LEAVES: return tm_LEAVES (t, interp, objc, objv); + case M_MOVE: return tm_MOVE (t, interp, objc, objv); + case M_NEXT: return tm_NEXT (t, interp, objc, objv); + case M_NODES: return tm_NODES (t, interp, objc, objv); + case M_NUMCHILDREN: return tm_NUMCHILDREN (t, interp, objc, objv); + case M_PARENT: return tm_PARENT (t, interp, objc, objv); + case M_PREVIOUS: return tm_PREVIOUS (t, interp, objc, objv); + case M_RENAME: return tm_RENAME (t, interp, objc, objv); + case M_ROOTNAME: return tm_ROOTNAME (t, interp, objc, objv); + case M_SERIALIZE: return tm_SERIALIZE (t, interp, objc, objv); + case M_SET: return tm_SET (t, interp, objc, objv); + case M_SIZE: return tm_SIZE (t, interp, objc, objv); + case M_SPLICE: return tm_SPLICE (t, interp, objc, objv); + case M_SWAP: return tm_SWAP (t, interp, objc, objv); + case M_UNSET: return tm_UNSET (t, interp, objc, objv); + case M_WALK: return tm_WALK (t, interp, objc, objv); + case M_WALKPROC: return tm_WALKPROC (t, interp, objc, objv); + } + /* Not coming to this place */ +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/ms.h b/tcllib/modules/struct/tree/ms.h new file mode 100644 index 0000000..3f48af5 --- /dev/null +++ b/tcllib/modules/struct/tree/ms.h @@ -0,0 +1,29 @@ +/* struct::tree - critcl - layer 2 declarations + * Support for tree methods. + */ + +#ifndef _MS_H +#define _MS_H 1 + +#include "tcl.h" +#include <ds.h> + +int tms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv); + +int tms_assign (Tcl_Interp* interp, TPtr t, Tcl_Obj* srccmd); +int tms_set (Tcl_Interp* interp, TPtr t, Tcl_Obj* dstcmd); +Tcl_Obj* tms_serialize (TNPtr n); + +int tms_getchildren (TNPtr n, int all, + int cmdc, Tcl_Obj** cmdv, + Tcl_Obj* tree, Tcl_Interp* interp); + +#endif /* _MS_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/shimmer.c b/tcllib/modules/struct/tree/shimmer.c new file mode 100644 index 0000000..52e0c9a --- /dev/null +++ b/tcllib/modules/struct/tree/shimmer.c @@ -0,0 +1,147 @@ +/* struct::tree - critcl - layer 1 definitions. + * (b) Node operations. + * Tcl_ObjType for nodes, and shimmering to it. + */ + +#include <string.h> +#include <tn.h> + +/* .................................................. */ + +static void free_rep (Tcl_Obj* obj); +static void dup_rep (Tcl_Obj* obj, Tcl_Obj* dup); +static void string_rep (Tcl_Obj* obj); +static int from_any (Tcl_Interp* ip, Tcl_Obj* obj); + +static +Tcl_ObjType tn_type = { + "tcllib::struct::tree/critcl::node", + free_rep, + dup_rep, + string_rep, + from_any +}; + +/* .................................................. */ + +static void +free_rep (Tcl_Obj* obj) +{ + /* Nothing to do. The rep is the TN in the T. */ +} + +static void +dup_rep (Tcl_Obj* obj, Tcl_Obj* dup) +{ + TNPtr n = (TNPtr) obj->internalRep.otherValuePtr; + + dup->internalRep.otherValuePtr = n; + dup->typePtr = &tn_type; +} + +static void +string_rep (Tcl_Obj* obj) +{ + Tcl_Obj* temp; + char* str; + TNPtr n = (TNPtr) obj->internalRep.otherValuePtr; + + obj->length = n->name->length; + obj->bytes = ckalloc (obj->length + 1); + + memcpy (obj->bytes, n->name->bytes, obj->length + 1); +} + +static int +from_any (Tcl_Interp* ip, Tcl_Obj* obj) +{ + Tcl_Panic ("Cannot create TDN structure via regular shimmering."); + return TCL_ERROR; +} + +/* .................................................. */ + +void +tn_shimmer (Tcl_Obj* o, TNPtr n) +{ + /* Release an existing representation */ + + if (o->typePtr && o->typePtr->freeIntRepProc) { + o->typePtr->freeIntRepProc (o); + } + + o->typePtr = &tn_type; + o->internalRep.otherValuePtr = n; +} + +/* .................................................. */ + +TNPtr +tn_get_node (TPtr t, Tcl_Obj* node, Tcl_Interp* interp, Tcl_Obj* tree) +{ + TN* n = NULL; + Tcl_HashEntry* he; + + /* Check if we have a valid cached int.rep. */ + +#if 0 + /* [x] TODO */ + /* Caching of handles implies that the trees have to */ + /* keep track of the tcl_obj pointing to them. So that */ + /* the int.rep can be invalidated upon tree deletion */ + + if (node->typePtr == &tn_type) { + n = (TN*) node->internalRep.otherValuePtr; + if (n->tree == t) { +#if 0 + fprintf (stderr, "cached: %p (%p - %p)\n", n, t, n->tree); + fflush(stderr); +#endif + return n; + } + } +#endif + /* Incompatible int.rep, or refering to a different + * tree. We go through the hash table. + */ + + he = Tcl_FindHashEntry (&t->node, Tcl_GetString (node)); + + if (he != NULL) { + n = (TN*) Tcl_GetHashValue (he); + + /* Shimmer the object, cache the node information. + */ + + tn_shimmer (node, n); + return n; + } + + /* Node handle not found. Leave an error message, + * if possible. + */ + + if (interp != NULL) { + Tcl_Obj* err = Tcl_NewObj (); + + /* Keep any prefix ... */ + Tcl_AppendObjToObj (err, Tcl_GetObjResult (interp)); + Tcl_AppendToObj (err, "node \"", -1); + Tcl_AppendObjToObj (err, node); + Tcl_AppendToObj (err, "\" does not exist in tree \"", -1); + Tcl_AppendObjToObj (err, tree); + Tcl_AppendToObj (err, "\"", -1); + + Tcl_SetObjResult (interp, err); + } + return NULL; +} + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/t.c b/tcllib/modules/struct/tree/t.c new file mode 100644 index 0000000..c54f112 --- /dev/null +++ b/tcllib/modules/struct/tree/t.c @@ -0,0 +1,440 @@ +/* struct::tree - critcl - layer 1 definitions + * (c) Tree functions + */ + +#include <t.h> +#include <tn.h> +#include <util.h> + +/* .................................................. */ + +T* +t_new (void) +{ + T* t = ALLOC (T); + + Tcl_InitHashTable (&t->node, TCL_STRING_KEYS); + + t->cmd = NULL; + t->counter = 0; + t->nodes = NULL; + t->nnodes = 0; + t->leaves = NULL; + t->nleaves = 0; + t->root = tn_new (t, "root"); + t->structure = 0; + + return t; +} + +void +t_delete (T* t) +{ + /* Delete a tree in toto. Recursively deletes all nodes first, + * starting at root. This also handles the nodes/leaves lists. + * Then the name -> node mapping, and the object name. The + */ + + tn_delete (t->root); + + Tcl_DeleteHashTable(&t->node); + + t->cmd = NULL; + ckfree ((char*) t); +} + +/* .................................................. */ + +void +t_structure (T* t) +{ + /* Computes all structural data, + * then declares it valid. + */ + + tn_structure (t->root, 0); + t->structure = 1; +} + +/* .................................................. */ + +int +t_deserialize (T* dst, Tcl_Interp* interp, Tcl_Obj* src) +{ + int listc; + Tcl_Obj** listv; + int nodes; + + int root = -1; + int* parent = NULL; + + /* Basic checks: + * - Is the input a list ? + * - Is its length a multiple of three ? + * + * structure: node-name parent-index attr-dict + * i+0 i+1 i+2 + */ + +#define NAME(i) (i) +#define PARENT(i) ((i)+1) +#define ATTR(i) ((i)+2) + + if (Tcl_ListObjGetElements (interp, src, &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + if ((listc % 3) != 0) { + Tcl_AppendResult (interp, + "error in serialization: list length not a multiple of 3.", + NULL); + return TCL_ERROR; + } + + nodes = listc/3; + + /* Iterate and check the attribute dictionaries for listness and + * size (even length). + */ + + { + int ac; + Tcl_Obj** av; + int i, j; + + for (i = 0, j = 0; + i < listc; + i += 3, j++) { + + ASSERT_BOUNDS (ATTR(i), listc); + ASSERT_BOUNDS (j, nodes); + + if (Tcl_ListObjGetElements (interp, listv [ATTR(i)], + &ac, &av) != TCL_OK) { + return TCL_ERROR; + } + if ((ac % 2) != 0) { + Tcl_AppendResult (interp, + "error in serialization: malformed attribute dictionary.", + NULL); + return TCL_ERROR; + } + } + } + + /* Iterate to locate the definition of root. Fails if there is none, + * or more than one. + */ + + { + int i, j; + CONST char* parent; + + for (i = 0, j = 0, root = -1; + i < listc; + i += 3, j++) { + /* j == i/3 */ + + ASSERT_BOUNDS (PARENT(i), listc); + ASSERT_BOUNDS (j, nodes); + + parent = Tcl_GetString (listv [PARENT(i)]); + + if (0 == strcmp ("", parent)) { + if (root >= 0) { + Tcl_AppendResult (interp, + "error in serialization: multiple root nodes.", + NULL); + return TCL_ERROR; + } + + root = j; + } + } + + if (root < 0) { + Tcl_AppendResult (interp, + "error in serialization: no root specified.", + NULL); + return TCL_ERROR; + } + } + + /* Iterate again, check that the non-empty parent references + * are ok. We use the information we have about root to skip + * over the empty reference. We save the extracted and parsed + * references in a temp. allocated array. + */ + + { + int i, j, index, res; + Tcl_Obj* p; + + parent = NALLOC (nodes, int); + + ASSERT_BOUNDS (root, nodes); + parent [root] = -1; /* Sensible, unused */ + + for (i = 0, j = 0; + i < listc; + i += 3, j++) { + /* j == i/3 */ + + ASSERT_BOUNDS (PARENT(i), listc); + ASSERT_BOUNDS (j, nodes); + + if (j == root) + continue; + + p = listv [PARENT(i)]; + res = Tcl_GetIntFromObj (interp, p, &index); + + if ( + (res != TCL_OK) || + (index < 0) || + (index >= listc) || + ((index % 3) != 0) + ) { + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "error in serialization: bad parent reference \"", + Tcl_GetString (p), + "\".", NULL); + ckfree ((char*) parent); + return TCL_ERROR; + } + + if (index == i) { + /* Found a cyclic reference (direct cycle, node defines + * itself as its parent) + */ + + Tcl_AppendResult (interp, + "error in serialization: cycle detected.", + NULL); + ckfree ((char*) parent); + return TCL_ERROR; + } + + parent [j] = index/3; + } + } + + /* Iteration over the parent information from the last phase. We + * are looking for indirect cycles. We detect them indirectly. If + * there are cycles we are unable to tag all nodes starting from the + * root. A tag means that the depth of the node can be computed, and + * for nodes in a cycle this is not possible. + */ + + { + int* tag = NALLOC (nodes, int); + int i; + int changed = 1; /* Flag that last iteration tagged new nodes */ + int done = 0; /* #nodes tagged */ + + for (i = 0; i < nodes; i++) { + + ASSERT_BOUNDS (i, nodes); + tag [i] = 0; + } + + ASSERT_BOUNDS (root, nodes); + tag [root] = 1; + done ++; + + while (changed) { + changed = 0; + + for (i = 0; i < nodes; i++) { + ASSERT_BOUNDS (i, nodes); + if (tag [i]) + continue; + + /* Assert: parent [i] in 0 .. nodes-1 */ + ASSERT_BOUNDS (parent[i], nodes); + if (!tag [parent [i]]) + continue; + + tag [i] = 1; + changed = 1; + done ++; + } + } + + ckfree ((char*) tag); + + if (done < nodes) { + Tcl_AppendResult (interp, + "error in serialization: cycle detected.", + NULL); + + ckfree ((char*) parent); + return TCL_ERROR; + } + } + + /* Last iteration. Check that the node names are unique. + */ + + { + int i, j, new; + Tcl_HashTable nx; + + Tcl_InitHashTable (&nx, TCL_STRING_KEYS); + + for (i = 0, j = 0; + i < listc; + i += 3, j++) { + + ASSERT_BOUNDS (NAME(i), listc); + ASSERT_BOUNDS (j, nodes); + + Tcl_CreateHashEntry (&nx, Tcl_GetString (listv [NAME(i)]), + &new); + + if (!new) { + Tcl_AppendResult (interp, + "error in serialization: duplicate node names.", + NULL); + Tcl_DeleteHashTable(&nx); + ckfree ((char*) parent); + return TCL_ERROR; + } + } + + Tcl_DeleteHashTable(&nx); + } + + /* The serialization has been successfully validated now. + * We create the nodes, their attributes, and link them + * into the proper structure per the root and parent + * information provided to us by the validation. + */ + + { + int i, j; + TN** nv = NALLOC (nodes, TN*); + TN* n; + TN* p; + + tn_delete (dst->root); + + for (i = 0, j = 0; + i < listc; + i += 3, j++) { + /* j == i/3 */ + + ASSERT_BOUNDS (NAME(i), listc); + ASSERT_BOUNDS (j, nodes); + + nv [j] = tn_new (dst, Tcl_GetString (listv [NAME(i)])); + } + + dst->root = nv [root]; + + for (i = 0, j = 0; + i < listc; + i += 3, j++) { + /* j == i/3 */ + + ASSERT_BOUNDS (ATTR(i), listc); + ASSERT_BOUNDS (j, nodes); + + if (j == root) { + /* We don't append the node, this has already been covered, + * but we have to process the attributes. + */ + + tn_set_attr (nv [j], interp, listv [ATTR(i)]); + continue; + } + + ASSERT_BOUNDS (parent[j], nodes); + + n = nv [j]; + p = nv [parent [j]]; + + tn_append (p, n); + tn_set_attr (n, interp, listv [ATTR(i)]); + } + + ckfree ((char*) nv); + } + + ckfree ((char*) parent); + return TCL_OK; +} + +/* .................................................. */ + +int +t_assign (T* dst, T* src) +{ + tn_delete (dst->root); + dst->root = tn_dup (dst, src->root); + return TCL_OK; +} + +/* .................................................. */ + +CONST char* +t_newnodename (T* t) +{ + int ok; + Tcl_HashEntry* he; + + do { + t->counter ++; + sprintf (t->handle, "node%d", t->counter); + + /* Check that there is no node using that name already */ + he = Tcl_FindHashEntry (&t->node, t->handle); + ok = (he == NULL); + } while (!ok); + + return t->handle; +} + +/* .................................................. */ + +void +t_dump (TPtr t, FILE* f) +{ + /* Write the structural data of the + * tree (i.e. internal pointers) to + * the file, as aid in debugging + */ + + Tcl_HashSearch hs; + Tcl_HashEntry* he; + TNPtr n; + + fprintf (f, "T (%p) {\n",t);fflush(f); + fprintf (f, ". Lstart %p '%s'\n", t->leaves, t->leaves?Tcl_GetString(t->leaves->name):"");fflush(f); + fprintf (f, ". Nstart %p '%s'\n", t->nodes, t->nodes ?Tcl_GetString(t->nodes ->name):"");fflush(f); + + for (he = Tcl_FirstHashEntry (&t->node, &hs); + he != NULL; + he = Tcl_NextHashEntry (&hs)) { + n = (TNPtr) Tcl_GetHashValue(he); + fprintf (f, ". N [%p '%s']",n,Tcl_GetString(n->name)) ;fflush(f); + fprintf (f, " %p",n->tree);fflush(f); + fprintf (f, " %p '%s'",n->prevleaf,n->prevleaf?Tcl_GetString(n->prevleaf->name):"");fflush(f); + fprintf (f, " %p '%s'",n->nextleaf,n->nextleaf?Tcl_GetString(n->nextleaf->name):"");fflush(f); + fprintf (f, " %p '%s'",n->prevnode,n->prevnode?Tcl_GetString(n->prevnode->name):"");fflush(f); + fprintf (f, " %p '%s'",n->nextnode,n->nextnode?Tcl_GetString(n->nextnode->name):"");fflush(f); + fprintf (f, " %p '%s'",n->parent ,n->parent ?Tcl_GetString(n->parent->name) :"");fflush(f); + fprintf (f, "\n");fflush(f); + } + fprintf (f, "}\n");fflush(f); +} + +/* .................................................. */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/t.h b/tcllib/modules/struct/tree/t.h new file mode 100644 index 0000000..20def33 --- /dev/null +++ b/tcllib/modules/struct/tree/t.h @@ -0,0 +1,59 @@ +/* struct::tree - critcl - layer 1 declarations + * (c) Tree functions + */ + +#ifndef _T_H +#define _T_H 1 + +#include "tcl.h" +#include <ds.h> + +TPtr t_new (void); +void t_delete (TPtr t); +void t_structure (TPtr t); +void t_dump (TPtr t, FILE* f); + +int t_deserialize (TPtr dst, Tcl_Interp* interp, Tcl_Obj* src); +int t_assign (TPtr dst, TPtr src); + +enum wtypes { + WT_BFS, WT_DFS +}; + +enum worder { + WO_BOTH, WO_IN, WO_PRE, WO_POST +}; + +typedef int (*t_walk_function) (Tcl_Interp* interp, + TN* n, Tcl_Obj* cs, + Tcl_Obj* da, Tcl_Obj* db, + Tcl_Obj* action); + +int t_walkoptions (Tcl_Interp* interp, int n, + int objc, Tcl_Obj* CONST* objv, + int* type, int* order, int* remainder, + char* usage); + +int t_walk (Tcl_Interp* interp, TN* tdn, int type, int order, + t_walk_function f, Tcl_Obj* cs, + Tcl_Obj* avn, Tcl_Obj* nvn); + +int t_walk_invokescript (Tcl_Interp* interp, TN* n, Tcl_Obj* cs, + Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); + +int t_walk_invokecmd (Tcl_Interp* interp, TN* n, Tcl_Obj* dummy0, + Tcl_Obj* dummy1, Tcl_Obj* dummy2, + Tcl_Obj* action); + +CONST char* t_newnodename (T* td); + +#endif /* _T_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/tests/Xsupport b/tcllib/modules/struct/tree/tests/Xsupport new file mode 100644 index 0000000..0dd09ef --- /dev/null +++ b/tcllib/modules/struct/tree/tests/Xsupport @@ -0,0 +1,157 @@ +# -*- tcl -*- +# tree.testsupport: Helper commands for the testsuite. +# +# Copyright (c) 2007 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# All rights reserved. +# +# RCS: @(#) $Id: Xsupport,v 1.1 2007/04/12 03:01:56 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +# Callbacks for tree walking. +# Remember the node in a global variable. + +proc walker {node} { + lappend ::FOO $node +} + +proc pwalker {tree n a} { + lappend ::t $a $n +} + +proc pwalkern {tree n a} { + lappend ::t $n +} + +proc pwalkercont {tree n a} { + if {[string equal $n "b"]} {lappend ::t . ; return -code continue} + lappend ::t $a $n +} + +proc pwalkerbreak {tree n a} { + if {[string equal $n "b"]} {lappend ::t . ; return -code break} + lappend ::t $a $n +} + +proc pwalkerret {tree n a} { + if {[string equal $n "b"]} { + lappend ::t . + return -code return good-return + } + lappend ::t $a $n +} + +proc pwalkererr {tree n a} { + if {[string equal $n "b"]} { + lappend ::t . + error fubar + } + lappend ::t $a $n +} + +proc pwalkerprune {tree n a} { + lappend ::t $a $n + if {$::prune && ($n == 2)} {struct::tree::prune} +} + +proc pwalkerpruneb {tree n a} { + lappend ::t $a $n + if {($n == 2)} {struct::tree::prune} +} + +# Validate a serialization against the tree it +# was generated from. + +proc validate_serial {t serial {rootname {}}} { + if {$rootname == {}} { + set rootname [$t rootname] + } + + # List length is multiple of 3 + if {[llength $serial] % 3} { + return serial/wrong#elements + } + + # Scan through list and built a number helper + # structures (arrays). + + array set a {} + array set p {} + array set ch {} + foreach {node parent attr} $serial { + # Node has to exist in tree + if {![$t exists $node]} { + return node/$node/unknown + } + if {![info exists ch($node)]} {set ch($node) {}} + # Parent reference has to be empty or + # integer, == 0 %3, >=0, < length serial + if {$parent != {}} { + if {![string is integer -strict $parent]} { + return node/$node/parent/no-integer/$parent + } + if {$parent % 3} { + return node/$node/parent/not-triple/$parent + } + if {$parent < 0} { + return node/$node/parent/out-of-bounds/$parent + } + if {$parent >= [llength $serial]} { + return node/$node/parent/out-of-bounds/$parent + } + # Resolve parent index into node name, has to match + set parentnode [lindex $serial $parent] + if {![$t exists $parentnode]} { + return node/$node/parent/unknown/$parent/$parentnode + } + if {![string equal [$t parent $node] $parentnode]} { + return node/$node/parent/mismatch/$parent/$parentnode/[$t parent $node] + } + lappend ch($parentnode) $node + } else { + set p($node) {} + } + # Attr list has to be of even length. + if {[llength $attr] % 2} { + return attr/$node/wrong#elements + } + # Attr have to exist and match in all respects + if {![string equal \ + [dictsort $attr] \ + [dictsort [$t getall $node]]]} { + return attr/$node/mismatch + } + } + # Second pass, check that the children information is encoded + # correctly. Reconstructed data has to match originals. + + foreach {node parent attr} $serial { + if {![string equal $ch($node) [$t children $node]]} { + return node/$node/children/mismatch + } + } + + # Reverse check + # - List of nodes from the 'rootname' and check + # that it and all its children are present + # in the structure. + + set ::FOO {} + mytree walk $rootname n {walker $n} + + foreach n $::FOO { + if {![info exists ch($n)]} { + return node/$n/mismatch/reachable/missing + } + } + if {[llength $::FOO] != [llength $serial]/3} { + return structure/mismatch/#nodes/multiples + } + if {[llength $::FOO] != [array size ch]} { + return structure/mismatch/#nodes/multiples/ii + } + return ok +} + +#---------------------------------------------------------------------- diff --git a/tcllib/modules/struct/tree/tn.c b/tcllib/modules/struct/tree/tn.c new file mode 100644 index 0000000..2e83fa4 --- /dev/null +++ b/tcllib/modules/struct/tree/tn.c @@ -0,0 +1,1147 @@ +/* struct::tree - critcl - layer 1 declarations + * (b) Node operations. + */ + +#include <tn.h> +#include <util.h> + +/* .................................................. */ + +static void extend_children (TNPtr n); +static int fill_descendants (TNPtr n, int lc, Tcl_Obj** lv, int at); + +/* .................................................. */ + +TNPtr +tn_new (TPtr t, CONST char* name) +{ + TNPtr n = ALLOC (TN); + int new; + + n->name = Tcl_NewStringObj(name, -1); + Tcl_IncrRefCount (n->name); + tn_shimmer (n->name, n); + + if (Tcl_FindHashEntry (&t->node, name) != NULL) { + Tcl_Panic ("struct::tree(c) tn_new - tried to use duplicate name for new node"); + } + + n->he = Tcl_CreateHashEntry(&t->node, name, &new); + Tcl_SetHashValue (n->he, (ClientData) n); + + n->tree = t; + n->nextleaf = NULL; + n->prevleaf = NULL; + n->nextnode = NULL; + n->prevnode = NULL; + + tn_node (n); + tn_leaf (n); + + n->parent = NULL; + n->child = NULL; + n->maxchildren = 0; + n->nchildren = 0; + n->left = NULL; + n->right = NULL; + n->attr = NULL; + + n->index = -1; + n->depth = -1; + n->height = -1; + n->desc = -1; + + return n; +} + +void +tn_delete (TNPtr n) +{ + T* t = n->tree; + + /* We assume that the node either has no parent or siblings anymore, + * or that their presence does not matter. The node may still have + * children. They are deleted recursively. That is the situation + * where the parent/sibling information does not matter anymore, and + * can be ignored. + */ + + tn_notleaf (n); + tn_notnode (n); + + Tcl_DecrRefCount (n->name); n->name = NULL; + Tcl_DeleteHashEntry (n->he); n->he = NULL; + + if (n->child) { + int i; + + for (i = 0; i < n->nchildren; i++) { + ASSERT_BOUNDS (i, n->nchildren); + + tn_delete (n->child [i]); + n->child [i] = NULL; + } + ckfree ((char*) n->child); + + n->child = NULL; + n->nchildren = 0; + n->maxchildren = 0; + } + + if (n->attr) { + Tcl_HashSearch hs; + Tcl_HashEntry* he; + + for(he = Tcl_FirstHashEntry(n->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); + } + Tcl_DeleteHashTable(n->attr); + ckfree ((char*) n->attr); + n->attr = NULL; + } + + ckfree ((char*) n); +} + +/* .................................................. */ + +void +tn_node (TNPtr n) +{ + TPtr t = n->tree; + TNPtr first = t->nodes; + + t->nnodes ++; + + n->nextnode = first; + n->prevnode = NULL; + t->nodes = n; + + if (!first) return; + first->prevnode = n; +} + +void +tn_notnode (TNPtr n) +{ + T* t = n->tree; + + if ((t->nodes == n) || n->prevnode || n->nextnode) { + if (t->nodes == n) { + t->nodes = n->nextnode; + } + if (n->prevnode) { + n->prevnode->nextnode = n->nextnode; + } + if (n->nextnode) { + n->nextnode->prevnode = n->prevnode; + } + n->prevnode = NULL; + n->nextnode = NULL; + t->nnodes --; + } +} + +void +tn_leaf (TNPtr n) +{ + TPtr t = n->tree; + TNPtr first = t->leaves; + + if ((t->leaves == n) || n->prevleaf || n->nextleaf) { + /* The node is already a leaf */ + return; + } + + /* Now make the non-leaf it a leaf */ + + t->nleaves ++; + + n->nextleaf = first; + n->prevleaf = NULL; + t->leaves = n; + + if (!first) return; + first->prevleaf = n; +} + +void +tn_notleaf (TNPtr n) +{ + T* t = n->tree; + + if ((t->leaves == n) || n->prevleaf || n->nextleaf) { + if (t->leaves == n) { + t->leaves = n->nextleaf; + } + if (n->prevleaf) { + n->prevleaf->nextleaf = n->nextleaf; + } + if (n->nextleaf) { + n->nextleaf->prevleaf = n->prevleaf; + } + n->prevleaf = NULL; + n->nextleaf = NULL; + t->nleaves --; + } +} + +/* .................................................. */ + +void +tn_structure (TNPtr n, int depth) +{ + n->depth = depth; + n->desc = n->nchildren; /* #direct children */ + + depth ++; + + if (n->nchildren) { + int i, maxh, h; + + for (i = 0, maxh = -1; + i < n->nchildren; + i++) { + ASSERT_BOUNDS (i, n->nchildren); + + tn_structure (n->child [i], depth); + + h = n->child [i]->height; + + if (h > maxh) { + maxh = h; + } + } + + n->height = maxh + 1; + } else { + n->height = 0; + } + + /* Extend parent with our descendants. Do not count + * ourselves. This is already done in the parent through + * the 'direct children' clause above at the beginning + * of the function. + */ + + if (n->parent) { + n->parent->desc += n->desc; + } +} + +/* .................................................. */ + +void +tn_detach (TNPtr n) +{ + /* Detaches the node from the tree by removing it from its parent + * node. The sibling relationships are squashed as well, and the + * index information for all right siblings is adjusted. The node + * does retain its children. After this function is called the node + * and its children are ready for tn_delete'. Or reinsertion in a + * different place. + */ + + TNPtr p = n->parent; + + if (p->nchildren == 1) { + /* This node is the last node in its parent. We can release the + * whole array of children now, and declare the parent to be a + * leaf again. There is no need to touch the siblings references, + * we know that they are NULL. + */ + + ckfree ((char*) p->child); + p->child = NULL; + p->maxchildren = 0; + p->nchildren = 0; + + tn_leaf (p); + + } else { + /* The node is somewhere in the array of children of its + * parent. We know the exact location, through 'index'. All + * siblings to the right are moved down one slot, and their index + * is adjusted in the same way. This is an O(n) + * operation. Afterward we adjust the left/right references of the + * node's siblings, if there are any, and reset the node's sibling + * references as well. + */ + + int i; + for (i = n->index; i < (p->nchildren-1); i++) { + + ASSERT_BOUNDS (i, p->nchildren); + ASSERT_BOUNDS (i+1, p->nchildren); + + p->child [i] = p->child [i+1]; + p->child [i]->index --; + } + p->nchildren --; + /* Note regarding the decrement: As the node was _not_ the last + * child we know that the condition 'nchildren > 0' still holds, and + * that there is no need to free the 'child' array. + */ + + if (n->left) { + n->left->right = n->right; + } + if (n->right) { + n->right->left = n->left; + } + + n->left = NULL; + n->right = NULL; + } + + n->parent = NULL; + n->tree->structure = 0; +} + +TNPtr* +tn_detachmany (TNPtr n, int len) +{ + /* Detaches the node n and its 'len -1' right siblings from the tree + * by removing them from their parent node. In toto 'len' nodes are + * removed. The sibling relationships are squashed as well, and the + * index information for all right siblings is adjusted. The nodes + * retain their children. After this function is called thes node + * and their children are ready for tn_delete'. Or reinsertion in a + * different place. + * + * The operation fails with a panic if there are less children we + * can cut than requested. It also panics when trying to cut + * nothing. + * + * Note: This function does not reset the parent reference in the + * cut nodes. + */ + + TNPtr* ch; + TNPtr p = n->parent; + int at = n->index; + int end = at + len; + + ASSERT (end <= p->nchildren, "tn_detachmany - tried to cut too many children"); + ASSERT (len > 0, "tn_detachmany - tried to cut nothing"); + + if ((at == 0) && (end == p->nchildren)) { + /* All children are taken. There is no need to copy anything, we + * can use the whole array, and reset the other information in the + * parent. Note that the condition above implies 'at == 0'. The + * parent node becomes a leaf again. + */ + + ch = p->child; + + p->child = NULL; + p->maxchildren = 0; + p->nchildren = 0; + + tn_leaf (p); + + } else { + /* Copies the cut nodes into a result array. Shifts the right + * siblings down, if there are any. + */ + + int i, k; + + ch = NALLOC (len, TNPtr); + + /* Examples. We always have nchildren = 10. + * + * _______________________________ + * at = 2, len = 3. + * + * 01 234 56789 i = 0, k = 2 + * 012 i = 3, k = 5 + * + * 01 234 56789 i = 2, k = 5 + * 01 567 89 i = 7, k = 10 + * + * _______________________________ + * at = 7, len = 3. + * + * 0123456 789 i = 0, k = 7 + * 012 i = 3, k = 10 + * + * 0123456 789 i = 7, k = 10 + * 0123456 nothing + * + * _______________________________ + * at = 6, len = 3. + * + * 012345 678 9 i = 0, k = 6 + * 012 i = 3, k = 9 + * + * 012345 678 9 i = 6, k = 9 + * 012345 9 i = 7, k = 10 + * + * _______________________________ + * at = 6, len = 1. + * + * 012345 6 789 i = 0, k = 6 + * 0 i = 1, k = 7 + * + * 012345 6 789 i = 6, k = 7 + * 012345 7 89 i = 9, k = 10 + */ + + for (i = 0, k = at; i < len; i++, k++) { + + ASSERT_BOUNDS (k, p->nchildren); + ASSERT_BOUNDS (i, len); + + ch [i] = p->child [k]; + } + + for (i = at, k = end; k < p->nchildren; i++, k++) { + + ASSERT_BOUNDS (k, p->nchildren); + ASSERT_BOUNDS (i, p->nchildren); + + p->child [i] = p->child [k]; + p->child [i]->index -= len; + } + + p->nchildren -= len; + + if (ch [0]->left) { + ch [0]->left->right = ch [len-1]->right; + } + if (ch [len-1]->right) { + ch [len-1]->right->left = ch [0]->left; + } + + ch [0]->left = NULL; + ch [len-1]->right = NULL; + } + + n->tree->structure = 0; + return ch; +} + +TNPtr* +tn_detachchildren (TNPtr n, int* nc) +{ + TNPtr* children = n->child; + + *nc = n->nchildren; + + n->child = NULL; + n->maxchildren = 0; + n->nchildren = 0; + + tn_leaf (n); + return children; +} + +/* .................................................. */ + +void +tn_append (TNPtr p, TNPtr n) +{ + /* Appending is O(1) */ + + /* The node chosen as parent cannot be a leaf (anymore) */ + + int at = p->nchildren; + + tn_notleaf (p); + + /* Allocate/Extend child array as needed */ + + p->nchildren ++; + extend_children (p); + + /* Link the node into the parent and to its left sibling, if + * any. This overwrites any existing relationships. Make sure + * that the node n is either new or was cut before. + */ + + ASSERT_BOUNDS (at, p->nchildren); + + p->child [at] = n; + + n->parent = p; + n->index = at; + n->right = NULL; + + if (at > 0) { + TNPtr sib; + + ASSERT_BOUNDS (at-1, p->nchildren); + + sib = p->child [at-1]; + n->left = sib; + sib->right = n; + } + + p->tree->structure = 0; +} + +void +tn_appendmany (TNPtr p, int nc, TNPtr* nv) +{ + int i; + + /* Appending is O(1) */ + + /* The node chosen as parent cannot be a leaf (anymore) */ + + int at = p->nchildren; + + tn_notleaf (p); + + /* Allocate/Extend child array as needed */ + + p->nchildren += nc; + extend_children (p); + + /* Link the nodes into the parent and to their left siblings, if + * any. This overwrites any existing relationships. Make sure that + * the nodes are either new or were cut before. + */ + + for (i = 0; i < nc; i++, at++) { + + ASSERT_BOUNDS (at, p->nchildren); + ASSERT_BOUNDS (i, nc); + + p->child [at] = nv [i]; + + nv [i]->parent = p; + nv [i]->index = at; + nv [i]->right = NULL; + + if (at > 0) { + TNPtr sib; + + ASSERT_BOUNDS (at, p->nchildren); + + sib = p->child [at-1]; + nv [i]->left = sib; + sib->right = nv [i]; + } + } + + p->tree->structure = 0; +} + +/* .................................................. */ + +void +tn_insert (TNPtr p, int at, TNPtr n) +{ + int i, k; + + if (at >= p->nchildren) { + tn_append (p, n); + return; + } + + /* Insertion at beginning, or somewhere in the middle */ + + if (at < 0) { + at = 0; + } + + /* The node chosen as parent cannot be a leaf */ + /* anymore */ + + tn_notleaf (p); + + /* Allocate/Extend child array as needed */ + + p->nchildren ++; + extend_children (p); + + /* Link the node into the parent and to its left and right siblings, + * if any. This overwrites any existing relationships. Make sure + * that the node n is either new or was cut before. + * + * Shift all nodes at 'at' and to the right one slot up. + * Note that 'nchildren' is incremented already. + */ + + for (i = p->nchildren-1, k = i-1; i > at; i--, k--) { + + ASSERT_BOUNDS (i, p->nchildren); + ASSERT_BOUNDS (k, p->nchildren); + + p->child [i] = p->child [k]; + p->child [i]->index ++; + } + + p->child [at] = n; + + n->parent = p; + n->index = at; + + /* We have to have a right sibling, otherwise it would have been + * appending. We may have a left sibling. + */ + + ASSERT_BOUNDS (at+1, p->nchildren); + + n->right = p->child [at+1]; + p->child [at+1]->left = n; + + if (at == 0) { + n->left = NULL; + } else { + ASSERT_BOUNDS (at-1, p->nchildren); + + n->left = p->child [at-1]; + p->child [at-1]->right = n; + } + + p->tree->structure = 0; +} + +void +tn_insertmany (TNPtr p, int at, int nc, TNPtr* nv) +{ + int i, k; + if (at >= p->nchildren) { + tn_appendmany (p, nc, nv); + return; + } + + if (at < 0) { + at = 0; + } + + /* The node chosen as parent cannot be a leaf */ + /* anymore */ + + tn_notleaf (p); + + /* Allocate/Extend child array as needed */ + + p->nchildren += nc; + extend_children (p); + + /* Link the node into the parent and to its left and right siblings, + * if any. This overwrites any existing relationships. Make sure + * that the node n is either new or was cut before. + * + * Shift all nodes at 'at' and to the right one slot up. + * Note that 'nchildren' is incremented already. + */ + + for (i = p->nchildren-1, k = i-nc; k >= at; i--, k--) { + + ASSERT_BOUNDS (i, p->nchildren); + ASSERT_BOUNDS (k, p->nchildren); + + p->child [i] = p->child [k]; + p->child [i]->index += nc; + } + + for (i = 0, k = at; i < nc; i++, k++) { + + ASSERT_BOUNDS (i, nc); + ASSERT_BOUNDS (k, p->nchildren); + + nv [i]->parent = p; + nv [i]->index = k; + p->child [k] = nv [i]; + } + + for (i = 0, k = at; i < nc; i++, k++) { + if (k > 0) { + ASSERT_BOUNDS (k, p->nchildren); + ASSERT_BOUNDS (k-1, p->nchildren); + + p->child [k]->left = p->child [k-1]; + p->child [k-1]->right = p->child [k]; + } + + if (k < (p->nchildren-1)) { + ASSERT_BOUNDS (k, p->nchildren); + ASSERT_BOUNDS (k+1, p->nchildren); + + p->child [k]->right = p->child [k+1]; + p->child [k+1]->left = p->child [k]; + } + } + + p->tree->structure = 0; +} + +/* .................................................. */ + +void +tn_cut (TNPtr n) +{ + TNPtr p = n->parent; /* Remember the location of n in its */ + int at = n->index; /* parent, this is the point there its + * children are re-inserted */ + int nc; + TNPtr* nv; + + nv = tn_detachchildren (n, &nc); + tn_detach (n); + + tn_insertmany (p, at, nc, nv); + ckfree ((char*) nv); + + tn_delete (n); +} + +TNPtr +tn_dup (TPtr dst, TNPtr src) +{ + TNPtr dstn; + + dstn = tn_new (dst, Tcl_GetString (src->name)); + + if (src->attr) { + int i, new; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + Tcl_HashEntry* dhe; + CONST char* key; + Tcl_Obj* val; + + dstn->attr = ALLOC (Tcl_HashTable); + Tcl_InitHashTable(dstn->attr, TCL_STRING_KEYS); + + for(i = 0, he = Tcl_FirstHashEntry(src->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs), i++) { + + key = Tcl_GetHashKey (src->attr, he); + val = (Tcl_Obj*) Tcl_GetHashValue(he); + + dhe = Tcl_CreateHashEntry(dstn->attr, key, &new); + + Tcl_IncrRefCount (val); + Tcl_SetHashValue (dhe, (ClientData) val); + } + } + + if (src->nchildren) { + int i; + + dstn->child = NALLOC (src->nchildren, TNPtr); + dstn->maxchildren = src->nchildren; + dstn->nchildren = 0; + + for (i = 0; i < src->nchildren; i++) { + + ASSERT_BOUNDS (i, src->nchildren); + + tn_append (dstn, + tn_dup (dst, src->child [i])); + } + } + + return dstn; +} + +/* .................................................. */ + +void +tn_set_attr (TNPtr n, Tcl_Interp* interp, Tcl_Obj* dict) +{ + Tcl_HashEntry* he; + CONST char* key; + Tcl_Obj* val; + int new, i; + int listc; + Tcl_Obj** listv; + + if (Tcl_ListObjGetElements (interp, dict, &listc, &listv) != TCL_OK) { + Tcl_Panic ("Malformed nodes attributes, snuck through validation of serialization."); + } + + if (!listc) { + return; + } + + tn_extend_attr (n); + + for (i = 0; i < listc; i+= 2) { + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + key = Tcl_GetString (listv [i]); + val = listv [i+1]; + + he = Tcl_CreateHashEntry(n->attr, key, &new); + + Tcl_IncrRefCount (val); + Tcl_SetHashValue (he, (ClientData) val); + } +} + +/* .................................................. */ + +void +tn_extend_attr (TNPtr n) +{ + if (n->attr != NULL) { + return; + } + + n->attr = ALLOC (Tcl_HashTable); + Tcl_InitHashTable(n->attr, TCL_STRING_KEYS); +} + +/* .................................................. */ + +int +tn_depth (TNPtr n) +{ + if (!n->tree->structure) { + t_structure (n->tree); + } + return n->depth; +} + +int +tn_height (TNPtr n) +{ + if (!n->tree->structure) { + t_structure (n->tree); + } + return n->height; +} + +int +tn_ndescendants (TNPtr n) +{ + if (n == n->tree->root) { + /* For the root we do not need to know the structure data of the + * tree to determine the number of descendants. It is the number + * of nodes minus one, i.e. all nodes except the root. + */ + + return n->tree->nnodes - 1; + + } else if (!n->nchildren) { + /* If the node has no direct children we know there are no + * descendants as well + */ + + return 0; + + } else if (!n->tree->structure) { + t_structure (n->tree); + } + + return n->desc; +} + +Tcl_Obj** +tn_getdescendants (TNPtr n, int* nc) +{ + int end; + int lc = tn_ndescendants (n); + Tcl_Obj** lv; + + *nc = lc; + + if (lc == 0) { + return NULL; + } + + lv = NALLOC (lc, Tcl_Obj*); + end = fill_descendants (n, lc, lv, 0); + + ASSERT (end == lc, "Bad list of descendants"); + return lv; +} + +Tcl_Obj** +tn_getchildren (TNPtr n, int* nc) +{ + if (!n->nchildren) { + *nc = 0; + return NULL; + } else { + int i; + Tcl_Obj** lv; + + *nc = n->nchildren; + lv = NALLOC (n->nchildren, Tcl_Obj*); + + for (i = 0; i < n->nchildren; i++) { + + ASSERT_BOUNDS (i, n->nchildren); + + lv [i] = n->child [i]->name; + } + + return lv; + } +} + +int +tn_filternodes (int* nc, Tcl_Obj** nv, + int cmdc, Tcl_Obj** cmdv, + Tcl_Obj* tree, Tcl_Interp* interp) +{ + int i; + int ec; + Tcl_Obj** ev; + + if (cmdc && (*nc > 0)) { + /* Run the filter command over all nodes in the list. + * Keep only the nodes passing the filter in the list. + */ + + int lc = *nc; + + int src, dst, res, flag; + + /* Set up the command vector for the callback. + * Two placeholders for tree and node arguments. + */ + + ec = cmdc + 2; + ev = NALLOC (ec, Tcl_Obj*); + + for (i = 0; i < cmdc; i++) { + ASSERT_BOUNDS (i, ec); + + ev [i] = cmdv [i]; + Tcl_IncrRefCount (ev [i]); + } + ASSERT_BOUNDS (cmdc, ec); + + ev [cmdc] = tree; /* Tree */ + Tcl_IncrRefCount (ev [cmdc]); + + /* Run the callback on each element of the list */ + + for (src = 0, dst = 0; + src < lc; + src++) { + + /* Fill the placeholders */ + + ASSERT_BOUNDS (cmdc+1, ec); + ASSERT_BOUNDS (src, lc); + + ev [cmdc+1] = nv [src]; /* Node */ + + /* Run the callback */ + + Tcl_IncrRefCount (ev [cmdc+1]); + + res = Tcl_EvalObjv (interp, ec, ev, 0); + + Tcl_DecrRefCount (ev [cmdc+1]); + + /* Process the result */ + + if (res != TCL_OK) { + goto abort; + } + + if (Tcl_GetBooleanFromObj (interp, + Tcl_GetObjResult (interp), + &flag) != TCL_OK) { + goto abort; + } + + /* Result is valid, use this decide retain/write over */ + + if (!flag) + continue; + + ASSERT_BOUNDS (dst, lc); + ASSERT_BOUNDS (src, lc); + + nv [dst] = nv [src]; + dst++; + } + + /* Cleanup state */ + + Tcl_ResetResult (interp); + + for (i = 0; i < cmdc; i++) { + ASSERT_BOUNDS (i, ec); + Tcl_DecrRefCount (ev [i]); + } + ASSERT_BOUNDS (cmdc, ec); + Tcl_DecrRefCount (ev [cmdc]); /* Tree */ + + ckfree ((char*) ev); + + *nc = dst; + } + + return TCL_OK; + + abort: + /* We do not reset the interp result. It either contains + * the non-boolean result, or the error message + */ + + for (i = 0; i < cmdc; i++) { + ASSERT_BOUNDS (i, ec); + Tcl_DecrRefCount (ev [i]); + } + ASSERT_BOUNDS (cmdc, ec); + Tcl_DecrRefCount (ev [cmdc]); /* Tree */ + + ckfree ((char*) ev); + return TCL_ERROR; +} + +/* .................................................. */ + +int +tn_isancestorof (TNPtr na, TNPtr nb) +{ + /* True <=> a is ancestor of b */ + + for (nb = nb->parent; nb != NULL; ) { + if (na == nb) { + return 1; + } + nb = nb->parent; + } + + return 0; +} + +/* .................................................. */ + +Tcl_Obj* +tn_get_attr (TNPtr tdn, Tcl_Obj* empty) +{ + int i; + Tcl_Obj* res; + int listc; + Tcl_Obj** listv; + Tcl_HashSearch hs; + Tcl_HashEntry* he; + CONST char* key; + + if ((tdn->attr == NULL) || (tdn->attr->numEntries == 0)) { + return empty; + } + + listc = 2 * tdn->attr->numEntries; + listv = NALLOC (listc, Tcl_Obj*); + + for(i = 0, he = Tcl_FirstHashEntry(tdn->attr, &hs); + he != NULL; + he = Tcl_NextHashEntry(&hs)) { + + key = Tcl_GetHashKey (tdn->attr, he); + + ASSERT_BOUNDS (i, listc); + ASSERT_BOUNDS (i+1, listc); + + listv [i] = Tcl_NewStringObj (key, -1); i++; + listv [i] = (Tcl_Obj*) Tcl_GetHashValue(he); i++; + } + + res = Tcl_NewListObj (listc, listv); + ckfree ((char*) listv); + return res; +} + +int +tn_serialize (TNPtr tdn, int listc, Tcl_Obj** listv, int at, int parent, Tcl_Obj* empty) +{ + int self = at; + + ASSERT_BOUNDS (at+0, listc); + ASSERT_BOUNDS (at+1, listc); + ASSERT_BOUNDS (at+2, listc); + + listv [at++] = tdn->name; + listv [at++] = (parent < 0 ? empty : Tcl_NewIntObj (parent)); + listv [at++] = tn_get_attr (tdn, empty); + + if (tdn->nchildren) { + int i; + for (i = 0; i < tdn->nchildren; i++) { + at = tn_serialize (tdn->child [i], listc, listv, at, self, empty); + } + } + + return at; +} + +/* .................................................. */static int +fill_descendants (TNPtr n, int lc, Tcl_Obj** lv, int at) +{ + /* The descendants of the root are simply all nodes except the root + * itself. That is easy to retrieve. + */ + + if (n == n->tree->root) { + TNPtr iter; + + for (iter = n->tree->nodes; + iter != NULL; + iter = iter->nextnode) { + + /* Skip the root node, it is not a descendant! */ + if (iter == n) continue; + + ASSERT_BOUNDS (at, lc); + + lv [at] = iter->name; + at++; + } + } else if (n->child) { + int i; + TNPtr c; + + for (i = 0; i < n->nchildren; i++) { + c = n->child [i]; + + ASSERT_BOUNDS (at, lc); + ASSERT_BOUNDS (i, n->nchildren); + + lv [at] = c->name; + at++; + + at = fill_descendants (c, lc, lv, at); + } + } + + return at; +} + +static void +extend_children (TNPtr n) +{ + if (n->nchildren > n->maxchildren) { + if (n->child == NULL) { + n->child = NALLOC (n->nchildren, TNPtr); + } else { + int nc = 2 * n->nchildren; + TNPtr* new = (TNPtr*) attemptckrealloc ((char*) n->child, + nc * sizeof (TNPtr)); + if (new == NULL) { + nc = n->nchildren; + new = (TNPtr*) ckrealloc ((char*) n->child, nc * sizeof (TNPtr)); + } + n->child = new; + n->maxchildren = nc; + } + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/tn.h b/tcllib/modules/struct/tree/tn.h new file mode 100644 index 0000000..f43506d --- /dev/null +++ b/tcllib/modules/struct/tree/tn.h @@ -0,0 +1,63 @@ +/* struct::tree - critcl - layer 1 declarations + * (b) Node operations. + */ + +#ifndef _TN_H +#define _TN_H 1 + +#include "tcl.h" +#include <ds.h> + +void tn_shimmer (Tcl_Obj* o, TNPtr n); +TNPtr tn_get_node (TPtr t, Tcl_Obj* node, Tcl_Interp* interp, Tcl_Obj* tree); + +TNPtr tn_new (TPtr td, CONST char* name); +TNPtr tn_dup (TPtr dst, TNPtr src); +void tn_delete (TNPtr n); + +void tn_node (TNPtr n); +void tn_notnode (TNPtr n); +void tn_leaf (TNPtr n); +void tn_notleaf (TNPtr n); +void tn_structure (TNPtr n, int depth); + +void tn_detach (TNPtr n); +TNPtr* tn_detachmany (TNPtr n, int len); +TNPtr* tn_detachchildren (TNPtr n, int* nc); + +void tn_append (TNPtr p, TNPtr n); +void tn_insert (TNPtr p, int at, TNPtr n); + +void tn_appendmany (TNPtr p, int nc, TNPtr* nv); +void tn_insertmany (TNPtr p, int at, int nc, TNPtr* nv); + +void tn_cut (TNPtr n); + +int tn_depth (TNPtr n); +int tn_height (TNPtr n); +int tn_ndescendants (TNPtr n); +Tcl_Obj** tn_getdescendants (TNPtr n, int* nc); +Tcl_Obj** tn_getchildren (TNPtr n, int* nc); + +int tn_filternodes (int* nc, Tcl_Obj** nv, + int cmdc, Tcl_Obj** cmdv, + Tcl_Obj* tree, Tcl_Interp* interp); + +int tn_isancestorof (TNPtr a, TNPtr b); + +void tn_extend_attr (TNPtr n); +void tn_set_attr (TNPtr n, Tcl_Interp* interp, Tcl_Obj* dict); +Tcl_Obj* tn_get_attr (TNPtr n, Tcl_Obj* empty); + +int tn_serialize (TNPtr n, int listc, Tcl_Obj** listv, + int at, int parent, Tcl_Obj* empty); + +#endif /* _TN_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/util.c b/tcllib/modules/struct/tree/util.c new file mode 100644 index 0000000..e8aa5d6 --- /dev/null +++ b/tcllib/modules/struct/tree/util.c @@ -0,0 +1,115 @@ +/* struct::tree - critcl - support - stack/queue of nodes. + * definitions. + */ + +#include "tcl.h" +#include <util.h> + +static NL* nlq_newitem (void* n); + + +/* Initialize queue data structure. + */ + +void +nlq_init (NLQ* q) +{ + q->start = q->end = NULL; +} + +/* Add item to end of the list + */ + +void +nlq_append (NLQ* q, void* n) +{ + NL* qi = nlq_newitem (n); + + if (!q->end) { + q->start = q->end = qi; + } else { + q->end->next = qi; + q->end = qi; + } +} + +/* Add item to the front of the list + */ + +void +nlq_push (NLQ* q, void* n) +{ + NL* qi = nlq_newitem (n); + + if (!q->end) { + q->start = q->end = qi; + } else { + qi->next = q->start; + q->start = qi; + } +} + +/* Return item at front of the list. + */ + +void* +nlq_pop (NLQ* q) +{ + NL* qi = NULL; + void* n = NULL; + + if (!q->start) { + return NULL; + } + + qi = q->start; + n = qi->n; + + q->start = qi->next; + if (q->end == qi) { + q->end = NULL; + } + + ckfree ((char*) qi); + return n; +} + +/* Delete all items in the list. + */ + +void* +nlq_clear (NLQ* q) +{ + NL* next; + NL* qi = q->start; + + while (qi) { + next = qi->next; + ckfree ((char*) qi); + qi = next; + } + q->start = NULL; + q->end = NULL; +} + +/* INTERNAL - Create new item to put into the list. + */ + +static NL* +nlq_newitem (void* n) +{ + NL* qi = (NL*) ckalloc (sizeof (NL)); + + qi->n = n; + qi->next = NULL; + + return qi; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/util.h b/tcllib/modules/struct/tree/util.h new file mode 100644 index 0000000..e1f0f49 --- /dev/null +++ b/tcllib/modules/struct/tree/util.h @@ -0,0 +1,65 @@ +/* struct::tree - critcl - layer 0 declarations + * API general utilities + */ + +#ifndef _UTIL_H +#define _UTIL_H 1 + +#include <tcl.h> + +/* Allocation macros for common situations. + */ + +#define ALLOC(type) (type *) ckalloc (sizeof (type)) +#define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type)) + +/* Assertions in general, and asserting the proper range of an array index. + */ + +#undef TREE_DEBUG +#define TREE_DEBUG 1 + +#ifdef TREE_DEBUG +#define XSTR(x) #x +#define STR(x) XSTR(x) +#define RANGEOK(i,n) ((0 <= (i)) && (i < (n))) +#define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__)) ;} +#define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " > " STR(n)) +#else +#define ASSERT(x,msg) +#define ASSERT_BOUNDS(i,n) +#endif + +/* .................................................. */ + +/* NL = Node List. Actually a list of generic pointers. + * NLQ = NL Queue. Also useable as stack. + */ + +typedef struct NL *NLptr; + +typedef struct NL { + NLptr next; + void* n; +} NL; + +typedef struct NLQ { + NLptr start; + NLptr end; +} NLQ; + +void nlq_init (NLQ* q); +void nlq_append (NLQ* q, void* n); +void nlq_push (NLQ* q, void* n); +void* nlq_pop (NLQ* q); +void* nlq_clear (NLQ* q); + +#endif /* _UTIL_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree/walk.c b/tcllib/modules/struct/tree/walk.c new file mode 100644 index 0000000..9c1c814 --- /dev/null +++ b/tcllib/modules/struct/tree/walk.c @@ -0,0 +1,709 @@ + +#include <string.h> +#include "tcl.h" +#include <t.h> +#include <util.h> + +/* .................................................. */ + +static int t_walkdfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); +static int t_walkdfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); +static int t_walkdfsin (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); +static int t_walkdfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* enter, Tcl_Obj* leave); +static int t_walkbfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); +static int t_walkbfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action); +static int t_walkbfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* enter, Tcl_Obj* leave); + +/* .................................................. */ + +int +t_walkoptions (Tcl_Interp* interp, int n, + int objc, Tcl_Obj* CONST* objv, + int* type, int* order, int* remainder, + char* usage) +{ + int i; + Tcl_Obj* otype = NULL; + Tcl_Obj* oorder = NULL; + + static CONST char* wtypes [] = { + "bfs", "dfs", NULL + }; + static CONST char* worders [] = { + "both", "in", "pre", "post", NULL + }; + + for (i = 3; i < objc; ) { + ASSERT_BOUNDS (i, objc); + if (0 == strcmp ("-type", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) { + Tcl_AppendResult (interp, + "value for \"-type\" missing", + NULL); + return TCL_ERROR; + } + + ASSERT_BOUNDS (i+1, objc); + otype = objv [i+1]; + i += 2; + + } else if (0 == strcmp ("-order", Tcl_GetString (objv [i]))) { + if (objc == (i+1)) { + Tcl_AppendResult (interp, + "value for \"-order\" missing", + NULL); + return TCL_ERROR; + } + + ASSERT_BOUNDS (i+1, objc); + oorder = objv [i+1]; + i += 2; + + } else if (0 == strcmp ("--", Tcl_GetString (objv [i]))) { + i++; + break; + } else { + break; + } + } + + if (i == objc) { + Tcl_WrongNumArgs (interp, 2, objv, usage); + return TCL_ERROR; + } + + if ((objc - i) > n) { + Tcl_AppendResult (interp, "unknown option \"", NULL); + Tcl_AppendResult (interp, Tcl_GetString (objv [i]), NULL); + Tcl_AppendResult (interp, "\"", NULL); + return TCL_ERROR; + } + + if (!otype) { + *type = WT_DFS; + } else if (Tcl_GetIndexFromObj (interp, otype, wtypes, "search type", + 0, type) != TCL_OK) { + return TCL_ERROR; + } + + if (!oorder) { + *order = WO_PRE; + } else if (Tcl_GetIndexFromObj (interp, oorder, worders, "search order", + 0, order) != TCL_OK) { + return TCL_ERROR; + } + + if ((*order == WO_IN) && (*type == WT_BFS)) { + Tcl_AppendResult (interp, + "unable to do a in-order breadth first walk", + NULL); + return TCL_ERROR; + } + + *remainder = i; + return TCL_OK; +} + +/* .................................................. */ + +int +t_walk (Tcl_Interp* interp, TN* tdn, int type, int order, + t_walk_function f, Tcl_Obj* cs, + Tcl_Obj* avn, Tcl_Obj* nvn) +{ + int res; + Tcl_Obj* la = NULL; + Tcl_Obj* lb = NULL; + + switch (type) + { + case WT_DFS: + switch (order) + { + case WO_BOTH: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb); + + res = t_walkdfsboth (interp, tdn, f, cs, avn, nvn, la, lb); + + Tcl_DecrRefCount (la); + Tcl_DecrRefCount (lb); + break; + + case WO_IN: + la = Tcl_NewStringObj ("visit",-1); Tcl_IncrRefCount (la); + + res = t_walkdfsin (interp, tdn, f, cs, avn, nvn, la); + + Tcl_DecrRefCount (la); + break; + + case WO_PRE: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + + res = t_walkdfspre (interp, tdn, f, cs, avn, nvn, la); + + Tcl_DecrRefCount (la); + break; + + case WO_POST: + la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la); + + res = t_walkdfspost (interp, tdn, f, cs, avn, nvn, la); + + Tcl_DecrRefCount (la); + break; + } + break; + + case WT_BFS: + switch (order) + { + case WO_BOTH: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + lb = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (lb); + + res = t_walkbfsboth (interp, tdn, f, cs, avn, nvn, la, lb); + + Tcl_DecrRefCount (la); + Tcl_DecrRefCount (lb); + break; + + case WO_PRE: + la = Tcl_NewStringObj ("enter",-1); Tcl_IncrRefCount (la); + + res = t_walkbfspre (interp, tdn, f, cs, avn, nvn, la); + + Tcl_DecrRefCount (la); + break; + + case WO_POST: + la = Tcl_NewStringObj ("leave",-1); Tcl_IncrRefCount (la); + + res = t_walkbfspost (interp, tdn, f, cs, avn, nvn, la); + + Tcl_DecrRefCount (la); + break; + } + break; + } + + /* Error and Return are passed unchanged. Everything else is ok */ + + if (res == TCL_ERROR) {return res;} + if (res == TCL_RETURN) {return res;} + return TCL_OK; +} + + +/* .................................................. */ + +int +t_walk_invokescript (Tcl_Interp* interp, TN* n, Tcl_Obj* cs, + Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + int res; + + /* Note: Array elements, like 'a(x)', are not possible as iterator variables */ + + if (avn) { + Tcl_ObjSetVar2 (interp, avn, NULL, action, 0); + } + Tcl_ObjSetVar2 (interp, nvn, NULL, n->name, 0); + + res = Tcl_EvalObj(interp, cs); + + return res; +} + +int +t_walk_invokecmd (Tcl_Interp* interp, TN* n, Tcl_Obj* dummy0, + Tcl_Obj* dummy1, Tcl_Obj* dummy2, + Tcl_Obj* action) +{ + int res; + int cc = (int) dummy0; + Tcl_Obj** ev = (Tcl_Obj**) dummy1; /* cc+3 elements */ + + ev [cc] = dummy2; /* Tree */ + ev [cc+1] = n->name; /* Node */ + ev [cc+2] = action; /* Action */ + + Tcl_IncrRefCount (ev [cc]); + Tcl_IncrRefCount (ev [cc+1]); + Tcl_IncrRefCount (ev [cc+2]); + + res = Tcl_EvalObjv (interp, cc+3, ev, 0); + + Tcl_DecrRefCount (ev [cc]); + Tcl_DecrRefCount (ev [cc+1]); + Tcl_DecrRefCount (ev [cc+2]); + + return res; +} + +/* .................................................. */ + +static int +t_walkdfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + * prune /5 - skip children, otherwise ok. + */ + + int res; + + /* Parent before children, action is 'enter'. */ + + res = (*f) (interp, tdn, cs, avn, nvn, action); + + if (res == 5) { + return TCL_OK; + } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + if (tdn->nchildren) { + /* We make a copy of the child array. This emulates the behaviour of + * the Tcl implementation, which will walk to a child of this node, + * even if the loop body/procedure moved it to a different node before + * it was reached by the loop here. If the node it the child is moved + * to was already visited nothing else will happen. Ortherwise the + * child will be visited multiple times. + */ + + int i; + int nc = tdn->nchildren; + TN** nv = NALLOC (nc,TN*); + memcpy (nv, tdn->child, nc*sizeof(TN*)); + + for (i = 0; i < nc; i++) { + res = t_walkdfspre (interp, nv [i], f, cs, avn, nvn, action); + + /* prune, continue cannot occur, were transformed into ok + * by the child. + */ + + if (res != TCL_OK) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + return TCL_OK; +} + +static int +t_walkdfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + int res; + + /* Parent after children, action is 'leave'. */ + + if (tdn->nchildren) { + /* We make a copy of the child array. This emulates the behaviour of + * the Tcl implementation, which will walk to a child of this node, + * even if the loop body/procedure moved it to a different node before + * it was reached by the loop here. If the node it the child is moved + * to was already visited nothing else will happen. Ortherwise the + * child will be visited multiple times. + */ + + int i; + + int nc = tdn->nchildren; + TN** nv = NALLOC (nc,TN*); + memcpy (nv, tdn->child, nc*sizeof(TN*)); + + for (i = 0; i < nc; i++) { + res = t_walkdfspost (interp, nv [i], f, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + res = (*f) (interp, tdn, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + return res; + } else if (res == 5) { + /* Illegal pruning */ + + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Illegal attempt to prune post-order walking", NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +static int +t_walkdfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* enter, Tcl_Obj* leave) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + * prune /5 - skip children, otherwise ok. + */ + + int res; + + /* Parent before and after Children, action is 'enter' & 'leave'. */ + + res = (*f) (interp, tdn, cs, avn, nvn, enter); + + if (res != 5) { + if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + if (tdn->nchildren) { + int i; + int nc = tdn->nchildren; + TN** nv = NALLOC (nc,TN*); + memcpy (nv, tdn->child, nc*sizeof(TN*)); + + for (i = 0; i < nc; i++) { + res = t_walkdfsboth (interp, nv [i], f, cs, avn, nvn, enter, leave); + + /* prune, continue cannot occur, were transformed into ok + * by the child. + */ + + if (res != TCL_OK) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + } + + res = (*f) (interp, tdn, cs, avn, nvn, leave); + + if (res == 5) { + return TCL_OK; + } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + return res; + } + + return TCL_OK; +} + +static int +t_walkdfsin (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + int res; + + /* First child visited first, then parent, then */ + /* the remaining children. Action is 'visit'. */ + /* This is the correct thing for binary trees. */ + /* For #children <= 1 the parent is visited */ + /* before the child */ + + if (tdn->nchildren == 0) { + res = (*f) (interp, tdn, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + return res; + } else if (res == 5) { + /* Illegal pruning */ + + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Illegal attempt to prune in-order walking", NULL); + return TCL_ERROR; + } + + } else if (tdn->nchildren == 1) { + res = (*f) (interp, tdn, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + return res; + } else if (res == 5) { + /* Illegal pruning */ + + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Illegal attempt to prune in-order walking", NULL); + return TCL_ERROR; + } + + return t_walkdfsin (interp, tdn->child [0], f, cs, avn, nvn, action); + + } else { + int i; + int nc = tdn->nchildren; + TN** nv = NALLOC (nc,TN*); + memcpy (nv, tdn->child, nc*sizeof(TN*)); + + res = t_walkdfsin (interp, tdn->child [0], f, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + ckfree ((char*) nv); + return res; + } + + res = (*f) (interp, tdn, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + ckfree ((char*) nv); + return res; + } else if (res == 5) { + /* Illegal pruning */ + ckfree ((char*) nv); + + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Illegal attempt to prune in-order walking", NULL); + return TCL_ERROR; + } + + for (i = 1; i < nc; i++) { + res = t_walkdfsin (interp, nv [i], f, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + ckfree ((char*) nv); + return res; + } + } + + ckfree ((char*) nv); + } + + return TCL_OK; +} + +static int +t_walkbfsboth (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* enter, Tcl_Obj* leave) +{ + /* ok - next node + * error - abort walking + * break - pre: abort walking, skip to post, post: abort walking + * continue - next node + * return - abort walking + * prune /5 - skip children, otherwise ok. + */ + + int res; + TN* n; + NLQ q; + NLQ qb; + + nlq_init (&q); + nlq_init (&qb); + + nlq_append (&q, tdn); + nlq_push (&qb, tdn); + + while (1) { + n = nlq_pop (&q); + if (!n) break; + + res = (*f) (interp, n, cs, avn, nvn, enter); + + if (res == 5) { + continue; + } else if (res == TCL_ERROR) { + nlq_clear (&q); + nlq_clear (&qb); + return res; + } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + nlq_clear (&q); + + /* We abort the collection of more nodes, but still run the + * backward iteration (post-order phase). + */ + break; + } + + if (n->nchildren) { + int i; + for (i = 0; i < n->nchildren; i++) { + nlq_append (&q, n->child [i]); + nlq_push (&qb, n->child [i]); + } + } + } + + /* Backward visit to leave */ + + while (1) { + n = nlq_pop (&qb); + if (!n) break; + + res = (*f) (interp, n, cs, avn, nvn, leave); + + if (res == 5) { + continue; + } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + nlq_clear (&qb); + return res; + } + } + + return TCL_OK; +} + +static int +t_walkbfspre (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + /* ok - next node + * error - abort walking + * break - abort walking + * continue - next node + * return - abort walking + * prune /5 - skip children, otherwise ok. + */ + + int res; + TN* n; + NLQ q; + + nlq_init (&q); + nlq_append (&q, tdn); + + while (1) { + n = nlq_pop (&q); + if (!n) break; + + res = (*f) (interp, n, cs, avn, nvn, action); + + if (res == 5) { + continue; + } else if ((res != TCL_OK) && (res != TCL_CONTINUE)) { + nlq_clear (&q); + return res; + } + + if (n->nchildren) { + int i; + for (i = 0; i < n->nchildren; i++) { + nlq_append (&q, n->child [i]); + } + } + } + + return TCL_OK; +} + +static int +t_walkbfspost (Tcl_Interp* interp, TN* tdn, t_walk_function f, + Tcl_Obj* cs, Tcl_Obj* avn, Tcl_Obj* nvn, + Tcl_Obj* action) +{ + int res; + TN* n; + NLQ q; + NLQ qb; + + nlq_init (&q); + nlq_init (&qb); + + nlq_append (&q, tdn); + nlq_push (&qb, tdn); + + while (1) { + n = nlq_pop (&q); + if (!n) break; + + if (n->nchildren) { + int i; + for (i = 0; i < n->nchildren; i++) { + nlq_append (&q, n->child [i]); + nlq_push (&qb, n->child [i]); + } + } + } + + /* Backward visit to leave */ + + while (1) { + n = nlq_pop (&qb); + if (!n) break; + + res = (*f) (interp, n, cs, avn, nvn, action); + + if ((res == TCL_ERROR) || + (res == TCL_BREAK) || + (res == TCL_RETURN)) { + nlq_clear (&qb); + return res; + } else if (res == 5) { + /* Illegal pruning */ + + nlq_clear (&qb); + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Illegal attempt to prune post-order walking", NULL); + return TCL_ERROR; + } + } + + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tcllib/modules/struct/tree1.tcl b/tcllib/modules/struct/tree1.tcl new file mode 100644 index 0000000..726396e --- /dev/null +++ b/tcllib/modules/struct/tree1.tcl @@ -0,0 +1,1485 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree1.tcl,v 1.5 2005/10/04 17:15:05 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::struct {} + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree +} + +# ::struct::tree::tree -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree {{name ""}} { + variable counter + + if {[llength [info level 0]] == 1} { + incr counter + set name "tree${counter}" + } + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 namespace current] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} ::$name {} ::struct::tree::TreeProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + return [uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]] +} + +# ::struct::tree::_children -- +# +# Return the child list for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return $children($node) +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + set children($parentNode) [lreplace $children($parentNode) $index $index] + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + set depth 0 + while { ![string equal $node "root"] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} ::$name {} +} + +# ::struct::tree::_exists -- +# +# Test for existance of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + if {[string equal $key data]} { + return "" + } + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name getall $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # Only default key is present, invisibly. + return {data {}} + } + + upvar ${name}::$attribute($node) data + return [array get data] +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name keys $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + return {data} + } + + upvar ${name}::$attribute($node) data + return [array names data] +} + +# ::struct::tree::_keyexists -- +# +# Test for existance of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + return [string equal $key data] + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + if { [string equal $node "root"] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpaw...) + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name {node root}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + Serialize $name $node tree attr + return [list $tree [array get attr]] +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args] > 3} { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + ?value?\"" + } + + # Process the arguments ... + + set key "data" + set haveValue 0 + if {[llength $args] > 1} { + foreach {flag key} $args break + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be key" + } + if {[llength $args] == 3} { + set haveValue 1 + set value [lindex $args end] + } + } elseif {[llength $args] == 1} { + set haveValue 1 + set value [lindex $args end] + } + + if {$haveValue} { + # Setting a value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) $value] + } else { + # Getting a value + + return [_get $name $node -key $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name lappend [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [lappend data($key) $value] +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name {node root}} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array names + if { [string equal $node "root"] } { + set size [llength [array names ${name}::parent]] + return [expr {$size - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# node Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + set children($parentNode) [lreplace $children($parentNode) $from $to] + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + if {[string equal $node1 "root"] || [string equal $node2 "root"]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2] + set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1] + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. + + variable ${name}::attribute + + if { + [set ia [info exists attribute($node1)]] || + [set ib [info exists attribute($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $attribute($node1) + set attribute($node1) $attribute($node2) + set attribute($node2) $tmp + } elseif {$ia} { + set attribute($node2) $attribute($node1) + unset attribute($node1) + } elseif {$ib} { + set attribute($node1) $attribute($node2) + unset attribute($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# args Optional additional args specifying which key to unset; +# if given, must be of the form "-key key". If not given, +# the key "data" is unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be \"$name unset\ + [list $node] ?-key key?\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + catch {unset data($key)} + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd" + + if {[llength $args] > 6 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "invalid search order \"$order\":\ + should be pre, post, both, or in" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + if { [string equal $type "dfs"] } { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + set st [lreplace $st end end] + + if {$leave || $touch} { + # Evaluate the command at this node + WalkCall $name $node $lvlabel $cmd + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the command at this node (pre, both) + WalkCall $name $node "enter" $cmd + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + set st [lreplace $st end end] + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + + if {$enter} { + # Evaluate the command at this node + WalkCall $name $node "enter" $cmd + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the command at this node + WalkCall $name $node "leave" $cmd + } + } + } + return +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {tree node action cmd} { + set subs [list %n [list $node] %a [list $action] %t [list $tree] %% %] + uplevel 2 [string map $subs $cmd] + return +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attrributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + upvar ${name}::$attr data + set data(data) "" + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar avar} { + upvar 1 $tvar tree $avar attr + + variable ${name}::children + variable ${name}::attribute + + # Store attribute data + if {[info exists attribute($node)]} { + set attr($node) [array get ${name}::$attribute($node)] + } else { + set attr($node) {} + } + + # Build tree structure as nested list. + + set subtrees [list] + foreach c $children($node) { + Serialize $name $c sub attr + lappend subtrees $sub + } + + set tree [list $node $subtrees] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'tree::tree' into the general structure namespace. + namespace import -force tree::tree + namespace export tree +} +package provide struct::tree 1.2.2 diff --git a/tcllib/modules/struct/tree1.test b/tcllib/modules/struct/tree1.test new file mode 100644 index 0000000..45953da --- /dev/null +++ b/tcllib/modules/struct/tree1.test @@ -0,0 +1,1352 @@ +# tree.test: tests for the tree structure. -*- tcl -*- +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# All rights reserved. +# +# RCS: @(#) $Id: tree1.test,v 1.7 2006/10/09 21:41:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.2 +testsNeedTcltest 1.0 + +testing { + useLocal tree1.tcl struct::tree +} + +# ------------------------------------------------------------------------- + +namespace import struct::tree + +#---------------------------------------------------------------------- + +test tree-0.1 {tree errors} { + tree mytree + catch {tree mytree} msg + mytree destroy + set msg +} "command \"::mytree\" already exists, unable to create tree" +test tree-0.2 {tree errors} { + tree mytree + catch {mytree} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree option ?arg arg ...?\"" +test tree-0.3 {tree errors} { + tree mytree + catch {mytree foo} msg + mytree destroy + set msg +} "bad option \"foo\": must be append, children, cut, delete, depth, destroy, exists, get, getall, index, insert, isleaf, keyexists, keys, lappend, move, next, numchildren, parent, previous, serialize, set, size, splice, swap, unset, or walk" +test tree-0.4 {tree errors} { + catch {tree set} msg + set msg +} "command \"::set\" already exists, unable to create tree" + +test tree-1.1 {children} { + + tree mytree + set result [list ] + lappend result [mytree children root] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} + lappend result [mytree children root] + lappend result [mytree children {IT::EM 0}] + mytree destroy + set result +} [list {} {{IT::EM 0} {IT::EM 1} {IT::EM 2}} {{IT::EM 3} {IT::EM 4}}] +test tree-1.2 {children, bad node} { + tree mytree + set result [catch {mytree children foobar} msg] + mytree destroy + list $result $msg +} [list 1 "node \"foobar\" does not exist in tree \"::mytree\""] + +test tree-2.1 {create} { + tree mytree + set result [string equal [info commands ::mytree] "::mytree"] + mytree destroy + set result +} 1 +test tree-2.2 {create} { + set name [tree] + set result [list $name [string equal [info commands $name] "$name"]] + $name destroy + set result +} [list ::tree1 1] + +test tree-3.1 {destroy} { + tree mytree + mytree destroy + string equal [info commands ::mytree] "" +} 1 + +test tree-4.1 {delete} { + tree mytree + catch {mytree delete root} msg + mytree destroy + set msg +} "cannot delete root node" +test tree-4.2 {delete} { + tree mytree + catch {mytree delete {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-4.3 {delete} { + tree mytree + mytree insert root end {IT::EM 0} + mytree delete {IT::EM 0} + set result [list [mytree exists {IT::EM 0}] [mytree children root]] + mytree destroy + set result +} {0 {}} +test tree-4.4 {delete} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree delete {IT::EM 0} + set result [list [mytree exists {IT::EM 0}] \ + [mytree exists {IT::EM 1}] \ + [mytree exists {IT::EM 2}]] + mytree destroy + set result +} {0 0 0} + +test tree-5.1 {exists} { + tree mytree + set result [list ] + lappend result [mytree exists root] + mytree insert root end {IT::EM 0} + lappend result [mytree exists {IT::EM 0}] + mytree delete {IT::EM 0} + lappend result [mytree exists {IT::EM 0}] + mytree destroy + set result +} {1 1 0} + +test tree-6.1 {insert creates and initializes node} { + tree mytree + mytree insert root end {IT::EM 0} + set result [list ] + lappend result [mytree exists {IT::EM 0}] + lappend result [mytree parent {IT::EM 0}] + lappend result [mytree children {IT::EM 0}] + lappend result [mytree set {IT::EM 0}] + lappend result [mytree children root] + mytree destroy + set result +} {1 root {} {} {{IT::EM 0}}} +test tree-6.2 {insert insert nodes in correct location} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root 0 {IT::EM 2} + set result [mytree children root] + mytree destroy + set result +} {{IT::EM 2} {IT::EM 0} {IT::EM 1}} +test tree-6.3 {insert gives error when trying to insert to a fake parent} { + tree mytree + catch {mytree insert {IT::EM 0} end {IT::EM 1}} msg + mytree destroy + set msg +} "parent node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-6.4 {insert generates node name when none is given} { + tree mytree + set result [list [mytree insert root end]] + lappend result [mytree insert root end] + mytree insert root end {IT::EM 3} + lappend result [mytree insert root end] + mytree destroy + set result +} [list node1 node2 node3] +test tree-6.5 {insert inserts multiple nodes properly} { + tree mytree + mytree insert root end a b c d e f + set result [mytree children root] + mytree destroy + set result +} [list a b c d e f] +test tree-6.6 {insert moves nodes that exist} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 0} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree insert root end {IT::EM 4} + set result [list [mytree children root] [mytree children {IT::EM 0}]] + mytree destroy + set result +} [list [list {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} {IT::EM 4}] [list {IT::EM 5} {IT::EM 6}]] +test tree-6.7 {insert moves nodes that already exist properly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree insert root end {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + [mytree children {IT::EM 0}] \ + [mytree children {IT::EM 1}] \ + [mytree parent {IT::EM 1}] \ + [mytree parent {IT::EM 2}] \ + ] + mytree destroy + set result +} [list [list {IT::EM 0} {IT::EM 1} {IT::EM 2}] {} {} root root] +test tree-6.8 {insert moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree insert root 0 {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + ] + mytree destroy + set result +} [list [list {IT::EM 1} {IT::EM 2} {IT::EM 0}]] +test tree-6.9 {insert moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree insert root 1 {IT::EM 0} {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 0} {IT::EM 1} {IT::EM 2}] +test tree-6.10 {insert moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert root 2 {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3}] +test tree-6.11 {insert moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 3} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree insert root 2 {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 1} {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} {IT::EM 2} {IT::EM 3}] +test tree-6.12 {insert moves node in parent properly when oldInd < newInd} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert root 2 {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 1} {IT::EM 0} {IT::EM 2} {IT::EM 3}] +test tree-6.13 {insert gives error when trying to move root} { + tree mytree + catch {mytree insert root end root} msg + mytree destroy + set msg +} "cannot move root node" +test tree-6.14 {insert gives error when trying to make node its descendant} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree insert {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" cannot be its own descendant" +test tree-6.15 {insert gives error when trying to make node its descendant} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + catch {mytree insert {IT::EM 2} end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" cannot be its own descendant" +test tree-6.17 {check node names with spaces} { + tree mytree + catch {mytree insert root end ":\n\t "} msg + mytree destroy + set msg +} [list ":\n\t "] +test tree-6.18 {extended node names with spaces check} { + tree mytree + set ::FOO {} + proc walker {node} { + lappend ::FOO $node + } + set node ":\n\t " + set msg [mytree insert root end $node] + lappend msg [mytree isleaf $node] + mytree insert $node end yummy + lappend msg [mytree size $node] + lappend msg [mytree isleaf $node] + mytree set $node foo + mytree walk root -command [list walker %n] + lappend msg $::FOO + lappend msg [mytree keys $node] + lappend msg [mytree parent $node] + lappend msg [mytree set $node] + mytree destroy + set msg +} [list ":\n\t " 1 1 0 [list root ":\n\t " yummy] data root foo] + +test tree-7.1 {move gives error when trying to move root} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree move {IT::EM 0} end root} msg + mytree destroy + set msg +} "cannot move root node" +test tree-7.2 {move gives error when trying to move non existant node} { + tree mytree + catch {mytree move root end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-7.3 {move gives error when trying to move to non existant parent} { + tree mytree + catch {mytree move {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} "parent node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-7.4 {move gives error when trying to make node its own descendant} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree move {IT::EM 0} end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" cannot be its own descendant" +test tree-7.5 {move gives error when trying to make node its own descendant} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + catch {mytree move {IT::EM 2} end {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" cannot be its own descendant" +test tree-7.6 {move correctly moves a node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree move {IT::EM 0} end {IT::EM 2} + set result [list [mytree children {IT::EM 0}] [mytree children {IT::EM 1}]] + lappend result [mytree parent {IT::EM 2}] + mytree destroy + set result +} {{{IT::EM 1} {IT::EM 2}} {} {IT::EM 0}} +test tree-7.7 {move moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree move root 0 {IT::EM 1} {IT::EM 2} + set result [list \ + [mytree children root] \ + ] + mytree destroy + set result +} [list [list {IT::EM 1} {IT::EM 2} {IT::EM 0}]] +test tree-7.8 {move moves multiple nodes properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} + mytree move root 1 {IT::EM 0} {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 2} {IT::EM 0} {IT::EM 1}] +test tree-7.9 {move moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root 2 {IT::EM 1} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 0} {IT::EM 2} {IT::EM 1} {IT::EM 3}] +test tree-7.10 {move moves node within parent properly} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree insert {IT::EM 3} end {IT::EM 4} {IT::EM 5} {IT::EM 6} + mytree move root 2 {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 1} {IT::EM 2} {IT::EM 0} {IT::EM 4} {IT::EM 5} {IT::EM 6} {IT::EM 3}] +test tree-7.11 {move moves node in parent properly when oldInd < newInd} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root 2 {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 1} {IT::EM 2} {IT::EM 0} {IT::EM 3}] +test tree-7.12 {move node up one} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root [mytree index [mytree next {IT::EM 0}]] {IT::EM 0} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 1} {IT::EM 0} {IT::EM 2} {IT::EM 3}] +test tree-7.13 {move node down one} { + tree mytree + mytree insert root end {IT::EM 0} {IT::EM 1} {IT::EM 2} {IT::EM 3} + mytree move root [mytree index [mytree previous {IT::EM 2}]] {IT::EM 2} + set result [mytree children root] + mytree destroy + set result +} [list {IT::EM 0} {IT::EM 2} {IT::EM 1} {IT::EM 3}] + +test tree-8.1 {parent gives error on fake node} { + tree mytree + catch {mytree parent {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-8.2 {parent gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + set result [list [mytree parent {IT::EM 0}] [mytree parent root]] + mytree destroy + set result +} {root {}} + +test tree-9.1 {size gives error on bogus node} { + tree mytree + catch {mytree size {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-9.2 {size uses root node as default} { + tree mytree + set result [mytree size] + mytree destroy + set result +} 0 +test tree-9.3 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert root end {IT::EM 3} + mytree insert root end {IT::EM 4} + mytree insert root end {IT::EM 5} + set result [mytree size] + mytree destroy + set result +} 6 +test tree-9.4 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 1} end {IT::EM 4} + mytree insert {IT::EM 1} end {IT::EM 5} + set result [mytree size {IT::EM 0}] + mytree destroy + set result +} 5 +test tree-9.5 {size gives correct value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 2} + mytree insert {IT::EM 0} end {IT::EM 3} + mytree insert {IT::EM 1} end {IT::EM 4} + mytree insert {IT::EM 1} end {IT::EM 5} + set result [mytree size {IT::EM 1}] + mytree destroy + set result +} 2 + +test tree-10.1 {set gives error on bogus node} { + tree mytree + catch {mytree set {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-10.2 {set with node name gets/sets "data" value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foobar + set result [mytree set {IT::EM 0}] + mytree destroy + set result +} "foobar" +test tree-10.3 {set with node name and key gets/sets key value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key baz foobar + set result [list [mytree set {IT::EM 0}] [mytree set {IT::EM 0} -key baz]] + mytree destroy + set result +} [list "" "foobar"] +test tree-10.4 {set with too many args gives error} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree set {IT::EM 0} foo bar baz boo} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree set {IT::EM 0} ?-key key? ?value?\"" +test tree-10.5 {set with bad args} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree set {IT::EM 0} foo bar} msg + mytree destroy + set msg +} "invalid option \"foo\": should be key" +test tree-10.6 {set with bad args} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree set {IT::EM 0} foo bar baz} msg + mytree destroy + set msg +} "invalid option \"foo\": should be key" +test tree-10.7 {set with bad key gives error} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree set {IT::EM 0} -key foo} msg + mytree destroy + set msg +} "invalid key \"foo\" for node \"IT::EM 0\"" + +test tree-11.1 {depth} { + tree mytree + catch {mytree depth {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-11.2 {depth of root is 0} { + tree mytree + set result [mytree depth root] + mytree destroy + set result +} 0 +test tree-11.3 {depth is computed correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 1} + mytree insert {IT::EM 1} end {IT::EM 2} + mytree insert {IT::EM 2} end {IT::EM 3} + set result [mytree depth {IT::EM 3}] + mytree destroy + set result +} 4 + +test tree-12.1 {pre dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type dfs -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 0.1} \ + enter ::mytree {IT::EM 0.2} enter ::mytree {IT::EM 1} \ + enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2}] + +test tree-12.1.0 {post dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order post -type dfs -command {lappend t %a %t %n} + mytree destroy + set t +} [list leave ::mytree {IT::EM 0.1} leave ::mytree {IT::EM 0.2} leave ::mytree {IT::EM 0} \ + leave ::mytree {IT::EM 1.1} leave ::mytree {IT::EM 1.2} \ + leave ::mytree {IT::EM 1} leave ::mytree root] + +test tree-12.1.1 {both dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order both -type dfs -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 0.1} \ + leave ::mytree {IT::EM 0.1} enter ::mytree {IT::EM 0.2} leave ::mytree {IT::EM 0.2} \ + leave ::mytree {IT::EM 0} enter ::mytree {IT::EM 1} enter ::mytree {IT::EM 1.1} \ + leave ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} leave ::mytree {IT::EM 1.2} \ + leave ::mytree {IT::EM 1} leave ::mytree root] + +test tree-12.1.3 {in dfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -order in -type dfs -command {lappend t %a %t %n} + mytree destroy + set t +} [list visit ::mytree {IT::EM 0.1} visit ::mytree {IT::EM 0} visit ::mytree {IT::EM 0.2} \ + visit ::mytree root visit ::mytree {IT::EM 1.1} visit ::mytree {IT::EM 1} \ + visit ::mytree {IT::EM 1.2}] + +test tree-12.1.4 {pre dfs walk, different % specifiers} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type dfs -command {lappend t %n %%} + mytree destroy + set t +} [list root % {IT::EM 0} % {IT::EM 0.1} % \ + {IT::EM 0.2} % {IT::EM 1} % \ + {IT::EM 1.1} % {IT::EM 1.2} %] + +test tree-12.1.5 {pre dfs walk, different % specifiers} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type dfs -command {lappend t %% %t} + mytree destroy + set t +} [list % ::mytree % ::mytree % ::mytree \ + % ::mytree % ::mytree \ + % ::mytree % ::mytree] + +test tree-12.1.6 {pre dfs walk, nodes with spaces in names} { + tree mytree + set t [list ] + mytree insert root end "node/0" + mytree insert root end "node/1" + mytree insert "node/0" end "node/0/1" + mytree insert "node/0" end "node/0/2" + mytree insert "node/1" end "node/1/1" + mytree insert "node/1" end "node/1/2" + mytree walk root -type dfs -command {lappend t %n} + mytree destroy + set t +} [list root "node/0" "node/0/1" "node/0/2" "node/1" "node/1/1" "node/1/2"] + +test tree-12.2 {pre bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1} \ + enter ::mytree {IT::EM 0.1} enter ::mytree {IT::EM 0.2} enter ::mytree {IT::EM 1.1} \ + enter ::mytree {IT::EM 1.2}] + +test tree-12.2.0 {post bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs -order post -command {lappend t %a %t %n} + mytree destroy + set t +} [list leave ::mytree {IT::EM 1.2} leave ::mytree {IT::EM 1.1} leave ::mytree {IT::EM 0.2} \ + leave ::mytree {IT::EM 0.1} leave ::mytree {IT::EM 1} leave ::mytree {IT::EM 0} \ + leave ::mytree root] + +test tree-12.2.1 {both bfs walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -type bfs -order both -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1} \ + enter ::mytree {IT::EM 0.1} enter ::mytree {IT::EM 0.2} enter ::mytree {IT::EM 1.1} \ + enter ::mytree {IT::EM 1.2} leave ::mytree {IT::EM 1.2} leave ::mytree {IT::EM 1.1} \ + leave ::mytree {IT::EM 0.2} leave ::mytree {IT::EM 0.1} leave ::mytree {IT::EM 1} \ + leave ::mytree {IT::EM 0} leave ::mytree root] + +test tree-12.3 {pre dfs is default walk} { + tree mytree + set t [list ] + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 0.1} \ + enter ::mytree {IT::EM 0.2} enter ::mytree {IT::EM 1} \ + enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2}] +test tree-12.4 {walk with too few args} {badTest} { + tree mytree + catch {mytree walk} msg + mytree destroy + set msg +} "no value given for parameter \"node\" to \"::struct::tree::_walk\"" +test tree-12.5 {walk with too few args} { + tree mytree + catch {mytree walk root} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" +test tree-12.6 {walk with too many args} { + tree mytree + catch {mytree walk root -foo bar -baz boo -foo2 boo -foo3 baz} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" +test tree-12.7 {walk with fake node} { + tree mytree + catch {mytree walk {IT::EM 0} -command {}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-12.8 {walk gives error on invalid search type} { + tree mytree + catch {mytree walk root -type foo -command foo} msg + mytree destroy + set msg +} {invalid search type "foo": should be dfs, or bfs} +test tree-12.9 {walk gives error on invalid search order} { + tree mytree + catch {mytree walk root -order foo -command foo} msg + mytree destroy + set msg +} {invalid search order "foo": should be pre, post, both, or in} +test tree-12.10 {walk gives error on invalid combination of order and type} { + tree mytree + catch {mytree walk root -order in -type bfs -command foo} msg + mytree destroy + set msg +} {unable to do a in-order breadth first walk} +test tree-12.11 {walk with unknown options} { + tree mytree + catch {mytree walk root -foo bar} msg + mytree destroy + set msg +} "unknown option \"-foo\": should be \"::mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" +test tree-12.12 {walk, option without value} { + tree mytree + catch {mytree walk root -type dfs -order} msg + mytree destroy + set msg +} "value for \"-order\" missing: should be \"::mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" +test tree-12.13 {walk without command} { + tree mytree + catch {mytree walk root -order pre} msg + mytree destroy + set msg +} "no command specified: should be \"::mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\"" + + +test tree-13.1 {swap gives error when trying to swap root} { + tree mytree + catch {mytree swap root {IT::EM 0}} msg + mytree destroy + set msg +} "cannot swap root node" +test tree-13.2 {swap gives error when trying to swap non existant node} { + tree mytree + catch {mytree swap {IT::EM 0} {IT::EM 1}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-13.3 {swap gives error when trying to swap non existant node} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree swap {IT::EM 0} {IT::EM 1}} msg + mytree destroy + set msg +} "node \"IT::EM 1\" does not exist in tree \"::mytree\"" +test tree-13.4 {swap gives error when trying to swap node with self} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree swap {IT::EM 0} {IT::EM 0}} msg + mytree destroy + set msg +} "cannot swap node \"IT::EM 0\" with itself" +test tree-13.5 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.1} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.2} + mytree swap {IT::EM 0} {IT::EM 0.1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0.1} enter ::mytree {IT::EM 0} \ + enter ::mytree {IT::EM 0.1.1} enter ::mytree {IT::EM 0.1.2} enter ::mytree {IT::EM 0.2}] +test tree-13.6 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.1} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.2} + mytree swap {IT::EM 0} {IT::EM 0.1.1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0.1.1} enter ::mytree {IT::EM 0.1} \ + enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 0.1.2} enter ::mytree {IT::EM 0.2}] +test tree-13.7 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree swap {IT::EM 0} {IT::EM 1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 1} enter ::mytree {IT::EM 0.1} \ + enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1.1}] +test tree-13.8 {swap swaps node relationships correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert {IT::EM 0} end {IT::EM 0.1} + mytree insert {IT::EM 0} end {IT::EM 0.2} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.1} + mytree insert {IT::EM 0.1} end {IT::EM 0.1.2} + mytree swap {IT::EM 0.1} {IT::EM 0} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} [list enter ::mytree root enter ::mytree {IT::EM 0.1} enter ::mytree {IT::EM 0} \ + enter ::mytree {IT::EM 0.1.1} enter ::mytree {IT::EM 0.1.2} enter ::mytree {IT::EM 0.2}] + +test tree-14.1 {get gives error on bogus node} { + tree mytree + catch {mytree get {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-14.2 {get gives error on bogus key} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree get {IT::EM 0} -key bogus} msg + mytree destroy + set msg +} "invalid key \"bogus\" for node \"IT::EM 0\"" +test tree-14.3 {get uses data as default key} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foobar + set result [mytree get {IT::EM 0}] + mytree destroy + set result +} "foobar" +test tree-14.4 {get respects -key flag} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key boom foobar + set result [mytree get {IT::EM 0} -key boom] + mytree destroy + set result +} "foobar" + +test tree-15.1 {unset gives error on bogus node} { + tree mytree + catch {mytree unset {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-15.2 {unset does not give error on bogus key} { + tree mytree + mytree insert root end {IT::EM 0} + set result [catch {mytree unset {IT::EM 0} -key bogus}] + mytree destroy + set result +} 0 +test tree-15.3 {unset removes a keyed value from a node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key foobar foobar + mytree unset {IT::EM 0} -key foobar + catch {mytree get {IT::EM 0} -key foobar} msg + mytree destroy + set msg +} "invalid key \"foobar\" for node \"IT::EM 0\"" +test tree-15.4 {unset requires -key} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key foobar foobar + catch {mytree unset {IT::EM 0} flaboozle foobar} msg + mytree destroy + set msg +} "invalid option \"flaboozle\": should be \"::mytree unset {IT::EM 0} ?-key key?\"" + +test tree-16.1 {isleaf} { + tree mytree + set t [mytree isleaf root] + mytree insert root end {IT::EM 0} + lappend t [mytree isleaf root] [mytree isleaf {IT::EM 0}] + mytree destroy + set t +} [list 1 0 1] +test tree-16.2 {isleaf} { + tree mytree + catch {mytree isleaf {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" + +test tree-17.1 {index of root fails} { + tree mytree + catch {mytree index root} msg + mytree destroy + set msg +} "cannot determine index of root node" +test tree-17.2 {index} { + tree mytree + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 0} + set result [list [mytree index {IT::EM 0}] [mytree index {IT::EM 1}]] + mytree destroy + set result +} [list 1 0] +test tree-17.3 {index of non-existant node} { + tree mytree + catch {mytree index {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" + +test tree-18.1 {numchildren} { + tree mytree + set t [mytree numchildren root] + mytree insert root end {IT::EM 0} + lappend t [mytree numchildren root] [mytree numchildren {IT::EM 0}] + mytree destroy + set t +} [list 0 1 0] +test tree-18.2 {numchildren} { + tree mytree + catch {mytree numchildren {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" + +test tree-19.1 {next from root} { + tree mytree + set res [mytree next root] + mytree destroy + set res +} {} +test tree-19.2 {next from fake node} { + tree mytree + catch {mytree next {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-19.3 {next} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + set res [list [mytree next {IT::EM 0}] [mytree next {IT::EM 1}]] + mytree destroy + set res +} [list {IT::EM 1} {}] + +test tree-20.1 {previous from root} { + tree mytree + set res [mytree previous root] + mytree destroy + set res +} {} +test tree-20.2 {previous from fake node} { + tree mytree + catch {mytree previous {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-20.3 {next} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + set res [list [mytree previous {IT::EM 0}] [mytree previous {IT::EM 1}]] + mytree destroy + set res +} [list {} {IT::EM 0}] + +test tree-21.1 {cutting nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} {enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1.0} enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} enter ::mytree {IT::EM 2}} +test tree-21.2 {cutting nodes} { + tree mytree + catch {mytree cut root} msg + mytree destroy + set msg +} {cannot cut root node} +test tree-21.3 {cut sets parent values of relocated nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set res [list \ + [mytree parent {IT::EM 1.0}] \ + [mytree parent {IT::EM 1.1}] \ + [mytree parent {IT::EM 1.2}]] + mytree destroy + set res +} [list root root root] +test tree-21.4 {cut removes node} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1} + mytree insert root end {IT::EM 2} + mytree insert {IT::EM 1} end {IT::EM 1.0} + mytree insert {IT::EM 1} end {IT::EM 1.1} + mytree insert {IT::EM 1} end {IT::EM 1.2} + mytree cut {IT::EM 1} + set res [mytree exists {IT::EM 1}] + mytree destroy + set res +} 0 +test tree-21.5 {cut removes node} { + tree mytree + catch {mytree cut {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" + +test tree-22.1 {splicing nodes} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + mytree splice root 1 3 {IT::EM 1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} {enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1} enter ::mytree {IT::EM 1.0} enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} enter ::mytree {IT::EM 2}} +test tree-22.2 {splicing nodes with no node name given} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + set res [mytree splice root 1 3] + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + list $res $t +} [list node1 {enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree node1 enter ::mytree {IT::EM 1.0} enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} enter ::mytree {IT::EM 2}}] +test tree-22.3 {splicing nodes errors on duplicate node name} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + catch {mytree splice root 1 3 {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" already exists in tree \"::mytree\"" +test tree-22.4 {splicing node sets parent values correctly} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + mytree splice root 1 3 {IT::EM 1} + set res [list \ + [mytree parent {IT::EM 1}] \ + [mytree parent {IT::EM 1.0}] \ + [mytree parent {IT::EM 1.1}] \ + [mytree parent {IT::EM 1.2}]] + mytree destroy + set res +} [list root {IT::EM 1} {IT::EM 1} {IT::EM 1}] +test tree-22.5 {splicing node works with strange index} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + mytree splice root -5 12 {IT::EM 1} + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} {enter ::mytree root enter ::mytree {IT::EM 1} enter ::mytree {IT::EM 0} enter ::mytree {IT::EM 1.0} enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} enter ::mytree {IT::EM 2}} +test tree-22.6 {splicing nodes with no node name and no "to" index given} { + tree mytree + mytree insert root end {IT::EM 0} + mytree insert root end {IT::EM 1.0} + mytree insert root end {IT::EM 1.1} + mytree insert root end {IT::EM 1.2} + mytree insert root end {IT::EM 2} + mytree splice root 1 + set t [list ] + mytree walk root -command {lappend t %a %t %n} + mytree destroy + set t +} {enter ::mytree root enter ::mytree {IT::EM 0} enter ::mytree node1 enter ::mytree {IT::EM 1.0} enter ::mytree {IT::EM 1.1} enter ::mytree {IT::EM 1.2} enter ::mytree {IT::EM 2}} + +test tree-23.1 {getall gives error on bogus node} { + tree mytree + catch {mytree getall {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-23.2 {getall gives error when key specified} { + tree mytree + catch {mytree getall {IT::EM 0} -key data} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-23.3 {getall with node name returns list of key/value pairs} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foobar + mytree set {IT::EM 0} -key other thing + set results [mytree getall {IT::EM 0}] + mytree destroy + lsort $results +} "data foobar other thing" + +test tree-24.1 {keys gives error on bogus node} { + tree mytree + catch {mytree keys {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-24.2 {keys gives error when key specified} { + tree mytree + catch {mytree keys {IT::EM 0} -key data} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-24.3 {keys with node name returns list of keys} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foobar + mytree set {IT::EM 0} -key other thing + set results [mytree keys {IT::EM 0}] + mytree destroy + lsort $results +} "data other" + +test tree-25.1 {keyexists gives error on bogus node} { + tree mytree + catch {mytree keyexists {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-25.2 {keyexists returns false on non-existant key} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree keyexists {IT::EM 0} -key bogus} msg + mytree destroy + set msg +} "0" +test tree-25.3 {keyexists uses data as default key} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foobar + set result [mytree keyexists {IT::EM 0}] + mytree destroy + set result +} "1" +test tree-25.4 {keyexists respects -key flag} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key boom foobar + set result [mytree keyexists {IT::EM 0} -key boom] + mytree destroy + set result +} "1" + +test tree-26.1 {append gives error on bogus node} { + tree mytree + catch {mytree append {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-26.2 {append with node name appends to "data" value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foo + set result [mytree append {IT::EM 0} bar] + mytree destroy + set result +} "foobar" +test tree-26.3 {append with node name and key appends key value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key baz foo + set result [mytree append {IT::EM 0} -key baz bar] + mytree destroy + set result +} "foobar" +test tree-26.4 {append with too many args gives error} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree append {IT::EM 0} foo bar baz boo} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree set {IT::EM 0} ?-key key? value\"" +test tree-26.5 {append with bad args} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree append {IT::EM 0} -foo bar baz} msg + mytree destroy + set msg +} "invalid option \"-foo\": should be -key" +test tree-26.6 {append respects -key flag} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key baz foo + set result [mytree append {IT::EM 0} -key baz bar] + mytree destroy + set result +} "foobar" + +test tree-27.1 {lappend gives error on bogus node} { + tree mytree + catch {mytree lappend {IT::EM 0}} msg + mytree destroy + set msg +} "node \"IT::EM 0\" does not exist in tree \"::mytree\"" +test tree-27.2 {lappend with node name appends to "data" value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} foo + set result [mytree lappend {IT::EM 0} bar] + mytree destroy + set result +} "foo bar" +test tree-27.3 {lappend with node name and key appends key value} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key baz foo + set result [mytree lappend {IT::EM 0} -key baz bar] + mytree destroy + set result +} "foo bar" +test tree-27.4 {lappend with too many args gives error} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree lappend {IT::EM 0} foo bar baz boo} msg + mytree destroy + set msg +} "wrong # args: should be \"::mytree lappend {IT::EM 0} ?-key key? value\"" +test tree-27.5 {lappend with bad args} { + tree mytree + mytree insert root end {IT::EM 0} + catch {mytree lappend {IT::EM 0} -foo bar baz} msg + mytree destroy + set msg +} "invalid option \"-foo\": should be -key" +test tree-27.6 {lappend respects -key flag} { + tree mytree + mytree insert root end {IT::EM 0} + mytree set {IT::EM 0} -key baz foo + set result [mytree lappend {IT::EM 0} -key baz bar] + mytree destroy + set result +} "foo bar" + + +test tree-28.1 {serialization} { + + tree mytree + mytree insert root end 0 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + + set result [mytree serialize] + mytree destroy + + foreach {t a} $result break + list $t [dictsort $a] +} {{root {{0 {{3 {}} {4 {}}}} {1 {}} {2 {}}}} {0 {} 1 {} 2 {} 3 {} 4 {} root {}}} + +test tree-28.2 {serialization} { + + tree mytree + mytree insert root end 0 + mytree insert root end 1 + mytree insert root end 2 + mytree insert 0 end 3 + mytree insert 0 end 4 + + set result [mytree serialize 0] + mytree destroy + + foreach {t a} $result break + list $t [dictsort $a] +} {{0 {{3 {}} {4 {}}}} {0 {} 3 {} 4 {}}} + +testsuiteCleanup diff --git a/tcllib/modules/struct/tree_c.tcl b/tcllib/modules/struct/tree_c.tcl new file mode 100644 index 0000000..cf78b8a --- /dev/null +++ b/tcllib/modules/struct/tree_c.tcl @@ -0,0 +1,208 @@ +# treec.tcl -- +# +# Implementation of a tree data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_treec +package provide struct_treec 2.1.1 +package require Tcl 8.2 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders tree/*.h + critcl::csources tree/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include <util.h> + #include <t.h> + #include <tn.h> + #include <ms.h> + #include <m.h> + + /* .................................................. */ + /* Global tree management, per interp + */ + + typedef struct TDg { + long int counter; + char buf [50]; + } TDg; + + static void + TDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + TDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::tree/critcl" + + Tcl_InterpDeleteProc* proc = TDgrelease; + TDg* tdg; + + tdg = Tcl_GetAssocData (interp, KEY, &proc); + if (tdg == NULL) { + tdg = (TDg*) ckalloc (sizeof (TDg)); + tdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) tdg); + } + + tdg->counter ++; + sprintf (tdg->buf, "tree%d", tdg->counter); + return tdg->buf; + +#undef KEY + } + + static void + TDdeleteCmd (ClientData clientData) + { + /* Release the whole tree. */ + t_delete ((T*) clientData); + } + } + + # Main command, tree creation. + + critcl::ccommand tree_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + * - name =|:=|as|deserialize source |4 + */ + + CONST char* name; + T* td; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name ?=|:=|as|deserialize source??" + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = TDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + T_ASSIGN, T_IS, T_AS, T_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", + 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + td = t_new (); + + switch (srctype) { + case T_ASSIGN: + case T_AS: + case T_IS: + if (tms_assign (interp, td, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case T_DESER: + if (t_deserialize (td, interp, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + td = t_new (); + } + + td->cmd = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + tms_objcmd, (ClientData) td, + TDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } + + namespace eval tree { + critcl::ccommand prune_critcl {dummy interp objc objv} { + return 5; + } + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/tcllib/modules/struct/tree_tcl.tcl b/tcllib/modules/struct/tree_tcl.tcl new file mode 100644 index 0000000..fbbc357 --- /dev/null +++ b/tcllib/modules/struct/tree_tcl.tcl @@ -0,0 +1,2442 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree_tcl.tcl,v 1.5 2009/06/22 18:21:59 andreas_kupries Exp $ + +package require Tcl 8.2 +package require struct::list + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree_tcl +} + +# ::struct::tree::tree_tcl -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "tree${counter}" + } + 2 { + # Standard call. New empty tree. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype tree + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + variable rootname + set rootname root + + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} $name {} ::struct::tree::TreeProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + tree { + set code [catch {_= $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + serial { + set code [catch {_deserialize $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + # Give object to caller for use. + return $name +} + +# ::struct::tree::prune_tcl -- +# +# Abort the walk script, and ignore any children of the +# node we are currently at. +# +# Arguments: +# None. +# +# Results: +# None. +# +# Sideeffects: +# +# Stops the execution of the script and throws a signal to the +# surrounding walker to go to the next node, and ignore the +# children of the current node. + +proc ::struct::tree::prune_tcl {} { + return -code 5 +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + set code [catch {uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]} result] + + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller uplevel $sub] \ + -errorcode $::errorCode -code error $result + } elseif {$code == 2} { + return -code $code $result + } + return $result +} + +# ::struct::tree::_:= -- +# +# Assignment operator. Copies the source tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# source Name of the tree object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::tree::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::tree::_--> -- +# +# Reverse assignment operator. Copies this tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object to copy +# dest Name of the tree object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::tree::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::tree::_ancestors -- +# +# Return the list of all parent nodes of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parents List of parents of node $node. +# Immediate ancestor (parent) first, +# Root of tree (ancestor of all) last. + +proc ::struct::tree::_ancestors {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + set a {} + while {[info exists parent($node)]} { + set node $parent($node) + if {$node == {}} break + lappend a $node + } + return $a +} + +# ::struct::tree::_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the tree object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::tree::_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::attribute + + set usage "wrong # args: should be \"[list $name] attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names attribute] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists attribute($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names attribute $value] + } + -regexp { + set nodes {} + foreach n [array names attribute] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error $usage + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$attribute($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::tree::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# serial Serialized tree to copy from. +# +# Results: +# Nothing. + +proc ::struct::tree::_deserialize {name serial} { + # As we destroy the original tree as part of + # the copying process we don't have to deal + # with issues like node names from the new tree + # interfering with the old ... + + # I. Get the serialization of the source tree + # and check it for validity. + + CheckSerialization $serial attr p c rn + + # Get all the relevant data into the scope + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + variable ${name}::nextAttr + + # Kill the existing parent/children information and insert the new + # data in their place. + + foreach n [array names parent] { + unset parent($n) children($n) + } + array set parent [array get p] + array set children [array get c] + unset p c + + set nextAttr 0 + foreach a [array names attribute] { + unset ${name}::$attribute($a) + } + foreach n [array names attr] { + GenAttributeStorage $name $n + array set ${name}::$attribute($n) $attr($n) + } + + set rootname $rn + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + puts $rootname + parray children + parray parent + parray attribute + puts ___________________________________ + } + return +} + +# ::struct::tree::_children -- +# +# Return the list of children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name args} { + # args := ?-all? node ?filter cmdprefix? + + # '-all' implies that not only the direct children of the + # node, but all their children, and so on, are returned. + # + # 'filter cmd' implies that only those nodes in the result list + # which pass the test 'cmd' are placed into the final result. + + set usage "wrong # args: should be \"[list $name] children ?-all? node ?filter cmd?\"" + + if {([llength $args] < 1) || ([llength $args] > 4)} { + return -code error $usage + } + if {[string equal [lindex $args 0] -all]} { + set all 1 + set args [lrange $args 1 end] + } else { + set all 0 + } + + # args := node ?filter cmdprefix? + + if {([llength $args] != 1) && ([llength $args] != 3)} { + return -code error $usage + } + if {[llength $args] == 3} { + foreach {node _const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set node [lindex $args 0] + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + if {$all} { + set result [DescendantsCore $name $node] + } else { + variable ${name}::children + set result $children($node) + } + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + variable ${name}::rootname + + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + ldelete children($parentNode) $index + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while {[llength $st] > 0} { + set node [lindex $st end] + ldelete st end + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + variable ${name}::rootname + set depth 0 + while { ![string equal $node $rootname] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_descendants -- +# +# Return the list containing all descendants of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look at. +# +# Results: +# desc (filtered) List of nodes descending from 'node'. + +proc ::struct::tree::_descendants {name node args} { + # children -all sucessor, allows filtering. + + set usage "wrong # args: should be \"[list $name] descendants node ?filter cmd?\"" + + if {[llength $args] > 2} { + return -code error $usage + } elseif {[llength $args] == 2} { + foreach {_const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set result [DescendantsCore $name $node] + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +proc ::struct::tree::DescendantsCore {name node} { + # CORE for listing of node descendants. + # No checks ... + # No filtering ... + + variable ${name}::children + + # New implementation. Instead of keeping a second, and explicit, + # list of pending nodes to shift through (= copying of array data + # around), we reuse the result list for that, using a counter and + # direct access to list elements to keep track of what nodes have + # not been handled yet. This eliminates a whole lot of array + # copying within the list implementation in the Tcl core. The + # result is unchanged, i.e. the nodes are in the same order as + # before. + + set result $children($node) + set at 0 + + while {$at < [llength $result]} { + set n [lindex $result $at] + incr at + foreach c $children($n) { + lappend result $c + } + } + + return $result +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::tree::_exists -- +# +# Test for existence of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$attribute($node) data + return [array get data $pattern] +} + +# ::struct::tree::_height -- +# +# Return the height (distance from the given node to its deepest child) +# +# Arguments: +# name Name of the tree. +# node Node we wish to know the height for.. +# +# Results: +# height Distance to deepest child of the node. + +proc ::struct::tree::_height {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[llength $children($node)] == 0} { + # No children, is a leaf, height is 0. + return 0 + } + + # New implementation. We iteratively compute the height for each + # node under the specified one, from the bottom up. The previous + # implementation, using recursion will fail if the encountered + # subtree has a height greater than the currently set recursion + # limit. + + array set h {} + + # NOTE: Check out if a for loop doing direct access, i.e. without + # list reversal, is faster. + + foreach n [struct::list reverse [DescendantsCore $name $node]] { + # Height of leafs + if {![llength $children($n)]} {set h($n) 0} + + # Height of our parent is max of our and previous height. + set p $parent($n) + if {![info exists h($p)] || ($h($n) >= $h($p))} { + set h($p) [expr {$h($n) + 1}] + } + } + + # NOTE: Check out how much we gain by caching the result. + # For all nodes we have this computed. Use cache here + # as well to cut the inspection of descendants down. + # This may degenerate into a recursive solution again + # however. + + return $h($node) +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node. + return {} + } + + upvar ${name}::$attribute($node) data + return [array names data $pattern] +} + +# ::struct::tree::_keyexists -- +# +# Test for existence of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key cannot exist + return 0 + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpa...) + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + ldelete children($oldParent) $ind + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + ldelete children($oldParent) $ind + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_nodes -- +# +# Return a list containing all nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of nodes in the tree. + +proc ::struct::tree::_nodes {name} { + variable ${name}::children + return [array names children] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_rootname -- +# +# Query or change the name of the root node. +# +# Arguments: +# name Name of the tree. +# +# Results: +# The name of the root node + +proc ::struct::tree::_rootname {name} { + variable ${name}::rootname + return $rootname +} + +# ::struct::tree::_rename -- +# +# Change the name of any node. +# +# Arguments: +# name Name of the tree. +# node Name of node to be renamed +# newname New name for the node. +# +# Results: +# The new name of the node. + +proc ::struct::tree::_rename {name node newname} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[_exists $name $newname]} { + return -code error "unable to rename node to \"$newname\",\ + node of that name already present in the tree \"$name\"" + } + + set oldname $node + + # Perform the rename in the internal + # data structures. + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + + set children($newname) $children($oldname) + unset children($oldname) + set parent($newname) $parent($oldname) + unset parent($oldname) + + foreach c $children($newname) { + set parent($c) $newname + } + + if {[string equal $oldname $rootname]} { + set rootname $newname + } else { + set p $parent($newname) + set pos [lsearch -exact $children($p) $oldname] + lset children($p) $pos $newname + } + + if {[info exists attribute($oldname)]} { + set attribute($newname) $attribute($oldname) + unset attribute($oldname) + } + + return $newname +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name args} { + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] serialize ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + variable ${name}::rootname + set node $rootname + } + + set tree [list] + Serialize $name $node tree + return $tree +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional argument specifying a value. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node key args} { + if {[llength $args] > 1} { + return -code error "wrong # args: should be \"$name set node key\ + ?value?\"" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Process the arguments ... + + if {[llength $args] > 0} { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting the value + + return [_get $name $node $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [lappend data($key) $value] +} + +# ::struct::tree::_leaves -- +# +# Return a list containing all leaf nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of leaf nodes in the tree. + +proc ::struct::tree::_leaves {name} { + variable ${name}::children + + set res {} + foreach n [array names children] { + if {[llength $children($n)]} continue + lappend res $n + } + return $res +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name args} { + variable ${name}::rootname + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] size ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + return [expr {[array size ${name}::parent] - 1}] + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + if { [string equal $node $rootname] } { + return [expr {[array size ${name}::parent] - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# args Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + + if { ![_exists $name $parentNode] } { + return -code error "node \"$parentNode\" does not exist in tree \"$name\"" + } + + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[string equal $from "end"]} { + set from [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $from -> n]} { + set from [expr {[llength $children($parentNode)] - 1 - $n}] + } + if {[string equal $to "end"]} { + set to [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $to -> n]} { + set to [expr {[llength $children($parentNode)] - 1 - $n}] + } + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + ldelete children($parentNode) $from $to + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + variable ${name}::rootname + if {[string equal $node1 $rootname] || [string equal $node2 $rootname]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + lset children($parent1) $i1 $node2 + lset children($parent2) $i2 $node1 + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$attribute($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset attribute($node) + unset data + } + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? a n script +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" + + if {[llength $args] > 7 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 2 $usage] + # Remainder is 'a n script' + + foreach {loopvariables script} $args break + + if {[llength $loopvariables] > 2} { + return -code error "too many loop variables, at most two allowed" + } elseif {[llength $loopvariables] == 2} { + foreach {avar nvar} $loopvariables break + } else { + set nvar [lindex $loopvariables 0] + set avar {} + } + + # Make sure we have a script to run, otherwise what's the point? + if { [string equal $script ""] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::_walkproc {name node args} { + set usage "$name walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" + + if {[llength $args] > 6 || [llength $args] < 1} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 1 $usage] + # Remainder is 'n cmdprefix' + + set script [lindex $args 0] + + # Make sure we have a script to run, otherwise what's the point? + if { ![llength $script] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCallProc $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCallProc $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::WalkOptions {theargs n usage} { + upvar 1 type type order order + + # Set defaults + set type dfs + set order pre + + while {[llength $theargs]} { + set flag [lindex $theargs 0] + switch -exact -- $flag { + "-type" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set type [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "-order" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set order [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "--" { + set theargs [lrange $theargs 1 end] + break + } + default { + break + } + } + } + + if {[llength $theargs] == 0} { + return -code error "wrong # args: should be \"$usage\"" + } + if {[llength $theargs] != $n} { + return -code error "unknown option \"$flag\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "bad search order \"$order\":\ + must be both, in, pre, or post" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + return $theargs +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {avar nvar tree node action cmd} { + + if {$avar != {}} { + upvar 2 $avar a ; set a $action + } + upvar 2 $nvar n ; set n $node + + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCall] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + #return -code $code $result + } + } + return {} +} + +proc ::struct::tree::WalkCallProc {tree node action cmd} { + + lappend cmd $tree $node $action + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCallProc] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + } + } + return {} +} + +proc ::struct::tree::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar} { + upvar 1 $tvar tree + + variable ${name}::attribute + variable ${name}::parent + + # 'node' is the root of the tree to serialize. The precondition + # for the call is that this node is already stored in the list + # 'tvar', at index 'rootidx'. + + # The attribute data for 'node' goes immediately after the 'node' + # data. the node information is _not_ yet stored, and this command + # has to do this. + + + array set r {} + set loc($node) 0 + + lappend tree $node {} + if {[info exists attribute($node)]} { + upvar ${name}::$attribute($node) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + + foreach n [DescendantsCore $name $node] { + set loc($n) [llength $tree] + lappend tree $n $loc($parent($n)) + + if {[info exists attribute($n)]} { + upvar ${name}::$attribute($n) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + } + + return $tree +} + + +proc ::struct::tree::CheckSerialization {ser avar pvar cvar rnvar} { + upvar 1 $avar attr $pvar p $cvar ch $rnvar rn + + # Overall length ok ? + + if {[llength $ser] % 3} { + return -code error \ + "error in serialization: list length not a multiple of 3." + } + + set rn {} + array set p {} + array set ch {} + array set attr {} + + # Basic decoder pass + + foreach {node parent nattr} $ser { + + # Initialize children data, if not already done + if {![info exists ch($node)]} { + set ch($node) {} + } + # Attribute length ok ? Dictionary! + if {[llength $nattr] % 2} { + return -code error \ + "error in serialization: malformed attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $nattr]} { + set attr($node) $nattr + } + # Remember root + if {$parent == {}} { + lappend rn $node + set p($node) {} + continue + } + # Parent reference ok ? + if { + ![string is integer -strict $parent] || + ($parent % 3) || + ($parent < 0) || + ($parent >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad parent reference \"$parent\"." + } + # Remember parent, and reconstruct children + + set p($node) [lindex $ser $parent] + lappend ch($p($node)) $node + } + + # Root node information ok ? + + if {[llength $rn] < 1} { + return -code error \ + "error in serialization: no root specified." + } elseif {[llength $rn] > 1} { + return -code error \ + "error in serialization: multiple root nodes." + } + set rn [lindex $rn 0] + + # Duplicate node names ? + + if {[array size ch] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Cycles in the parent relationship ? + + array set visited {} + foreach n [array names p] { + if {[info exists visited($n)]} {continue} + array set _ {} + while {$n != {}} { + if {[info exists _($n)]} { + # Node already converted, cycle. + return -code error \ + "error in serialization: cycle detected." + } + set _($n) . + # root ? + if {$p($n) == {}} {break} + set n $p($n) + if {[info exists visited($n)]} {break} + set visited($n) . + } + unset _ + } + # Ok. The data is now ready for the caller. + + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::tree::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::tree::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::tree::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'tree::tree' into the general structure namespace + # for pickup by the main management. + + namespace import -force tree::tree_tcl +} |