tsp.pm.in

Lin-Kernighan heuristic for the TSP and minimum weight perfect matching

#! @PERL@ -w
# @configure_input@

# This is a Perl class encapsulating behaviour for TSPLIB instances.
# (insert reference to TSPLIB)

# This program is Copyright 1997 David Neto.
# It is distributed with the package LK. 
# It is licenced under the terms of the GNU Library General Public License, 
# See the file named COPYING for the details of the LGPL.
# version 2 or later, or under Larry Wall's Artistic License.

package TSP;  # Use cap first name, so it's not a pragma.
require	Exporter;
@ISA 	= qw(Exporter);
@EXPORT	= qw(new read write is_geo is_two_d is_explicit cost);

use strict;

my(%two_d_types)=("EUC_2D",2,"CEIL_2D",3);
my(%geo_types)=%two_d_types;
my(%explicit_types)=("EXPLICIT",1);
my(@edge_types)=("EXPLICIT",1,"EUC_2D",2,"CEIL_2D",3);
sub cost_from_euc2d {
			my ($self) = shift;
		 	my ($u) = shift;
		 	my ($v) = shift;
			$u = int(0+$u);	# Ensure it is an integer
			$v= int(0+$v);	# Ensure it is an integer
			my ($ux) = $$self{'coords'}[$u][0];
			my ($uy) = $$self{'coords'}[$u][1]; 
			my ($vx) = $$self{'coords'}[$v][0];
			my ($vy) = $$self{'coords'}[$v][1];
			my ($dx)= $ux-$vx;
			my ($dy)= $uy-$vy;
			int(0.5+sqrt($dx*$dx+$dy*$dy)); }

sub cost_from_ceil2d {
		 	my ($self) = shift;
		 	my ($u) = shift;
		 	my ($v) = shift;
			$u = int(0+$u);	# Ensure it is an integer
			$v = int(0+$v);	# Ensure it is an integer
			my ($uc)= $$self{'coords'}[$u];
			my ($vc)= $$self{'coords'}[$v];
			my ($dx)= $$uc[0]-$$vc[0];
			my ($dy)= $$uc[1]-$$vc[1];
			my ($d) = sqrt($dx*$dx+$dy*$dy);
			my ($id)= int($d);
			$id < $d ? $id+1 : $id; }
			
sub cost_from_explicit {
			my ($self) = shift;
		 	my ($u) = shift;
		 	my ($v) = shift;
			$u = int(0+$u);	# Ensure it is an integer
			$v = int(0+$v);	# Ensure it is an integer
			if ( $u < $v ) { $$self{'explicit'}[$u][$v]; }
			else { $$self{'explicit'}[$v][$u]; } }

my(%cost_from_type)=(
	"EXPLICIT", \&cost_from_explicit,
	"EUC_2D", \&cost_from_euc2d,
	"CEIL_2D", \&cost_from_ceil2d);

				
my(@edge_formats)=("LOWER_DIAG_ROW",101,"FULL_MATRIX",102,"UPPER_ROW",103);
my($float_expr)="(-?\\d+\\.?\[0-9\]*(\[eE\]\[+-\]\\d+)?|\\.\[0-9\]+(\[eE\]\[+-\]\\d+)?)";

# Class methods
# Class method new allocates a new TSP object and blesses it into the TSP 
# package (or whatever subclass inherits this).
sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = {};
   bless $self, $class;
   $self->initialize();
   return $self;
}

# Instance methods
# Instance method initialize sets default values for common fields. 
# The instance still needs populating with edge lengths or coordinates.
sub initialize {
	my ($self) = shift;
	$$self{'n'}=0;
	$$self{'name'}="(no name)";
	$$self{'comment'}="(no comment)";
	$$self{'type'}="(no type)";
	$$self{'edge_type'}="(no edge type)";
	$$self{'edge_format'}="(no edge format)";
	$$self{'cost'}= sub { 0 };	# This is the cost function.  It gets set later.
}

sub is_two_d { # Answer whether I am a 2-d geometric instance.
	my $self = shift;
	return $two_d_types{$$self{'edge_type'}};
}

sub is_geo { # Answer whether I am a geometric instance.
	my $self = shift;
#	print STDERR "geo types are: ", keys(%geo_types),"\n";
	return $geo_types{$$self{'edge_type'}};
}

sub is_explicit { # Answer whether I have explicit edge weights.
	my $self = shift;
	return $explicit_types{$$self{'edge_type'}};
}


# cost(u,v)
sub cost { # Compute the distance between u and v.
	my $self = shift;
	my $u = shift;
	my $v = shift;
	my $cost_sub = $$self{'cost'};
	return &$cost_sub($self,$u,$v);
}

