1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
# vim: syntax=perl
# Author: Chao-Kuei Hung
# For more info, including license, please see doc/index.html
use strict;
my ($min, $via);
sub get_path {
my ($s, $t) = @_;
return () if $s eq $t;
my (@a, @b);
if (ref $via->{$s}{$t} eq "Vertex") {
@a = get_path($s, $via->{$s}{$t});
@b = get_path($via->{$s}{$t}, $t);
return (@a,@b);
} elsif (ref $via->{$s}{$t}) { # linked directly by an edge
return ($via->{$s}{$t});
} else { # unreachable
return ();
}
}
sub flwa {
my ($gr, %opts) = @_;
my ($n2V, @V, $e, $relay, $s, $t, $new_val, $prev,
@old_path, @new_path);
$n2V = $gr->cget(-vertices);
@V = @{ $n2V }{ sort keys %$n2V };
print STDERR "Warning: This algorithm is very slow.\n" .
"Please get yourself some exercise while waiting.\n";
foreach $s (@V) {
foreach $e ($gr->edges_around($s)) {
$t = $e->target();
$min->{$s}{$t} = $e->cget(-weight);
$via->{$s}{$t} = $e;
}
$min->{$s}{$s} = 0;
}
foreach $relay (@V) {
$gr->cget(-canvas)->set_mark(1);
print STDERR "[$relay]\n";
foreach $s (@V) {
next if $s eq $relay or not defined $min->{$s}{$relay};
foreach $t (@V) {
next if $t eq $relay or $t eq $s or not defined $min->{$relay}{$t};
$new_val = $min->{$s}{$relay} + $min->{$relay}{$t};
@old_path = defined $min->{$s}{$t} ? get_path($s,$t) : ();
@new_path = (get_path($s,$relay), get_path($relay,$t));
if (ref $prev->{t}) {
$prev->{relay}->configure(-status=>"init");
$prev->{s}->configure(-status=>"init");
$prev->{t}->configure(-status=>"init");
map { $_->configure(-status=>"init") } @{ $prev->{path} };
}
if (not defined $min->{$s}{$t}
or $new_val < $min->{$s}{$t}) {
$min->{$s}{$t} = $new_val;
$via->{$s}{$t} = $relay;
# notice drawing order: both paths may overlap
map { $_->configure(-status=>"discard") } @old_path;
map { $_->configure(-status=>"pending") } @new_path;
} else {
map { $_->configure(-status=>"discard") } @new_path;
map { $_->configure(-status=>"pending") } @old_path;
}
$s->configure(-status=>"pending");
$t->configure(-status=>"pending");
$relay->configure(-status=>"focus");
$gr->cget(-canvas)->set_mark(0);
$prev = { relay=>$relay, s=>$s, t=>$t,
path=>[@old_path, @new_path] };
}
}
}
$prev->{relay}->configure(-status=>"init");
$prev->{s}->configure(-status=>"init");
$prev->{t}->configure(-status=>"init");
map { $_->configure(-status=>"init") } @{ $prev->{path} };
$gr->cget(-canvas)->set_mark(0);
#foreach $s (@V) {
#foreach $t (@V) {
#print "$s=>$t : ";
#my (@p) = get_path($s,$t);
#print "@p\n";
#}
#}
}
1;
|
