background results from the CPAN

background

Algorithm-Networksort

view release on metacpan or search on metacpan

lib/Algorithm/Networksort.pm view on Meta::CPAN

#
use overload
	'""'	=> \&_stringify;

#
# Names for the algorithm keys.
#
my %algname = (
	balanced => "Balanced",
	batcher => "Batcher's Mergesort",
	bitonic => "Bitonic Sort",
	bosenelson => "Bose-Nelson Sort",
	bubble => "Bubble Sort",
	hibbard => "Hibbard's Sort",
	oddeventrans => "Odd-Even Transposition Sort",
	oddevenmerge => "Batcher's Odd-Even Merge Sort",
);

#
# Default parameters for SVG and EPS-based Knuth diagrams.
#
my %graphset = (
	hz_sep => 12,
	hz_margin => 18,
	vt_sep => 12,
	vt_margin => 21,
	indent => 9,
	inputradius => 2,
	compradius => 2,
	inputline => 2,
	compline => 2,
);

#
# Default parameters for text-based Knuth diagrams.
#
my %textset = (
	inputbegin => "o-",
	inputline => "---",
	inputcompline => "-|-",
	inputend => "-o\n",
	compbegin => "-^-",
	compend => "-v-",
	gapbegin => "  ",
	gapcompline => " | ",
	gapnone => "   ",
	gapend => "  \n",
);

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

has algorithm => (
	isa => 'Str', is => 'ro',
	default => 'bosenelson',
);

has inputs => (
	isa => 'Int', is => 'ro', required => 1,
);

has nwid => (
	isa => 'Str', is => 'rw', required => 0,
	predicate => 'has_nwid',
);

has comparators => (
	isa => 'ArrayRef[ArrayRef[Int]]', is => 'rw', required => 0,
	predicate => 'has_comparators',
);

has network => (
	isa => 'ArrayRef[ArrayRef[Int]]', is => 'rw', required => 0,
	predicate => 'has_network',
);

has ['depth', 'length'] => (
	isa => 'Int', is => 'rw', required => 0,
	init_arg => 0,
);

has creator => (
	isa => 'Str', is => 'ro', required => 0,
	default => sub { return "Perl module " . __PACKAGE__ .  ", " .
		"version $VERSION";}
);

has title => (
	isa => 'Str', is => 'rw', required => 0,
	predicate => 'has_title'
);

has formats => (
	isa => 'ArrayRef[Str]', is => 'rw', required => 0,
	init_arg => undef,
);

has grouped_format => (
	isa => 'Str', is => 'rw', required => 0,
	default => "%s,\n",
);

has index_base => (
	isa => 'ArrayRef[Value]', is => 'rw', required => 0,
);

#
# Variables to track sorting statistics
#
my $swaps = 0;

lib/Algorithm/Networksort.pm view on Meta::CPAN


		#
		# 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;
	}

	return @node_stack;
}

#
# Set up the horizontal coordinates.
#
sub hz_coords
{
	my($columns, %grset) = @_;

	my @hcoord = ($grset{hz_margin} + $grset{indent}) x $columns;

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

	return @hcoord;
}

#
# Set up the vertical coordinates.
#
sub vt_coords
{
	my($inputs, %grset) = @_;

	my @vcoord = ($grset{vt_margin}) x $inputs;

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

	return @vcoord;
}

