head	1.4;
access;
symbols
	tcllib-1-13:1.4
	tcllib-1-12:1.4
	tklib-0-5:1.2
	tcllib-1-11-1:1.2
	tcllib-1-11:1.2
	tcllib-1-10:1.1;
locks; strict;
comment	@# @;


1.4
date	2009.11.03.17.38.30;	author andreas_kupries;	state Exp;
branches;
next	1.3;

1.3
date	2009.09.21.23.48.03;	author andreas_kupries;	state Exp;
branches;
next	1.2;

1.2
date	2008.10.11.23.23.48;	author andreas_kupries;	state Exp;
branches;
next	1.1;

1.1
date	2006.11.16.06.33.13;	author andreas_kupries;	state Exp;
branches;
next	;


desc
@@


1.4
log
@
	* 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.
@
text
@# -*- 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.3 2009/09/21 23:48:03 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
}

#----------------------------------------------------------------------
@


1.3
log
@
	* 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).
@
text
@d9 1
a9 1
# RCS: @@(#) $Id: Xsupport,v 1.2 2008/10/11 23:23:48 andreas_kupries Exp $
d147 1
a147 1
    graph $g
@


1.2
log
@
	* 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:
@
text
@d9 1
a9 1
# RCS: @@(#) $Id: Xsupport,v 1.1 2006/11/16 06:33:13 andreas_kupries Exp $
d204 117
@


1.1
log
@
	* 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:
@
text
@d9 1
a9 1
# RCS: @@(#) $Id: graph.test,v 1.25 2006/10/09 21:41:42 andreas_kupries Exp $
d44 1
a44 1
	# Node attribues matching ?
d56 1
a56 1
	    if {[llength $a] != 3} {
d96 10
@

