algotutor 0.8.6-1 / usr / share / algotutor / Graph.pm

# Author:  Chao-Kuei Hung
# For more info, including license, please see doc/index.html

package Graph;
# Graph

use strict;
use Carp;
use vars qw(@ISA);
@ISA = qw(Collection);

use Collection;
use Vertex;
use DCEdge;
# { package main; require "graph/dfs"; }

# use Data::Dumper;

# We don't distinguish abstract graphs from geometric graphs.
# Every graph is given the DCEL structure. This makes the logic
# of coding easier (at the cost of slight increase in running time).
# Every graph is directed, and every edge is paired. Artificial
# edges are hidden.

sub new {
    my ($class, %opts) = @_;
    $class = ref($class) if ref($class);
    my ($init_data) = delete $opts{-init_data};
    my ($operation) = delete $opts{-operation};
    my ($t) = delete $opts{-type};
    croak "'Graph' code does not know how to process '$t' data\n"
	unless ($t eq 'graph' or $t eq 'points');
    my ($self) = $class->SUPER::new(%opts);

    my (@v_names, $k, $s);

    if ($t eq 'points') {
	my ($n, $i, $name) = $#$init_data;
	$name =
	($n < 26) ?
	    sub { return chr(ord('A')+$_[0]); }
	:
	    sub { 'V' . $_[0] }
	;
	$k = 0;
	$init_data = { map { $name->($k++) => {-pos=>$_} } @$init_data };
    }
    # When vertices and edges are refered to in a text file, names are
    # used. Inside a program, however, they seem to be more naturally
    # refered to as objects (blessed references). But don't go too far
    # and use objects as hash keys. You would get strings as return
    # values when using operator "keys" on such a hash. It does not help
    # reducing indirection (even if one manages to get eval work) and it
    # makes debugging less convenient. So we decide to make -name an
    # option instead of making it the key, and create a temporary table
    # mapping names to objects during Graph creation.

    # create vertices
    my ($n2V);	# table of (vertex) names to vertex objects
    @v_names = sort keys %{ $init_data };
#    $self->{"#Vertices"} = [];
    foreach $s (@v_names) {
	my (%v_opt) = map { /^-\w+$/ ? ($_=>$init_data->{$s}{$_}) : () }
	    keys %{$init_data->{$s}};
	$n2V->{$s} = $self->v_new($s, %v_opt);
#	push @{ $self->{"#Vertices"} }, $n2V->{$s};
    }
    $self->{-vertices} = $n2V;	# convenience, read-only configuration variable

    # create edges
    my ($n2E);	# table of (vertex) names to edge objects
    my (@nbr);
    foreach $s (@v_names) {
	@nbr = sort grep { not /\W/ } keys %{$init_data->{$s}};
	foreach $t (@nbr) {
	    $n2E->{$s}{$t} = DCEdge->new($n2V->{$s}, $n2V->{$t},
		-weight=>$init_data->{$s}{$t}, -text=>$init_data->{$s}{$t},
		-directed=>$self->cget(-directed)
	    );
	}
	$self->{"#OneEdge"} = $n2V->{$s}->{"#OneEdge"} =
	    $n2E->{$s}{$nbr[0]} if $#nbr>=0;
    }

    $self->dcelify($n2V, $n2E);

    # End of naming scheme conversion. From now on, vertices and
    # edges are refered to as objects (blessed references). Code
    # readers are reminded to think in object terms.

    return $self;
}

sub dcelify {
# build Doubly Connected Edge List pointers
    my ($self, $n2V, $n2E) = @_;
    my ($s, $t);

    # pass one: verify symmetry and identify twins
    foreach $s (keys %$n2E) {
	foreach $t (keys %{ $n2E->{$s} }) {
	    if (not exists $n2E->{$t}{$s}) {
		$n2E->{$t}{$s} = DCEdge->new($n2V->{$t}, $n2V->{$s}, -arrow=>"last");
		if ($self->cget(-directed)) {
		    $n2E->{$t}{$s}->phantomize();
		} else {
		    warn "one way edge detected";
		    $n2E->{$t}{$s}->configure(-status=>"alert", -directed=>1);
		}
	    }
	    $n2E->{$s}{$t}->twin($n2E->{$t}{$s});
	    $n2E->{$t}{$s}->twin($n2E->{$s}{$t});
	    my ($w) = $n2E->{$t}{$s}->cget(-weight);
	    if (not $self->cget(-directed)) {
		if (not defined $w or $w != $n2E->{$s}{$t}->cget(-weight)) {
		    warn "$s-$t is different from $t-$s in an undirected graph";
		    $n2E->{$t}{$s}->configure(-status=>"alert",
			-arrow=>"last", -directed=>1);
		}
	    }
	}
    }

    # pass two: sort edges around each vertex
    foreach $s (keys %$n2V) {
	my ($neighbor);
	my ($src_pos) = $n2V->{$s}->pos();
	foreach $t (keys %{ $n2E->{$s} }) {
	    my ($tgt_pos) = $n2V->{$t}->pos();
	    my ($a) = $tgt_pos - $src_pos;
	    push @$neighbor, {name=>$t, angle=>atan2($a->[1], $a->[0])};
	}
	next unless $#$neighbor >= 0;
	$neighbor = [ map { $_->{name} }
	    sort { $a->{angle} <=> $b->{angle} } @$neighbor
	];
	push @$neighbor, $neighbor->[0];
	my ($i);
	for ($i=0; $i<$#$neighbor; ++$i) {
	    my ($edge) = $n2E->{$s}{$neighbor->[$i]};
	    my ($prev) = $n2E->{$neighbor->[$i+1]}{$s};
	    $edge->prev($prev);
	    $prev->next($edge);
	}
    }

#my ($e, $k);
#foreach $e ( @{ $self->{"#EdgeList"} } ) {
#    print "[$e]\n";
#    foreach $k (keys %{ $e->{adj} }) {
#	print "    $k: $e->{adj}{$k}\n";
#    }
#}
}