# read: fileHandle
# Read the TSPLIB instance from the filehandle and populate myself with it.
sub read {
	my $self = shift;
	my $fh = shift;	# file handle
	my $line;

	# Parse the header
	HEADER: while($line=<$fh>) {
		$_ = $line;
		if (m/^\s*NAME\s*:\s*(.*)/) {
			$$self{'name'}=$1;
		} elsif (m/^\s*COMMENT\s*:\s*(.*)/) {
			$$self{'comment'}=$1;
		} elsif (m/^\s*TYPE\s*:\s*(.*)/) {
			my $str = $1;
			$str =~ m/^TSP$/ 
				|| die "TSP->read: I know TSPLIB files of type TSP, not $1";
			$$self{'type'}=$str;
		} elsif (m/^\s*EDGE_WEIGHT_TYPE\s*:\s*(.*)/) {
			$$self{'edge_type'}=$1;
			$$self{'cost'} = $cost_from_type{$1};
		} elsif (m/^\s*DIMENSION\s*:\s*(.*)/) { # The number of cities
			$$self{'n'}=0+$1;
		} elsif (m/^\s*NODE_COORD_SECTION\s*/) {
			if ( $self->is_geo ) { last HEADER; }
			else { 
				my ($edge_type) = $$self{'edge_type'};
				die "TSP->read: Can't have NODE_COORD_SECTION in $edge_type";
			}
		} else { die "TSP->read: Unrecognized line: $line"; }
	}

	# Parse the body
	SWITCH: {
		&two_d_body_from_handle($self,$fh),
			last SWITCH if (&is_two_d($self));
		&explicit_body_from_handle($self,$fh),
			last SWITCH if (&is_explicit($self));
		die "TSP->Unkown TSPLIB type";
	}

	return $self;
}

# two_d_body_from_handle: fileHandle
# Coordinates are stored in the 'coords' attribute of the object, and is
# 1-based array of references to 2-element arrays of double precision floating
# point numbers.
sub two_d_body_from_handle {
	my $self = shift;
	my $fh = shift;
	my $line;
	my $i=1;		# The array is 1-based, dammit.
	my $n = $$self{'n'};
	my @coords=();
	LINE: while( $line=<$fh> ) {
		last LINE if ( $i > $n );
		last LINE if ( $line =~ m/^\s*EOF/ );
		if ( $line=~ m/^\s*\d+\s+$float_expr\s+$float_expr/o ) {
			my $float1=$1+0;
			my $float2=$4+0;
			#print "1 $1 2 $2 3 $3 4 $4 5 $5 6 $6\n";
			$coords[$i] = [ $float1, $float2 ];
			#print STDERR "$coords[$i][1]\n";
			$i++;
			#print STDERR ".";
		}
	}
	if ( $i-1 != $$self{'n'} ) { 
		die "Wrong number of coordinates: $i instead of $$self{'n'}";
	}
	$$self{'coords'} = \@coords;
#print STDERR "coords are $$self{'coords'}\n";
	return $self;
}


# write: fileHandle
# Write the instance in TSPLIB form onto the filehandle.
sub write {
	my $self = shift;
	my $fh = shift;	# file handle

	print $fh "NAME: $$self{'name'}\n";
	print $fh "COMMENT: $$self{'comment'}\n";
	print $fh "TYPE: $$self{'type'}\n";
	print $fh "EDGE_WEIGHT_TYPE: $$self{'edge_type'}\n";
	print $fh "DIMENSION: $$self{'n'}\n";
	if ( &is_two_d($self) ) {
		print $fh "NODE_COORD_SECTION\n";
		my $i;
		for $i (1..$$self{'n'}) {
			my $x = $$self{'coords'}[$i][0];
			my $y = $$self{'coords'}[$i][1];
			print $fh "$i\t$x\t$y\n";
		}
	}
	print $fh "EOF\n";
	
	return $self;
}


# as_Rothberg_on: fileHandle
# Write the instance on the filehandle, but in a format digestible by
# Rothberg's weighted matching code.
# (See ftp://dimacs.rutgers.edu/pub/netflow/benchmarks/c/match_c.shell)
#
sub as_Rothberg_on {
	my $self = shift;
	my $fh = shift;	# file handle

	# There are three output cases: 
	#	E for Euclidean 
	#	U for Undirected (sparse)
	#	M for Matrix (dense)
	# All numbers, including distances, are integers.
	
	# All our instances are dense, so we never use U.
	# We just choose between E and M.
	SWITCH_ROTHBERG: {
		$self->two_d_as_Rothberg_on($fh), 
			last SWITCH_ROTHBERG if ($self->is_geo);
		$self->explicit_as_Rothberg_on($fh), 
			last SWITCH_ROTHBERG if ($self->is_geo);
	}
	return $self;
}

# two_d_as_Rothberg_on: fileHandle
# Write the instance on the filehandle, but in a format digestible by
# Rothberg's weighted matching code, type E.
# (See ftp://dimacs.rutgers.edu/pub/netflow/benchmarks/c/match_c.shell)
# The output is as follows:
# First line: <num-vertices> E
# Then <num-vertices> with coordinates.
# Beware that (I believe) his code always uses the CEIL_2D metric for Euclidean
# instances.
sub two_d_as_Rothberg_on {
	my $self = shift;
	my $fh = shift;	# file handle

	# All numbers, including distances, are integers.
	print $fh "$$self{'n'} E\n";
	my $i;
	foreach $i (1..$$self{'n'}) {
		my ($c)= $$self{'coords'}[$i];
		print "$$c[0] $$c[1]\n";
	}
	return $self;
}


# Add seconds reference to satisfy Perl -w.
1;