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

package TreeNode;
# Node of a Tree

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

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

sub new {
    my ($class, $parent, $rank, %opts) = @_;
    $class = ref($class) if ref($class);
    # $parent is either (normally) the parent of this TreeNode
    # or (when this TreeNode is the dummy node) the host

    # NOTE BELOW: Because of the chicken-egg problem, it's easier
    # not to call moveto() and set_child()
    # First figure out row and column
    my ($host, $rc, $self);
    if ($parent->isa("TreeNode")) { # ordinary node
	$host = $parent->host();
	$rc = $parent->{rowcol};
	$rc = [$rc->[0]+1, $rc->[1]*2+$rank];
	$self = $class->SUPER::new($host,
	    ::rc2xy($host, "TreeNode", @$rc), %opts);
	$self->{parent} = $parent;
	$parent->{child}[$rank] = $self;
	$opts{-status} = "hidden" if $rc->[0] < 1;
	delete $opts{-content};
	$self->{edge} = Edge->new($parent, $self, %opts);
    } else { # the dummy node
	$host = $parent;
	$rc = [-1, 0];
	$self = $class->SUPER::new($host,
	    ::rc2xy($host, "TreeNode", @$rc), %opts);
	$self->{parent} = $self;
    }
    # NOTE ABOVE: Because of the chicken-egg problem, it's easier
    # not to call moveto() and set_child()
    $self->{child} = [];
    $self->{rowcol} = $rc;
    return $self;
}

sub stringify {
    # In accordance with the semantics of Vertex::stringify,
    # the stringify method of every child class of Vertex
    # should return a unique string for identifying $self.
    my ($self) = @_;
    my ($r) = $self->SUPER::stringify();
    return $r ? $r : "(" . join(",", @{ $self->rowcol() }) . ")";
}

sub parent {
    my ($self) = @_;
    return $self->{parent};
}

sub level {
    my ($self) = @_;
    return $self->rowcol()->[0];
}

#sub is_dummy {
#    my ($self) = @_;
#    return $self->parent() eq $self;
#}
#
#sub is_root {
#    my ($self) = @_;
#    return $self->parent()->is_dummy();
#}
#
sub child {
    my ($self, $index, $child) = @_;
    if ($#_ >= 2) {
	croak "you probably wanted to call set_child()?";
    } elsif ($#_ >= 1) {
	# retrieve the $index-th child
	return $self->{child}[$index];
    } else {
	# retrieve all children (or # of children)
	return wantarray ? @{ $self->{child} } : $#{$self->{child}}+1;
    }
}

sub moveto {
    my ($self, $r, $c) = @_;
    $self->{rowcol} = [$r, $c];
    $self->set_pos(::rc2xy($self->host(), "TreeNode", $r, $c));
    $self->{edge}->set_ends($self->parent(), $self);
    $self->{edge}->configure(-status=>
	$self->level()>=1 ? $self->cget(-status) : "hidden"
    );
}

sub set_child {
    my ($self, $index, $child, %opts) = @_;
    $self->{child}[$index] = $child;
    return unless ref $child;
    $child->{parent} = $self;
    my ($r, $c) = @{ $self->rowcol() };
    $child->moveto($r+1, $c*2+$index) # <-- problematic for non-binary trees
	unless $opts{-nomove};
}

sub rank {
    my ($self) = @_;
    my ($i, $parent);
    $parent = $self->parent();
    return undef unless defined $parent;
    my ($c);
    for ($i=0; $i<=$#{$parent->{child}}; ++$i) {
	if (defined $parent->{child}[$i]) {
	    return $i if $parent->{child}[$i] eq $self;
	    $c .= ",$parent->{child}[$i]";
	} else {
	    $c .= ",undef";
	}
    }
    croak "internal error: inconsistent parent link and child link:" .
	" parent of $self is $parent but children of $parent are $c";
}

sub rowcol {
    my ($self) = @_;
    die "call moveto instead!" if $#_ >= 1;
    return $self->{rowcol};
}

sub configure {
    my ($self, %opts) = @_;
    $self->SUPER::configure(%opts);
#    my ($r, $c) = @{ $self->rowcol() };
    return if not ref $self->{edge};
#    delete @opts{ qw(-shape -size -text -display -content) };
    $opts{-status} = "hidden" if $self->level() < 1;
    delete $opts{-content};
    $self->{edge}->configure(%opts);
}
#
#sub cget {
#    my ($self, $opt_name) = @_;
#    return $self->SUPER::cget($opt_name)->[0]
#	if ($opt_name eq "-sorting_key");
#    return exists $self->{$opt_name} ? $self->{$opt_name} : $self->SUPER::cget($opt_name);
#}

