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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
# vim: syntax=perl
# Author: Chao-Kuei Hung
# For more info, including license, please see doc/index.html
use strict;
sub pfs {
my ($gr, $pqcan, %opts) = @_;
my ($prio_name, $prio_func, %to_do, $n, $v, %stat, %value,
%incoming, $discovery_order, $visit_order);
my ($prio_table) = {
bfs => '$discovery_order', # Breadth First Search
sbs => '$n - $discovery_order', # Stack Based Search
prim => '$e->cget(-weight)', # Prim's spanning tree
dijk => '$value{$v} + $e->cget(-weight)',
# Dijkstra's shorstest path
};
$prio_name = ($opts{-priority} or "prim");
croak "unkown priority '$prio_name'" unless exists $prio_table->{$prio_name};
$prio_func = $prio_table->{$prio_name};
%to_do = %{ $gr->cget(-vertices) };
$v = (delete $opts{-start} or (sort keys %to_do)[0]);
$v = $to_do{$v};
# my ($print_func) = sub {
# my ($x)=@_;
# return "$x(" . $self->v_get($x, -value) . " " . $self->v_get($x, -parent) . ")";
# };
$n = [ %to_do ];
$n = ($#$n + 1) / 2;
# $self->v_set($v, -value=>0);
require Heap;
my ($seen) = Heap->new(-canvas=>$pqcan, -compare => sub {
my ($v, $w) = @_;
return $value{$v} <=> $value{$w};
},
-node_opts=>{
# -shape => "rectangle", -size => [70,50],
-display => sub {
my ($v) = $_[0]->cget(-content);
return "$v\n$value{$v}";
}
},
);
$visit_order = $discovery_order = 1;
do {
$v = $to_do{$v};
$value{$v} = 0;
$incoming{$v} = "";
$seen->insert($v);
while (not $seen->is_empty()) {
$v = $seen->remove();
delete $to_do{$v};
$stat{$v} = "done";
$incoming{$v}->configure(-status=>"done") if ref $incoming{$v};
$opts{-on_vertex}->($v, $value{$v})
if ref $opts{-on_vertex} eq "CODE";
# see comment in graph/dfs
$v->configure(-status=>"done");
$v->configure(-text=>"$v\n$visit_order") if $prio_name eq "sbs";
++$visit_order;
$gr->cget(-canvas)->set_mark(0);
my ($e, $w);
foreach $e ($gr->edges_around($v)) {
# if ($incoming{$v} eq $e->twin()) {
# # avoid examining the edge pointing back to the parent
# $e->configure(-status=>"discard") if $e->cget(-directed);
# next;
# }
$w = $e->target();
my ($new_prio) = eval $prio_func;
if (not defined $stat{$w}) {
$value{$w} = $new_prio;
++$discovery_order;
$stat{$w} = "fringe";
$incoming{$w} = $e;
$seen->insert($w);
$w->configure(-status=>"pending");
$e->configure(-status=>"pending");
} elsif ($stat{$w} eq "fringe" and $prio_name ne 'sbs'
and $new_prio < $value{$w}) {
$value{$w} = $new_prio;
$incoming{$w}->configure(-status=>"discard");
$incoming{$w} = $e;
# fix me! it's O(n) slow...
$seen->up(search_heap_for($seen, $w));
$w->configure(-status=>"pending");
$e->configure(-status=>"pending");
} else { # $stat{$w} eq "done"
$e->configure(-status=>"discard")
unless ($incoming{$v} eq $e->twin() and not $e->cget(-directed));
# avoid painting as back edge the edge pointing
# back to the parent
}
$gr->cget(-canvas)->set_mark(0);
} # foreach $e ($gr->edges_around($v)) ...
$gr->cget(-canvas)->set_mark(1);
} # while (not $seen->is_empty()) ...
$v = (keys %to_do)[0];
} while ($v);
}
sub search_heap_for {
my ($h, $v) = @_;
my ($i, $n, $t);
$n = $h->size();
for ($i=1; $i<=$n; ++$i) {
$t = $h->vc($i);
return $i if $t eq $v;
}
croak "internal error: can't find vertex $v";
return 1;
}
1;
|
