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

package Heap;
# Binary Heap

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

use PQueue;
use Vertex;
use Edge;
use overload
    '""' => 'stringify',
    'fallback' => 1
#    'eq' => '()',
#    'fallback' => undef
;

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 "'Heap' code does not know how to process '$t' data\n"
	if (defined $t and not $t eq 'sortable');
    my ($self) = $class->SUPER::new(%opts);
    $self->{"#vertex_reservoir"} = [ undef ];
    $self->{"#edge_reservoir"} = [ undef, undef ];
    my ($k, $v);

    unshift @$init_data, undef;
    for ($k=1; $k<=$#$init_data; ++$k) {
	$self->v_new($init_data->[$k]);
    }
    for ($k=$#$init_data; $k>int($#$init_data/2); --$k) {
	$self->v_configure($k, -status=>"done");
    }
    $self->cget(-canvas)->set_mark(2);
    for ($k=int($#$init_data/2); $k>=1; --$k) {
	$self->down($k);
	$self->cget(-canvas)->set_mark(1);
    }
    $self->cget(-canvas)->set_mark(2);
    if (defined $operation) {
	while (@$operation) {
	    my ($op) = shift @$operation;
	    my ($data) = shift @$operation;
	    if ($op eq 'remove') {
		$self->remove();
		$self->cget(-canvas)->set_mark(1);
	    } elsif ($op eq 'insert') {
		$self->insert($data);
		$self->cget(-canvas)->set_mark(1);
	    } else {
		carp "unknown operation '$op' ignored\n";
	    }
	}
    }
    return $self;
}

sub stringify {
    my ($self) = @_;
    my ($i, $newline, $r);
    $r = "Heap[";
    $newline = 1;
    for ($i=1; $i<=$self->size(); ++$i) {
	if ($i == $newline) {
	    $r .= "\n  ";
	    $newline *= 2;
	}
	my ($t) = $self->{'#vertex_reservoir'}[$i];
	$r .= ref $t->cget(-display) eq "CODE" ?
	    $t->cget(-display)->($t) : $t;
    }
    return "$r\n]\n";
}

#sub cget {
#    my ($self, $opt) = @_;
#    carp "unknown option '$opt' ignored" unless exists $self->{$opt};
#    return $self->{$opt};
#}

sub index2rc {
    my ($index) = @_;
    my ($r, $c, $po2) = (0, $index-1, 1);
    for (; $c>=$po2; $c-=$po2, ++$r, $po2+=$po2) { }
    return ($r, $c);
}

# recycling mechanism abandoned
sub size {
    my ($self) = @_;
    return $#{ $self->{"#vertex_reservoir"} };
#    $self->{"#node_in_use"} = $new_size if (defined $new_size);
#    return $self->{"#node_in_use"};
}

# the v_... subroutines should take care of the vertex
# _along_with_its_associated_edge_ !

sub v_new {
    my ($self, $cont, %opts) = @_;
    my ($n, $v, $e, $par);

    $n = $self->size()+1;
    $par = int($n/2);
    $par = $par >= 1 ? $self->{"#vertex_reservoir"}[$par] : undef;
    
    # recycling mechanism abandoned
#    if ($n > $#{ $self->{"#vertex_reservoir"} } ) {
    %opts = ( %{ $self->cget(-node_opts) }, %opts );
    # as always, the host should take care of prepending %opts with -node_opts
    $v = Vertex->new($self, ::rc2xy($self, "Vertex", index2rc($n)),
	-name=>sprintf("v%02d", $n), -content=>$cont, %opts);
    push @{ $self->{"#vertex_reservoir"} }, $v;
    if (ref $par) {
	$e = Edge->new($par, $v, %opts);
	push @{ $self->{"#edge_reservoir"} }, $e;
    }
#    $self->v_configure($n, %opts);
}

sub v_destroy {
    my ($self) = @_;
    my ($n) = $self->size();
    $self->v_configure($n, -status=>"hidden");
    pop @{ $self->{"#vertex_reservoir"} };
    pop @{ $self->{"#edge_reservoir"} } if $self->size() >= 1;
}

sub v_configure {
    my ($self, $k, %opts) = @_;
#print "    <H::v_c ", ref $opts{-content}, "/$opts{-content}>\n";
    $self->{"#vertex_reservoir"}[$k]->configure(%opts);
    return if ($k <= 1);
    delete @opts{ qw(-shape -size -text -display -content) };
    $self->{"#edge_reservoir"}[$k]->configure(%opts);
}

# content of $k-th vertex
sub vc {
    my ($self, $k) = @_;
    return $self->{"#vertex_reservoir"}[$k]->cget(-content);
}

#### do not touch $self->{"#vertex_reservoir"} and $self->{"#edge_reservoir"} below this line! ###

sub up {
    my ($self, $k) = @_;
    my ($cmp) = $self->cget(-compare);
    $self->v_configure($k, -status=>"focus");
    $self->cget(-canvas)->set_mark(0);

    my ($par, $ck);
    $ck = $self->vc($k);
    while ($k > 1) {
	$par = int($k/2);
	last if ($cmp->($ck, $self->vc($par)) >= 0);
	$self->v_configure($k, -status=>"done", -content=>$self->vc($par) );
	$self->v_configure($par, -status=>"focus", -content=>$ck);
	$self->cget(-canvas)->set_mark(0);
	$k = $par;
    }
    $self->v_configure($k, -status=>"done", -content=>$ck);
}

sub down {
    my ($self, $k) = @_;
    my ($cmp, $ck) = ($self->cget(-compare), $self->vc($k));
    my ($left, $right, $lighter) = ($k*2, $k*2+1);
    $self->v_configure($k, -status=>"focus");
    $self->cget(-canvas)->set_mark(0);
    while ($left <= $self->size()) {
	$lighter = $left;
	++$lighter if ($right <= $self->size() and
	    $cmp->($self->vc($right), $self->vc($left)) < 0);
	my ($cl) = $self->vc($lighter);
	last if ($cmp->($ck, $cl) <= 0);
	$self->v_configure($k, -status=>"done", -content=>$cl);
	$self->v_configure($lighter, -status=>"focus", -content=>$ck);
#	my ($other) = $left + $right - $lighter;
	$self->cget(-canvas)->set_mark(0);
	$k = $lighter;
	$left = $k*2;
	$right = $left + 1;
    }
    $self->v_configure($k, -status=>"done");
}

sub is_empty {
    my ($self) = @_;
    return $self->size() <= 0;
}

sub insert {
    my ($self, $x, %opts) = @_;
    $self->v_new($x, %opts);
    $self->up($self->size());
}

sub remove {
    my ($self) = @_;
    my ($n) = $self->size();
    my ($ret, $last) = ($self->vc(1), $self->vc($n));
    $self->v_destroy();
    if ($n > 1) {
	$self->v_configure(1, -content=>$last);
	$self->down(1);
    }
    return $ret;
}

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

#sub _e {
#    my ($self, $k, $new_val) = @_;
#    my ($t) = $self->{"#edge_reservoir"}[$k];
#    $self->{"#edge_reservoir"}[$k] = $new_val if (defined $new_val);
#    return $t;
#}
#
#sub _v {
#    my ($self, $k, $new_val) = @_;
#    my ($t) = $self->{"#vertex_reservoir"}[$k];
#    $self->{"#vertex_reservoir"}[$k] = $new_val if (defined $new_val);
#    return $t;
#}

if ($0 =~ /Heap.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);
$ctrl = gen_ctrl($mw, $can);
my ($pq) = Heap->new(-canvas=>$can->{main}, %{ do "data/countries.gr" });

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