sub search {
    my ($self, $sk_cont, %opts) = @_;
    # $sk_cont is the the search key, not in the form of a node,
    # but in the same form as -content=>...
    my ($c, $h, $focus, $rank, $foc_cont, $focus_status);
    $h = $self->host();
    $focus = $self;
#    $row = $col = 0;
    while (1) {
	$foc_cont = $focus->cget(-content);
	$focus_status = $focus->cget(-status);
	$focus->configure(-status=>"focus", -content=>$sk_cont);
	$h->cget(-canvas)->set_mark(0);
# this code only works for _binary_ trees
	$c = $h->cget(-compare)->($sk_cont, $foc_cont);
	$rank = ($c<=0) ? 0 : 1;
	$focus->configure(-status=>$focus_status, -content=>$foc_cont);
	# termination conditions are different:
	# locating an existing item stops upon finding the key;
	# locating for insertion falls through all the way to a leaf.
	last if $c == 0 and not $opts{-to_leaf};
	last if not ref $focus->child($rank);
	$focus = $focus->child($rank);
#	++$row;
#	$col = $col * $h->cget(-ary) + $rank;
    }
    return ($opts{-to_leaf} or $c == 0) ? $focus : undef;
}

sub adopt_subtree {
    my ($self, $rank, $child) = @_;
    $self->set_child($rank, $child, -nomove=>1);
    # $child will move itself later during traverse()
    return unless ref $child;
    my ($r0, $c0) = @{ $self->rowcol()  };	# 0-th generation
    my ($r1, $c1) = @{ $child->rowcol() };	# new 1-st generation
    my ($r_ofs, $c_ofs) = ($r0+1-$r1, $c0*2+$rank - $c1);
    $child->traverse(sub {
	my ($node) = @_;
	my ($r, $c) = @{ $node->rowcol() };
	($r, $c) = ($r+$r_ofs, $c+$c_ofs*::po2($r-$r1));
	$node->moveto($r, $c);
    }, "pre");
}

sub rotate_cw {
    my ($self) = @_;
    my ($rank, $parent, $promoted, $cn) = (
	$self->rank(), $self->parent(), $self->child(0), $self->host()->cget(-canvas)
    );
    if (not ref $promoted) {
	carp "rotate_cw requires the pivot node to have a left child\n";
	return;
    }
    my ($self_status, $promoted_status) = (
	$self->cget(-status), $promoted->cget(-status)
    );
    $self->configure(-status=>"focus");
    $promoted->configure(-status=>"focus");
    $cn->set_mark(0);
    my ($L, $M, $R) = (
	$promoted->child(0), $promoted->child(1), $self->child(1)
    );
    # note: each of $L, $M, $R could be undef
    my ($row, $col) = @{ $self->rowcol() };
    $parent->set_child($rank, $promoted);
#    $promoted->moveto($row, $col);
    $promoted->set_child(1, $self);
#    $self->moveto($row+1, $col*2+1);
    $promoted->adopt_subtree(0, $L);
    $self->adopt_subtree(0, $M);
    $self->adopt_subtree(1, $R);
    $cn->set_mark(0);
    $self->configure(-status=>$self_status);
    $promoted->configure(-status=>$promoted_status);
    $cn->set_mark(0);
}

sub rotate_ccw {
    my ($self) = @_;
    my ($rank, $parent, $promoted, $cn) = (
	$self->rank(), $self->parent(), $self->child(1), $self->host()->cget(-canvas)
    );
    if (not ref $promoted) {
	carp "rotate_ccw requires the pivot node to have a right child\n";
	return;
    }
    my ($self_status, $promoted_status) = (
	$self->cget(-status), $promoted->cget(-status)
    );
    $self->configure(-status=>"focus");
    $promoted->configure(-status=>"focus");
    $cn->set_mark(0);
    my ($L, $M, $R) = (
	$self->child(0), $promoted->child(0), $promoted->child(1)
    );
    # note: each of $L, $M, $R could be undef
    my ($row, $col) = @{ $self->rowcol() };
    $parent->set_child($rank, $promoted);
#    $promoted->moveto($row, $col);
    $promoted->set_child(0, $self);
#    $self->moveto($row+1, $col*2);
    $self->adopt_subtree(0, $L);
    $self->adopt_subtree(1, $M);
    $promoted->adopt_subtree(1, $R);
    $cn->set_mark(0);
    $self->configure(-status=>$self_status);
    $promoted->configure(-status=>$promoted_status);
    $cn->set_mark(0);
}

sub findmax {
    my ($self) = @_;
    my ($t) = $self;
    my ($c);
    while (ref ($c = $t->child(1))) { $t = $c; }
    return $t;
}

sub traverse {
    my ($self, $func, $order) = @_;

    $order = "in" unless defined $order;
    $func->($self) if $order eq "pre";
    $self->child(0)->traverse($func, $order) if (ref $self->child(0));
    $func->($self) if $order eq "in";
    $self->child(1)->traverse($func, $order) if (ref $self->child(1));
    $func->($self) if $order eq "post";
}

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

1;