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