sub colorswithdefaults
{
	#
	# Get the colorset, using the foreground color as the default color
	# for drawing, except for 'background', which has its own default.
	#
	my @keylist = grep{$_ !~ /background/} keys %colorset;
	my %clrset = map{$_ => ($colorset{$_} // $colorset{foreground} // '#000')}
		@keylist;
	$clrset{background} = $colorset{background};

	#
	#### colorset after defaults are set: %clrset
	#
	return %clrset;
}

#
# Helper function to see if the drawing colors are all identical.
# The hash is presumed to be one returned by colorswithdefaults().
#
sub ismonotone
{
	my (%clrs) = @_;

	my @keylist = grep{$_ !~ /foreground|background/} keys %colorset;

	return !scalar grep{$clrs{$_} ne $clrs{foreground}} @keylist;
}

#
# For the postscript setrgbcolor operator.
#
sub psrgbcolor
{
	my $color = $_[0] // '000';

	#
	# A postscript user might have this in an 'rr gg bb' format,
	# or not bother with the '#'.
	#
	$color =~ s/ //g;
	$color =~ s/^#//;

	if ($color =~ /[^0-9a-fA-F]/)
	{
		carp "Color '$color' is not in six or three hexadecimal digit RGB form.";
		$color = "000";
	}

	if (length $color == 3)
	{
		$color =~ s/(.)(.)(.)/$1$1 $2$2 $3$3/;
	}
	elsif (length $color == 6)
	{
		$color =~ s/(..)(..)(..)/$1 $2 $3/;
	}
	else
	{
		carp "Color '$color' is not in six or three hexadecimal digit RGB form.";
		$color = "0 0 0";
	}

	return join(" ", map{hex()/256} split(/ /, $color));
}

=head2 Methods For Graphing

=head3 graph_eps()

Returns a string that graphs out the network's comparators. The format
will be encapsulated postscript.

    my $nw = nwsrt(inputs = 4, algorithm => 'bitonic');

    print $nw->graph_eps();

=cut

sub graph_eps
{
	my $self = shift;
	my $network = $self->network();
	my $inputs = $self->inputs();
	my %grset = $self->graphsettings();

lib/Algorithm/Networksort.pm view on Meta::CPAN


	$string .= qq(    newpath moveto lineto stroke\n);

	if ($i_radius > 0)
	{
		if ($monotone)
		{
			$string .= qq(    newpath 2 copy moveto $i_radius 0 360 arc fill ) .
				qq(newpath 2 copy moveto $i_radius 0 360 arc fill\n);
		}
		else
		{
			$string .= qq(    $clrset{inputend}\n) .
				qq(    newpath 2 copy moveto $i_radius 0 360 arc fill\n) .
				qq(    $clrset{inputbegin}\n) .
				qq(    newpath 2 copy moveto $i_radius 0 360 arc fill\n);
		}
	}

	$string .= qq(} bind def\n\n);

	#
	# Define the comparator procedure.
	#
	$string .= qq(%\n% column inputline1 inputline2 draw-comparatorline\n%\n) .
		qq(/draw-comparatorline {\n) .
    		qq(    vcoord exch get 3 1 roll vcoord exch get 3 1 roll\n) .
    		qq(    hcoord exch get 3 1 roll 2 index exch % now x1 y1 x1 y2\n\n);

	$string .= qq(    4 copy\n) if ($c_radius > 0);
	$string .= qq(    $clrset{compline}\n) unless ($monotone);

	$string .= qq(    newpath moveto lineto stroke\n);

	if ($c_radius > 0)
	{
		if ($monotone)
		{
			$string .= qq(    newpath 2 copy moveto $c_radius 0 360 arc fill ) .
				qq(newpath 2 copy moveto $c_radius 0 360 arc fill\n);
		}
		else
		{
			$string .= qq(    $clrset{compend}\n) .
				qq(    newpath 2 copy moveto $c_radius 0 360 arc fill\n) .
				qq(    $clrset{compbegin}\n) .
				qq(    newpath 2 copy moveto $c_radius 0 360 arc fill\n);
		}
	}

	$string .= qq(} bind def\n\n);

	#
	# Save the current graphics state, then change the drawing
	# coordinates (from (0,0) = lower left to (0,0) = upper left),
	# and the color if we're drawing in a single color.
	#
	$string .= qq(gsave\n0 $ybound translate\n1 -1 scale\n);
	$string .= qq($clrset{foreground}\n) if ($monotone);

	if (defined $clrset{background})
	{
		$string .= qq(\ngsave $clrset{background}\n);
		$string .= qq(0 0 moveto 0 $ybound lineto $xbound $ybound lineto $xbound 0 lineto closepath);
		$string .= qq(\nfill grestore\n);
	}

	#
	# Draw the input lines.
	#
	$string .= qq(\n%\n% Draw the input lines.\n%\n$grset{inputline} setlinewidth\n) .
		qq(0 1 ) . ($inputs-1) . qq( {draw-inputline} for\n);

	#
	# Draw our comparators.
	# Each member of a group of comparators is drawn in the same column.
	#
	$string .= qq(\n%\n% Draw the comparator lines.\n%\n$grset{compline} setlinewidth\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 .= qq(showpage\ngrestore\n% End of the EPS graph.\n);
	return $string;
}

=head3 graph_svg()

Returns a string that creates a Knuth diagram of a network.

    $nw = nwsrt(inputs => 4, algorithm => 'bitonic');
    $diagram = $nw->graph_svg();    # Using default attributes.

The string will consist of SVG drawing tags enclosed by E<lt>svgE<gt> and E<lt>/svgE<gt> tags.

The attributes of the diagram can be changed via colorsettings() and graphsettings().

    $nw = nwsrt_best(name => 'floyd09');   # See Algorithm::Networksort::Best

    $nw->colorsettings(compbegin => '#04c', compend => '#00c');
    $diagram = $nw->graph_svg();

=begin html

<p>Embedded in a web page, this will produce</p>

<svg xmlns="http://www.w3.org/2000/svg"
     xmlns:xlink="http://www.w3.org/1999/xlink" width="278" height="154" viewbox="0 0 278 154">
  <title>9-input Network by Robert W. Floyd</title>
  <defs>
    <g id="I_454d" style="stroke-width:2" >
      <line style="fill:#000; stroke:#000" x1="18" y1="0" x2="260" y2="0" />
      <circle style="fill:#000; stroke:#000" cx="18" cy="0" r="2" /> <circle style="fill:#000; stroke:#000" cx="260" cy="0" r="2" />
    </g>

    <g id="C1_454d" style="stroke-width:2" >
      <line style="fill:#000; stroke:#000" x1="0" y1="0" x2="0" y2="14" />

lib/Algorithm/Networksort.pm view on Meta::CPAN


		$string .= qq(    </g>\n\n);

	#
	# Set up the comparator templates, and like the input template,
	# either set a single default color, or color the components
	# individually.
	#
	$string .= qq(    <!-- Define the different comparator lines. -->\n);

	$g_style = qq(style="stroke-width:$grset{compline});
	if ($monotone)
	{
		$g_style .= qq(;fill:$clrset{foreground}; stroke:$clrset{foreground}");
		$b_style = "";
		$l_style = "";
		$e_style = "";
	}
	else
	{
		$g_style .= qq(");
		$l_style = qq(style="fill:$clrset{compline}; stroke:$clrset{compline}");
		$b_style = qq(style="fill:$clrset{compbegin}; stroke:$clrset{compbegin}");
		$e_style = qq(style="fill:$clrset{compend}; stroke:$clrset{compend}");
	}

	my @cmptr = (0) x $inputs;
	for my $comparator (@$network)
	{
		my($from, $to) = @$comparator;
		my $clen = $to - $from;
		if ($cmptr[$clen] == 0)
		{
			$cmptr[$clen] = 1;

			my $endpoint = $vcoord[$to] - $vcoord[$from];

			$string .=
				qq(    <g id="C$clen$salt" $g_style >\n) .
				qq(      <desc>Comparator size $clen</desc>\n) .
				qq(      <line $l_style x1="0" y1="0" x2="0" y2="$endpoint" />\n);

			if ($c_radius > 0)
			{
				$string .= qq(      <circle $b_style cx="0" cy="0" r="$c_radius" />) .
					qq( <circle $e_style cx="0" cy="$endpoint" r="$c_radius" />\n);
			}

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

	$string .= qq(  </defs>\n\n);

	#
	# End of definitions.  Draw the input lines as a group.
	#
	$string .= qq(  <g id=") . $self->nwid() . qq($salt">\n);

	#
	# If there's a background color, insert as the first element a <rect>
	# with the full size of the view and a fill of the desired color.
	#
	if (defined $clrset{background})
	{
		$string .= qq(    <rect width="100%" height="100%" style="fill:$clrset{background}" />\n);
	}

	$string .= qq(    <!-- Draw the input lines. -->\n);
	$string .= qq(    <use xlink:href="#I$salt" y="$vcoord[$_]" />\n) for (0..$inputs-1);

	#
	# 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)
	{
		my $h = $hcoord[$hidx++];

		for my $comparator (@$group)
		{
			my($from, $to) = @$comparator;
			my $clen = $to - $from;
			my $v = $vcoord[$from];

			$string .= qq(    <!-- [$from,$to] -->) .
				qq(<use xlink:href="#C$clen$salt" x="$h" y="$v" />\n);
		}
	}

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

=head3 graph_text()

Returns a string that graphs out the network's comparators in plain text.

    my $nw = Algorithm::Networksort(inputs = 4, algorithm => 'bitonic');

    print $nw->graph_text();

This will produce

    o--^-----^--^--o
       |     |  |   
    o--v--^--|--v--o
          |  |      
    o--^--v--|--^--o
       |     |  |   
    o--v-----v--v--o


=cut

sub graph_text
{
	my $self = shift;
	my $network = $self->network();
	my $inputs = $self->inputs();
	my %txset = $self->textsettings();

	my @node_stack = $self->group(grouping => 'graph');
	my @inuse_nodes;

lib/Algorithm/Networksort.pm view on Meta::CPAN

			$string .= $txset{gapbegin};

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

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

	return $string;
}

=head3 colorsettings()

Sets the colors of the graph parts, currently for Postscript and SVG
output only.

The parts are named.

    my %old_colors = $nw->colorsettings(compbegin => "#cc0044", compend => "#cc4400");

You may use L<web colors|https://en.wikipedia.org/wiki/Web_colors> names
in place of the hex triplet if creating an SVG document (Postscript will
not understand it, however). The shorthand hexadecimal form (using only
three digits) is also valid, as it will be converted into the standard
six digit form before writing out the diagram.

=over 4

=item 'inputbegin'

Opening of input line.

=item 'inputline'

The input line.

=item 'inputend'

Closing of the input line.

=item 'compbegin'

Opening of the comparator.

=item 'compline'

The comparator line.

=item 'compend'

Closing of the comparator line.

=item 'foreground'

Default color for the graph as a whole.

=item 'background'

Color of the background.

=back

All parts I<not> named are reset to 'undef' (which means calling
C<colorsettings()> with no arguments resets everything), and will be
colored with the 'foreground' color. The foreground color itself has a
default value of '#000000' (black). The one exception is 'background',
which has no default color at all.

=cut

sub colorsettings
{
	my $self = shift;
	my %settings = @_;
	my %old_settings;

	%old_settings = %colorset;
	map{$colorset{$_} = undef} keys %colorset;

	for my $k (keys %settings)
	{
		#
		# If it's a real part to color, set it.
		#
		if (exists $colorset{$k})
		{
			$colorset{$k} = $settings{$k};
		}
		else
		{
			carp "colorsettings(): Unknown key '$k'";
		}
	}

	return %old_settings;
}

=head3 graphsettings()

Alter diagram properties such as line width or margin size.

    #
    # Set hz_margin, saving its old value for later.
    #
    my %old_gset = $nw->graphsettings(hz_margin => 12);

=head4 Options

SVG measurements are in pixels.

=over 3

=item 'hz_margin'

I<Default value: 18.>
The horizontal spacing between the edges of the graphic and the
sorting network.

=item 'hz_sep'

I<Default value: 12.>
The spacing separating the horizontal lines (the input lines).

=item 'vt_margin'

I<Default value: 21.>

( run in 0.661 second using v1.01-cache-2.11-cpan-fe3c2283af0 )