sub v_new {
    my ($self, $name, %opts) = @_;
    %opts = ( %{ $self->cget(-node_opts) }, %opts );
    # as always, the host should take care of prepending %opts with -node_opts
    my ($pos) = Vector2->new(@{ delete $opts{-pos} });
    my ($v) = Vertex->new($self, $pos, -name=>$name, %opts);
#    $v->configure(-text=>$v->cget(-display)->($v)) unless defined $opts{-text};
    return $v;
}

# sub e_new {
#     my ($self, $src, $tgt, %opts) = @_;
#     my ($e1, $e2);
#     $e1 = DCEdge->new($src, $tgt, -host=>$self, -arrow=>"last", %opts);
#     return $e1 if $self->{-directed};
#     $e2 = DCEdge->new($tgt, $src, -host=>$self, -arrow=>"last", %opts);
#     return wantarray ? ($e1, $e2) : $e1;
# }

sub one_edge {
    my ($self, $v) = @_;
    return $#_ >= 1 ? $v->{"#OneEdge"} : $self->{"#OneEdge"};
}

sub edges_around {
    my ($self, $v) = @_;
    my ($e, @s, $start);
    $e = $self->one_edge($v);
    return () unless $e;
    croak "broken 'OneEdge' on vertex $v" unless $e->source() eq $v;
    $start = $e;
    do {
	push @s, $e unless $e->is_phantom();
	$e = $e->prev()->twin();
    } while ($e ne $start);
    return @s;
}

sub destroy {
    my ($self) = @_;
    ::pfs($self, $self->cget(-canvas),
	-priority=>"sbs",
	-on_vertex=>sub { $_[0]->destroy(); },
	-on_edge=>sub { $_[0]->destroy(); },
    );
    undef $self;
}

if ($0 =~ /Graph.pm$/) {
# being tested as a stand-alone program, so run test code.

require "utilalgo";
my ($mw, $ctrl, $can);
$mw = MainWindow->new(-title=>"main_test");
# $can->{main} = gen_can($mw, undef, -elevation=>1, -maxlevel=>3);
$can->{main} = gen_can($mw, undef, -elevation=>2, -maxlevel=>3);
$can->{pq} = gen_can($mw, "Fringe (Frontier)",  -elevation=>1, -maxlevel=>3);
$ctrl = gen_ctrl($mw, $can);
my ($g) = Graph->new(-canvas=>$can->{main}, %{ do "data/trc.gr" });

sub disp_vert_val {
    my ($v, $val) = @_;
    $v->configure(-text=>"$v\n$val");
}

$::Config->{Graph} = {
};

#::dfs($g);

# Theoretically, Dijkstra's single-source-shortest path algorithm should
# not be applied to graphs like trc.gr which has edges with negative weights.
# But we are lucky with this particular example :-)
{ package main; require "graph/pfs"; }
::pfs($g, $can->{pq}, -start=>"lin", -priority=>"dijk", -on_vertex=>\&disp_vert_val);

#{ package main; require "graph/flwa"; }
#::flwa($g);

$ctrl->configure(-recorder=>0);

my ($v);
$v = $g->one_edge->source();
print "$v: ", join(",", map {$_->target()} $g->edges_around($v)), "\n";

#my ($rc, $s);
#$rc = $can->{pq}{SubWidget}{scrolled};
#foreach $s (@{ $rc->{"#history"} }) {
#    foreach my $l (@{ $s->{mark} }) {
#	printf "%4d", $l;
#    }
#    print " | ";
#    foreach my $l ($rc->relative_mark($s->{mark})) {
#	printf "%4d", $l;
#    }
#    print "\n";
#}

# $can->{main}->set_mark(1);
$ctrl->configure(-recorder=>0);
# If the canvas refuses to show any change, remember to verify that:
# - set_mark() was called at least once
# - -recorder is set to zero before entering MainLoop
# Failing to do either of the above will result in a mysterious bug
# that takes days to figure out !@#$%
Tk::MainLoop();

}

1;