Algorithm::Networksort - Create Sorting Networks.

  use Algorithm::Networksort qw(:all);

  my $inputs = 4;

  #
  # Generate the sorting network (a list of comparators).
  #
  my @network = nw_comparators($inputs);

  #
  # Print the list, and print the graph of the list.
  #
  print nw_format(\@network, $inputs), "\n";
  print nw_graph(\@network, $inputs), "\n";

    @network = nw_comparator($inputs);

    @network1 = nw_comparator($inputs, algorithm => $alg);

    @network2 = nw_comparator($inputs, algorithm => $alg, grouping => $grouptype);

    $string = nw_format(\@network, $format1, $format2, \@index_base);

    print nw_format(\@network);

    print nw_format(\@network,
                undef,
                undef,
                [1..$inputs]);

    print nw_format(\@network, "SWAP(%d, %d);\n");

    print nw_format(\@network,
                "SWAP(%d, %d);\n",
                undef,
                [1..$inputs]);

    print nw_format(\@network,
                "if (v[%d] < v[%d]) then\n",
                "    exchange(v, %d, %d)\nend if\n");

    my @alphabase = ('a'..'z')[0..$inputs];

    my $string = '[' .
            nw_format(\@network,
		"[%s,%s],",      # Note that we're using the string flag.
		undef,
		\@alphabase);

    substr($string, -1, 1) = ']';    # Overwrite the trailing comma.
    print $string;

    my $inputs = 4;
    my @network = nw_comparators($inputs);

    print qq(<?xml version="1.0" standalone="no"?>\n),
          qq(<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" ),
          qq("http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">\n),
	  nw_graph(\@network, $inputs, graph => 'svg');

    my $inputs = 8;
    my @network = nw_comparators($inputs, algorithm => 'batcher');
    my @grouped_network = nw_group(\@network, $inputs, grouping=>'parallel');

    print "There are ", scalar @network,
        " comparators in this network, grouped into\n",
        scalar @grouped_network, " parallel operations.\n\n";

    foreach my $group (@grouped_network)
    {
        print nw_format($group), "\n";
    }

    @grouped_network = nw_group(\@network, $inputs);
    print "\nThis will be graphed in ", scalar @grouped_network,
        " columns.\n";

    There are 19 comparators in this network, grouped into 6 parallel operations.

    [[0,4],[1,5],[2,6],[3,7]]
    [[0,2],[1,3],[4,6],[5,7]]
    [[2,4],[3,5],[0,1],[6,7]]
    [[2,3],[4,5]]
    [[1,4],[3,6]]
    [[1,2],[3,4],[5,6]]

    This will be graphed in 11 columns.

    my @digits = (1, 8, 3, 0, 4, 7, 2, 5, 9, 6);
    my @network = nw_comparators(scalar @digits, algorithm => 'best');
    nw_sort(\@network, \@digits);
    print join(", ", @digits);

package Algorithm::Networksort;

use 5.006;
use warnings;
use vars qw(@ISA $VERSION $flag_internal %EXPORT_TAGS @EXPORT_OK);

use strict;
use integer;
use Carp;

require Exporter;

@ISA = qw(Exporter);

%EXPORT_TAGS = (
	'all' => [ qw(
		nw_algorithms
		nw_algorithm_name
		nw_color
		nw_graph
		nw_group
		nw_comparators
		nw_format
		nw_sort
	) ],
);

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

$VERSION = '1.09';
$flag_internal = 0;

my %nw_best = (
	(9,	# R. W. Floyd.
	 [[0,1], [3,4], [6,7], [1,2], [4,5], [7,8], [0,1], [3,4], [6,7],
	  [0,3], [3,6], [0,3], [1,4], [4,7], [1,4], [2,5], [5,8], [2,5],
	  [1,3], [5,7], [2,6], [4,6], [2,4], [2,3], [5,6]]),

	(10,	# A. Waksman.
	 [[4,9], [3,8], [2,7], [1,6], [0,5], [1,4], [6,9], [0,3], [5,8],
	  [0,2], [3,6], [7,9], [0,1], [2,4], [5,7], [8,9],
	  [1,2], [4,6], [7,8], [3,5], [2,5], [6,8], [1,3], [4,7],
	  [2,3], [6,7], [3,4], [5,6], [4,5]]),

	(11,	# 12-input by Shapiro and Green, minus the connections
		# to a twelfth input.
	 [[0,1], [2,3], [4,5], [6,7], [8,9],
	  [1,3], [5,7], [0,2], [4,6], [8,10],
	  [1,2], [5,6], [9,10], [1,5], [6,10],
	  [5,9], [2,6], [1,5], [6,10], [0,4],
	  [3,7], [4,8], [0,4], [1,4], [7,10], [3,8],
	  [2,3], [8,9], [2,4], [7,9], [3,5], [6,8], [3,4], [5,6], [7,8]]),

	(12,	# Shapiro and Green.
	 [[0,1], [2,3], [4,5], [6,7], [8,9], [10,11],
	  [1,3], [5,7], [9,11], [0,2], [4,6], [8,10],
	  [1,2], [5,6], [9,10], [1,5], [6,10],
	  [5,9], [2,6], [1,5], [6,10], [0,4], [7,11],
	  [3,7], [4,8], [0,4], [7,11], [1,4], [7,10], [3,8],
	  [2,3], [8,9], [2,4], [7,9], [3,5], [6,8], [3,4], [5,6], [7,8]]),

	(13,	# Generated by the END algorithm.
	 [[1,7], [9,11], [3,4], [5,8], [0,12], [2,6],
	  [0,1], [2,3], [4,6], [8,11], [7,12], [5,9],
	  [0,2], [3,7], [10,11], [1,4], [6,12], [7,8],
	  [11,12], [4,9], [6,10],
	  [3,4], [5,6], [8,9], [10,11], [1,7], [2,6],
	  [9,11], [1,3], [4,7], [8,10],
	  [0,5], [2,5], [6,8], [9,10], [1,2], [3,5], [7,8],
	  [4,6],
	  [2,3], [4,5], [6,7], [8,9], [3,4], [5,6]]),

	(14,	# Green's construction for 16 inputs minus connections to
		# the fifteenth and sixteenth inputs.
	 [[0,1], [2,3], [4,5], [6,7], [8,9], [10,11], [12,13],
	  [0,2], [4,6], [8,10], [1,3], [5,7], [9,11],
	  [0,4], [8,12], [1,5], [9,13], [2,6], [3,7],
	  [0,8], [1,9], [2,10], [3,11], [4,12], [5,13],
	  [5,10], [6,9], [3,12],
	  [7,11], [1,2], [4,8], [1,4], [7,13], [2,8],
	  [2,4], [5,6], [9,10], [11,13], [3,8], [7,12],
	  [6,8], [10,12], [3,5], [7,9],
	  [3,4], [5,6], [7,8], [9,10], [11,12], [6,7], [8,9]]),

	(15,	# Green's construction for 16 inputs minus connections to
		# the sixteenth input.
	 [[0,1], [2,3], [4,5], [6,7], [8,9], [10,11], [12,13],
	  [0,2], [4,6], [8,10], [12,14], [1,3], [5,7], [9,11],
	  [0,4], [8,12], [1,5], [9,13], [2,6], [10,14], [3,7],
	  [0,8], [1,9], [2,10], [3,11], [4,12], [5,13], [6,14],
	  [5,10], [6,9], [3,12], [13,14],
	  [7,11], [1,2], [4,8], [1,4], [7,13], [2,8], [11,14],
	  [2,4], [5,6], [9,10], [11,13], [3,8], [7,12],
	  [6,8], [10,12], [3,5], [7,9],
	  [3,4], [5,6], [7,8], [9,10], [11,12], [6,7], [8,9]]),

	(16,	# Green's construction.
	 [[0,1], [2,3], [4,5], [6,7], [8,9], [10,11], [12,13], [14,15],
	  [0,2], [4,6], [8,10], [12,14], [1,3], [5,7], [9,11], [13,15],
	  [0,4], [8,12], [1,5], [9,13], [2,6], [10,14], [3,7], [11,15],
	  [0,8], [1,9], [2,10], [3,11], [4,12], [5,13], [6,14], [7,15],
	  [5,10], [6,9], [3,12], [13,14],
	  [7,11], [1,2], [4,8], [1,4], [7,13], [2,8], [11,14],
	  [2,4], [5,6], [9,10], [11,13], [3,8], [7,12],
	  [6,8], [10,12], [3,5], [7,9],
	  [3,4], [5,6], [7,8], [9,10], [11,12], [6,7], [8,9]])
);

#
# Names for the algorithm keys.
#
my %algname = (
	bosenelson => "Bose-Nelson",
	batcher => "Batcher's Mergesort",
	hibbard => "Hibbard",
	best => "Best Known",
);

#
# Parameters for SVG and EPS graphing.
#
my %graphset = (
	hz_sep => 12,
	hz_margin => 18,
	vt_sep => 12,
	vt_margin => 21,
	indent => 9,
	stroke_width => 2,
	title => undef,
	namespace => undef,
);

#
# Color parameters.
#
my %colorset = (
	foreground => undef,
	inputbegin => undef,
	inputline => undef,
	inputend => undef,
	compline=> undef,
	compbegin => undef,
	compend => undef,
	background => undef,
);

#
# Parameters for text 'graphing'.
#
my %textset = (
	inputbegin => "o-",
	inputline => "---",
	inputcompline => "-|-",
	inputend => "-o\n",
	compbegin => "-^-",
	compend => "-v-",
	gapbegin => "  ",
	gapcompline => " | ",
	gapnone => "   ",
	gapend => "  \n",
);

#
# Some forward declarations.
#
sub bn_split($$);
sub bn_merge($$$$);
sub semijoin($$@);

#
# @algkeys = nw_algorithms();
#
# Return a list algorithm choices. Each one is a valid key
# for the nw_comparator() algorithm key.
#
sub nw_algorithms()
{
	return keys %algname;
}

#
# nw_algorithm_name();
#
# Return the text-worthy name of the algorithm, given its key name.
#
sub nw_algorithm_name($)
{
	my $alg = shift;
	return $algname{$alg} if (defined $alg);
	return undef;
}

#
# @network = nw_comparators($input, %options);
#
# The function that starts it all.  Return a list of comparators (a
# two-item list) that will sort an n-item list.
#
sub nw_comparators($%)
{
	my $inputs = shift;
	my %opts = @_;
	my @comparators;

	return () if ($inputs < 2);
	$opts{algorithm} = 'bosenelson' unless (defined $opts{algorithm});
	$opts{grouping} = 'none' unless (defined $opts{grouping});

	unless (exists $algname{$opts{algorithm}})
	{
		carp "Unknown algorithm '", $opts{algorithm}, "'\n";
		return ();
	}

	if ($opts{algorithm} eq 'best')
	{
		return @{$nw_best{$inputs}} if (exists $nw_best{$inputs});
		carp "No 'best' network know for N = $inputs.  Using $algname{bosenelson}";
		return bosenelson($inputs);
	}

	@comparators = bosenelson($inputs) if ($opts{algorithm} eq 'bosenelson');
	@comparators = hibbard($inputs) if ($opts{algorithm} eq 'hibbard');
	@comparators = batcher($inputs) if ($opts{algorithm} eq 'batcher');

	#
	# Instead of using the list as provided by the algorithms,
	# re-order it using the grouping for the graphs. This makes
	# use of parallelism (and less stalling when used in a pipeline).
	#
	if ($opts{grouping} eq 'group' or $opts{grouping} eq 'parallel')
	{
		my @grouped_comparators = nw_group(\@comparators, $inputs,
				grouping => $opts{grouping});
		@comparators = ();
		foreach my $group (@grouped_comparators)
		{
			push @comparators, @$group;
		}
	}

	return @comparators;
}

#
# @network = hibbard($inputs);
#
# Return a list of two-element lists that comprise the comparators of a
# sorting network.
#
# Translated from the ALGOL listed in T. N. Hibbard's article, A Simple
# Sorting Algorithm, Journal of the ACM 10:142-50, 1963.
#
# The ALGOL code was overly dependent on gotos.  This has been changed.
#
sub hibbard($)
{ 
	my $inputs = shift;
	my @comparators;
	my($bit, $xbit, $ybit);

	#
	# $lastbit = ceiling(log2($inputs - 1)); but we'll
	# find it using the length of the bitstring.
	#
	my $lastbit = unpack("B32", pack("N", $inputs - 1));
	$lastbit =~ s/^0+//;
	$lastbit = 1 << (length $lastbit);

	#
	# $x and $y are the comparator endpoints.
	# We begin with values of zero and one.
	#
	my($x, $y) = (0, 1); 

	while (1 == 1)
	{
		#
		# Save the comparator pair, and calculate the next
		# comparator pair.
		#
		push @comparators, [$x, $y];
		print "Top of loop: ", nw_format(\@comparators) if ($flag_internal);

		#
		# Start with a check of X and Y's respective bits,
		# beginning with the zeroth bit.
		#
		$bit = 1;
		$xbit = $x & $bit;
	 	$ybit = $y & $bit; 

		#
		# But if the X bit is 1 and the Y bit is
		# zero, just clear the X bit and move on.
		#
 		while ($xbit != 0 and $ybit == 0)
		{
			$x &= ~$bit;

			$bit <<= 1;
			$xbit = $x & $bit;
	 		$ybit = $y & $bit; 
		}

 		if ($xbit != 0)		#  and $ybit != 0
		{
			$y &= ~$bit;
			next;
		}
 
		#
		# The X bit is zero if we've gotten this far.
		#
 		if ($ybit == 0)
		{
			$x |= $bit;
			$y |= $bit;
			$y &= ~$bit if ($y > $inputs - 1);
			next;
		}

		#
		# The X bit is zero, the Y bit is one, and we might
		# return the results.
		#
		do
		{
			return @comparators if ($bit == $lastbit);

			$x &= ~$bit;
			$y &= ~$bit;

			$bit <<= 1;	# Next bit.

			if ($y & $bit)
			{
				$x &= ~$bit;
				next;
			}

			$x |= $bit;
			$y |= $bit;
		} while ($y > $inputs - 1);

		#
		# No return, so loop onwards.
		#
		$bit = 1 if ($y < $inputs - 1); 
		$x &= ~$bit;
		$y |= $bit;
	}
}

#
# @network = bosenelson($inputs);
#
# Return a list of two-element lists that comprise the comparators of a
# sorting network.
#
# The Bose-Nelson algorithm.
#
sub bosenelson($)
{
	my $inputs = shift;

	return () if ($inputs < 2);

	return bn_split(0, $inputs);
}

#
# @comparators = bn_split($i, $length);
#
# The helper function that divides the range to be sorted.
#
# Note that the work of splitting the ranges is performed with the
# 'length' variables.  The $i variable merely acts as a starting
# base, and could easily have been 1 to begin with.
#
sub bn_split($$)
{
	my($i,  $length) = @_;
	my @comparators = ();

	print "bn_split($i, $length)\n" if ($flag_internal);

	if ($length >= 2)
	{
		my $mid = $length/2;

		push @comparators, bn_split($i, $mid);
		push @comparators, bn_split($i + $mid, $length - $mid);
		push @comparators, bn_merge($i, $mid, $i + $mid, $length - $mid);
	}
	print "bn_split($i, $length) returns ", nw_format(\@comparators), "\n\n" if ($flag_internal);
	return @comparators;
}

#
# @comparators = bn_merge($i, $length_i, $j, $length_j);
#
# The other helper function that adds comparators to the list, for a
# given pair of ranges.
#
# As with bn_split, the different conditions all depend upon the
# lengths of the ranges.  The $i and $j variables merely act as
# starting bases.
#
sub bn_merge($$$$)
{
	my($i, $length_i, $j, $length_j) = @_;
	my @comparators = ();

	print "bn_merge($i, $length_i, $j, $length_j)\n" if ($flag_internal);

	if ($length_i == 1 && $length_j == 1)
	{
		push @comparators, [$i, $j];
	}
	elsif ($length_i == 1 && $length_j == 2)
	{
		push @comparators, [$i, $j + 1];
		push @comparators, [$i, $j];
	}
	elsif ($length_i == 2 && $length_j == 1)
	{
		push @comparators, [$i, $j];
		push @comparators, [$i + 1, $j];
	}
	else
	{
		my $i_mid = $length_i/2;
		my $j_mid = ($length_i & 1)? $length_j/2: ($length_j + 1)/2;

		push @comparators, bn_merge($i, $i_mid, $j, $j_mid);
		push @comparators, bn_merge($i + $i_mid, $length_i - $i_mid, $j + $j_mid, $length_j - $j_mid);
		push @comparators, bn_merge($i + $i_mid, $length_i - $i_mid, $j, $j_mid);
	}

	print "bn_merge($i, $length_i, $j, $length_j) returns ", nw_format(\@comparators), "\n\n" if ($flag_internal);
	return @comparators;
}

#
# @network = batcher($inputs);
#
# Return a list of two-element lists that comprise the comparators of a
# sorting network.
#
# Batcher's sort as laid out in Knuth, Sorting and Searching, algorithm 5.2.2M.
#
sub batcher($)
{
	my $inputs = shift;
	my @network;

	return () if ($inputs < 2);

	#
	# $t = ceiling(log2($inputs)); but we'll
	# find it using the length of the bitstring.
	#
	my $t = unpack("B32", pack("N", $inputs));
	$t =~ s/^0+//;
	$t = length $t;

	my $p = 1 << ($t -1);

	while ($p > 0)
	{
		my $q = 1 << ($t -1);
		my $r = 0;
		my $d = $p;

		while ($d > 0)
		{
			for (my $i = 0; $i < $inputs - $d; $i++)
			{
				push @network, [$i, $i + $d] if (($i & $p) == $r);
			}

			$d = $q - $p;
			$q >>= 1;
			$r = $p;
		}
		$p >>= 1;
	}

	return @network;
}

#
# $array_ref = nw_sort(\@network, \@array);
#
# Use the network of comparators (in @network) to sort the elements
# in @array.  Returns the reference to the array, which is sorted
# in-place.
#
# This function is for testing purposes only, interpreting sorting
# pairs ad hoc in an interpreted language is going to be very slow.
#
sub nw_sort($$)
{
	my $network = shift;
	my $array = shift;

	foreach my $comparator (@$network)
	{
		my($left, $right) = @$comparator;

		if (($$array[$left] <=> $$array[$right]) == 1)
		{
			@$array[$left, $right] = @$array[$right, $left];
		}

		if ($flag_internal) {foreach my $elem (@$array){print $elem;} print "  ";}
	}

	print "\n" if ($flag_internal);
	return $array;
}

#
# $string = nw_format(\@network, $cmp_format, $swap_format, \@index_base);
#
# Return a string that represents the comparators.  Default format is
# an array of arrays, in standard perl form
#
sub nw_format($;$$$)
{
	my($network, $cmp_format, $swap_format, $index_base) = @_;
	my $string = '';

	if (scalar @$network == 0)
	{
		carp "No network to format.\n";
		return "";
	}

	if (defined $cmp_format)
	{
		foreach my $comparator(@$network)
		{
			@$comparator = @$index_base[@$comparator] if (defined $index_base);

			$string .= sprintf($cmp_format, @$comparator);
			$string .= sprintf($swap_format, @$comparator) if ($swap_format);
		}
	}
	else
	{
		$string = '[';
		foreach my $comparator (@$network)
		{
			@$comparator = @$index_base[@$comparator] if (defined $index_base);

			$string .= "[" . join(",", @$comparator) . "],";
		}

		substr($string, -1, 1) = "]";
	}

	return $string;
}

#
# @new_grouping = nw_group(\@network, $inputs);
#
# Take a list of comparators, and transform it into a list of a list of
# comparators, each sub-list representing a group that can be printed
# in a single column.  This makes it easier for the nw_graph routines to
# render a visual representation of the sorting network.
#
sub nw_group($$;%)
{
	my $network = shift;
	my $inputs = shift;
	my %opts = @_;

	my @node_range_stack;
	my @node_stack;

	#
	# Group the comparator nodes into columns.
	#
	foreach my $comparator (@$network)
	{
		my($from, $to) = @$comparator;

		#
		# How much of a column becomes untouchable depends upon whether
		# we are trying to print out comparators in a single column, or
		# whether we are just trying to arrange comparators in a single
		# column without concern for overlap.
		#
		my @range = (exists $opts{grouping} and $opts{grouping} eq "parallel")?
				($from, $to):
				($from..$to);
		my $col = scalar @node_range_stack;

		#
		# Search back through the stack of columns to see if
		# we can fit the comparator in an existing column.
		#
		while (--$col >= 0)
		{
			last if (grep{$_ != 0} @{$node_range_stack[$col]}[@range]);
		}

		#
		# If even the top column can't fit it in, make a
		# new, empty top.
		#
		if (++$col == scalar(@node_range_stack))
		{
			push @node_range_stack, [(0) x $inputs];
		}

		@{$node_range_stack[$col]}[@range] = (1) x (scalar @range);

		#
		# Autovivification creates the [$col] array element
		# if it doesn't currently exist.
		#
		push @{$node_stack[$col]}, $comparator;
	}

	#push @node_stack, [sort {${$a}[0] <=> ${$b}[0]} splice @nodes, 0] if (@nodes);
	return @node_stack;
}

#
# %colors = nw_color(%coloroptions);
#
# Sets the colors for the graphical format of the sorting network.
# Returns a hash of the resulting set.
#
sub nw_color(%)
{
	my %color_opts = @_;

	foreach my $key (keys %color_opts)
	{
		$colorset{$key} = $color_opts{$key} if (exists $color_opts{$key});
	}
	return %colorset;
}

#
# $string = nw_graph(\@network, $inputs, %options);
#
# Returns a string that contains the sorting network in a graphical format.
#
sub nw_graph($$;%)
{
	my $network = shift;
	my $inputs = shift;
	my %print_opts = @_;
	my %pset;

	if (scalar @$network == 0)
	{
		carp "No network to graph.\n";
		return "";
	}

	#
	# Text graph by default.
	#
	if (!exists $print_opts{graph} or $print_opts{graph} eq "text")
	{
		%pset = map{$_ => (defined $print_opts{$_})? $print_opts{$_}: $textset{$_}} keys %textset;
		return nw_text_graph($network, $inputs, %print_opts);
	}

	%pset = map{$_ => (defined $print_opts{$_})? $print_opts{$_}: $graphset{$_}} keys %graphset;

	return nw_svg_graph($network, $inputs, %pset) if ($print_opts{graph} eq "svg");
	return nw_eps_graph($network, $inputs, %pset) if ($print_opts{graph} eq "eps");

	carp "Unknown 'graph' type '" . $print_opts{graph} . "'.\n";
	return "";
}

#
# $string = nw_eps_graph(\@network, $inputs, %graphing_options);
#
# Returns a string that contains the sorting network in an EPS format.
#
sub nw_eps_graph($$%)
{
	my $network = shift;
	my $inputs = shift;
	my %grset = @_;

	my @node_stack = nw_group($network, $inputs);
	my $columns = scalar @node_stack;

	#
	# Set up the vertical and horizontal coordinates.
	#
	my @vcoord = ($grset{vt_margin}) x $inputs;
	my @hcoord = ($grset{hz_margin} + $grset{indent}) x $columns;

	for my $idx (0..$inputs-1)
	{
		$vcoord[$idx] += $idx * ($grset{vt_sep} + $grset{stroke_width});
	}

	for my $idx (0..$columns-1)
	{
		$hcoord[$idx] += $idx * ($grset{hz_sep} + $grset{stroke_width});
	}

	my $xbound = $hcoord[$columns - 1] + $grset{hz_margin} + $grset{indent};
	my $ybound = $vcoord[$inputs - 1] + $grset{vt_margin};
	my $title = $grset{title} || "N = $inputs Sorting Network.";

	#
	# A long involved piece to create the necessary DSC, the subroutine
	# definitions, arrays of vertical and horizontal coordinates, and
	# left and right margin definitions.
	#
	my $string =
		qq(%!PS-Adobe-3.0 EPSF-3.0\n%%BoundingBox: 0 0 $xbound $ybound\n%%CreationDate: ) .
		localtime() .
		qq(\n%%Creator: perl module ) . __PACKAGE__ . qq( version $VERSION.) .
		qq(\n%%Title: $title\n%%Pages: 1\n%%EndComments\n%%Page: 1 1\n) .
q(
% column inputline1 inputline2 draw-comparatorline
/draw-comparatorline {
        vcoord exch get 3 1 roll vcoord exch get
        3 1 roll hcoord exch get 3 1 roll 2 index exch % x1 y1 x1 y2
        newpath 2 copy currentlinewidth 0 360 arc gsave stroke grestore fill moveto
        2 copy lineto stroke currentlinewidth 0 360 arc gsave stroke grestore fill
} bind def

% inputline draw-inputline
/draw-inputline {
        vcoord exch get leftmargin exch dup rightmargin exch % x1 y1 x2 y1 
        newpath 2 copy currentlinewidth 0 360 arc moveto
        2 copy lineto currentlinewidth 0 360 arc stroke
} bind def

) .
		"/vcoord [" .
		join("\n    ", semijoin(' ', 16, @vcoord)) . "] def\n/hcoord [" .
		join("\n    ", semijoin(' ', 16, @hcoord)) . "] def\n\n" .
		"/leftmargin $grset{hz_margin} def\n/rightmargin " .
		($xbound - $grset{hz_margin}) . " def\n\n";

	#
	# Save the current graphics state, then change the default line width,
	# and the drawing coordinates from (0,0) = lower left to an upper left
	# origin.
	#
	$string .= "gsave\n$grset{stroke_width} setlinewidth\n0 $ybound translate\n1 -1 scale\n";

	#
	# Draw the input lines.
	#
	$string .= "\n%\n% Draw the input lines.\n%\n0 1 " . ($inputs-1) . " {draw-inputline} for\n";

	#
	# Draw our comparators.
	# Each member of a group of comparators is drawn in the same column.
	#
	$string .= "\n%\n% Draw the comparator lines.\n%\n";
	my $hidx = 0;
	for my $group (@node_stack)
	{
		for my $comparator (@$group)
		{
			$string .= sprintf("%d %d %d draw-comparatorline\n", $hidx, @$comparator);
		}
		$hidx++;
	}

	$string .= "showpage\ngrestore\n% End of the EPS graph.";
	return $string;
}

#
# $string = nw_svg_graph(\@network, $inputs, %graphing_options);
#
# Return a graph of the sorting network in Scalable Vector Graphics.
# Measurements are in pixels. 0,0 is the upper left corner.
#
sub nw_svg_graph($$%)
{
	my $network = shift;
	my $inputs = shift;
	my %grset = @_;

	my @node_stack = nw_group($network, $inputs);
	my $columns = scalar @node_stack;


	#
	# The default color for drawing is the foreground color.  Use
	# it to fill in any unspecified colors in our local colorset.
	#
	my $dclr = (defined $colorset{foreground})? $colorset{foreground}: 'black';
	my %clrset = map{$_ => (defined $colorset{$_})? $colorset{$_}: $dclr} keys %colorset;
	my $ns =  (defined $grset{namespace})? $grset{namespace} . ":" : "";

	#
	# Set up the vertical and horizontal coordinates.
	#
	my $left_margin = $grset{hz_margin};
	my @vcoord = ($grset{vt_margin}) x $inputs;
	my @hcoord = ($left_margin + $grset{indent}) x $columns;

	for my $idx (0..$inputs-1)
	{
		$vcoord[$idx] += $idx * ($grset{vt_sep} + $grset{stroke_width});
	}

	for my $idx (0..$columns-1)
	{
		$hcoord[$idx] += $idx * ($grset{hz_sep} + $grset{stroke_width});
	}

	my $xbound = $hcoord[$columns - 1] + $left_margin + $grset{indent};
	my $ybound = $vcoord[$inputs - 1] + $grset{vt_margin};
	my $right_margin = $xbound - $left_margin;
	my $title = $grset{title} || "N = $inputs Sorting Network.";

	my $string = qq(<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="$xbound" height="$ybound" viewbox="0 0 $xbound $ybound">\n) .
		qq(  <${ns}desc>\n    CreationDate: ) . localtime() .
		qq(\n    Creator: perl module ) . __PACKAGE__ .
		qq( version $VERSION.\n  </${ns}desc>\n) .
		qq(  <${ns}title>$title</${ns}title>\n);

	#
	# Set up the marker and the input line template.
	#
	$string .= qq(  <${ns}defs>\n);

	#
	# Define input line markers and comparator line marks.
	#
	my $refdim = $grset{stroke_width};
	my $boxdim = 2 * $refdim;
	my $b_clr = "stroke:$clrset{inputbegin}";
	my $l_clr = "stroke:$clrset{inputline}";
	my $e_clr = "stroke:$clrset{inputend}";

	$string .= qq(    <${ns}g id="inputline" style="fill:none; stroke-width:$grset{stroke_width}" >\n);
	$string .= qq(      <${ns}desc>Input line.</${ns}desc>\n);
	$string .= qq(      <${ns}circle style="$b_clr" cx="$grset{hz_margin}" cy="0" r="$grset{stroke_width}" />\n);
	$string .= qq(      <${ns}line style="$l_clr" x1="$grset{hz_margin}" y1="0" x2=") .
				($hcoord[$columns - 1] + $grset{indent}) . qq(" y2="0" />\n);
	$string .= qq(      <${ns}circle style="$e_clr" cx=") . ($hcoord[$columns - 1] + $grset{indent}) .
				qq(" cy="0" r="$grset{stroke_width}" />\n);

	$string .= qq(    </${ns}g>\n    <!-- Now the comparator lines, which vary in length. -->\n);


	$string .= qq(    <!-- Define the input line template. -->\n);

	#
	# Set the color in the group tag if all the components of the
	# inputline have the same color.  Otherwise, color the components
	# in the group individually.
	#
	$string .=
		qq(    <${ns}g id="inputline" ) .
		qq(style="fill:none; stroke:$clrset{inputline}; stroke-width:$grset{stroke_width}" >\n) .
		qq(       <${ns}desc>Input line.</${ns}desc>\n) .
		qq(       <${ns}line x1="$left_margin" y1="0" x2="$right_margin" y2="0" ) . 
		qq(style="marker-start: url(#inputbeginmark); marker-end: url(#inputendmark)" />\n);

	$string .= qq(    </${ns}g>\n    <!-- Define the comparator lines, which vary in length. -->\n);

	#
	# Define the comparator templates, which are of varying lengths.
	#
	my @cmptr = (0) x $inputs;
	for my $comparator (@$network)
	{
		my($from, $to) = @$comparator;
		my $clen = $to - $from;
		if ($cmptr[$clen] == 0)
		{
			my $endpoint = $vcoord[$to] - $vcoord[$from];
			$cmptr[$clen] = 1;

			#
			# Color the components in the group individually.
			#
			$b_clr = "fill:$clrset{compbegin}; stroke:$clrset{compbegin}";
			$l_clr = "fill:$clrset{compline}; stroke:$clrset{compline}";
			$e_clr = "fill:$clrset{compend}; stroke:$clrset{compend}";

			$string .=
			qq(    <${ns}g id="comparator$clen" style="stroke-width:$grset{stroke_width}" >\n) .
			qq(      <${ns}desc>Comparator size $clen.</${ns}desc>\n) .
			qq(      <${ns}circle style="$b_clr" cx="0" cy="0" r="$grset{stroke_width}" />\n) .
			qq(      <${ns}line style="$l_clr" x1="0" y1="0" x2="0" y2="$endpoint" />\n) .
			qq(      <${ns}circle style="$e_clr" cx="0" cy="$endpoint" r="$grset{stroke_width}" />\n) .
			qq(    </${ns}g>\n);
		}
	}

	#
	# End of definitions.  Draw the input lines as a group.
	#
	$string .= qq(  </${ns}defs>\n\n  <!-- Draw the input lines. -->\n);
	$string .= qq(  <${ns}g id="inputgroup">\n);
	$string .= qq(    <${ns}use xlink:href="#inputline" y = "$vcoord[$_]" />\n) for (0..$inputs-1);
	$string .= qq(  </${ns}g>\n);

	#
	# Draw our comparators.
	# Each member of a group of comparators is drawn in the same column.
	#
	$string .= qq(\n  <!-- Draw the comparator lines. -->\n);
	my $hidx = 0;
	for my $group (@node_stack)
	{
		for my $comparator (@$group)
		{
			my($from, $to) = @$comparator;
			my $clen = $to - $from;

			$string .= qq(  <!-- [$from, $to] --> <${ns}use xlink:href="#comparator$clen" x = ") .
					$hcoord[$hidx] . qq(" y = ") . $vcoord[$from] . qq(" />\n);
		}
		$hidx++;
	}

	$string .= qq(</svg>\n);
	return $string;
}

#
# $string = nw_text_graph(\@network, $inputs, %graphing_options);
#
# Return a graph of the sorting network in text.
#
sub nw_text_graph($$%)
{
	my $network = shift;
	my $inputs = shift;
	my %txset = @_;

	my @node_stack = nw_group($network, $inputs);
	my $column = 0;
	my $string = "";
	my @inuse_nodes;

	#
	# Set up a matrix of the begin and end points found in each column.
	# This will tell us where to draw our comparator lines.
	#
	for my $group (@node_stack)
	{
		my @node_column = (0) x $inputs;

		for my $comparator (@$group)
		{
			my($from, $to) = @$comparator;
			@node_column[$from, $to] = (1, -1);
		}
		push @inuse_nodes, [splice @node_column, 0];
		$column++;
	}

	#
	# Print that network.
	#
	my @column_line = (0) x $column;

	for my $row (0..$inputs-1)
	{
		#
		# Begin with the input line...
		#
		$string .= $txset{inputbegin};

		for my $col (0..$column-1)
		{
			my @node_column = @{$inuse_nodes[$col]};

			if ($node_column[$row] == 0)
			{
				$string .= $txset{($column_line[$col] == 1)? 'inputcompline': 'inputline'};
			}
			elsif ($node_column[$row] == 1)
			{
				$string .= $txset{compbegin};
			}
			else
			{
				$string .= $txset{compend};
			}
			$column_line[$col] += $node_column[$row];
		}

		$string .= $txset{inputend};

		#
		# Now print the space in between input lines.
		#
		if ($row != $inputs-1)
		{
			$string .= $txset{gapbegin};

			for my $col (0..$column -1)
			{
				$string .= $txset{($column_line[$col] == 0)? 'gapnone': 'gapcompline'};
			}

			$string .= $txset{gapend};
		}
	}

	return $string;
}

#
# @newlist = semijoin($expr, $itemcount, @list);
#
# $expr      - A string to be used in a join() call.
# $itemcount - The number of items in a list to be joined.
#              It may be negative.
# @list      - The list
#
# Create a new list by performing a join on I<$itemcount> elements at a
# time on the original list. Any leftover elements from the end of the
# list become the last item of the new list, unless I<$itemcount> is
# negative, in which case the first item of the new list is made from the
# leftover elements from the front of the list.
#
sub semijoin($$@)
{
	my($jstr, $itemcount, @oldlist) = @_;
	my($idx);
	my(@newlist) = ();

	return @oldlist if ($itemcount <= 1 and $itemcount >= -1);

	if ($itemcount > 0)
	{
		push @newlist, join $jstr, splice(@oldlist, 0, $itemcount) while @oldlist;
	}
	else
	{
		$itemcount = -$itemcount;
		unshift @newlist, join $jstr, splice(@oldlist, -$itemcount, $itemcount)
			while $itemcount <= @oldlist;
		unshift @newlist, join $jstr, splice( @oldlist, 0, $itemcount) if @oldlist;
	}

	return @newlist;
}

1;
__END__