#!/usr/bin/env perl

use strict;
use warnings;

use Tree::DAG_Node;

my($starting_node);

# -----------------------------------------------

sub grow_tree
{
	my($count) = 0;
	my($tree)  = Tree::DAG_Node -> new({name => 'Root', attributes => {'#' => $count} });
	my(%child) =
	(
		I => 'J',
		H => 'J',
		J => 'L',
		L => 'M',
		D => 'F',
		E => 'F',
		F => 'G',
		B => 'C',
	);

	my($child);
	my($kid_1, $kid_2);
	my($name, $node);

	for $name (qw/I H J J L D E F B/)
	{
		$count++;

		$node          = Tree::DAG_Node -> new({name => $name, attributes => {'#' => $count} });
		$child         = Tree::DAG_Node -> new({name => $child{$name}, attributes => {'#' => $count} });
		$starting_node = $node if ($name eq 'H');

		$child -> name('K') if ($count == 3);

		if ($child{$name} eq 'M')
		{
			$kid_1 = Tree::DAG_Node -> new({name => 'N', attributes => {'#' => $count}});
			$kid_2 = Tree::DAG_Node -> new({name => 'O', attributes => {'#' => $count}});

			$kid_1 -> add_daughter($kid_2);
			$child -> add_daughter($kid_1);
		}

		$node -> add_daughter($child);
		$tree -> add_daughter($node);
	}

	return $tree;

} # End of grow_tree.

# -----------------------------------------------

sub process_tree_helper
{
	my($tree)      = @_;
	my(@ancestors) = map{$_ -> name} $tree -> daughters;

	my(%ancestors);

	@ancestors{@ancestors} = (1) x @ancestors;

	my($attributes);
	my($name);
	my(@stack);

	$tree -> walk_down
	({
		ancestors => \%ancestors,
		callback  =>
		sub
		{
			my($node, $options) = @_;

			if ($$options{_depth} > 1)
			{
				$attributes = $node -> attributes;
				$name       = $node -> name;

				if (defined $$options{ancestors}{$name} && ! $$attributes{replaced})
				{
					push @{$$options{stack} }, $node;
				}
			}

			return 1;
		},
		_depth => 0,
		stack  => \@stack,
	});

	my($sub_tree) = Tree::DAG_Node -> new;

	my(@kids);
	my($node);
	my(%seen);

	for $node (@stack)
	{
		$name        = $node -> name;
		@kids        = grep{$_ -> name eq $name} $tree -> daughters;
		$seen{$name} = 1;

		$sub_tree -> add_daughters(map{$_ -> copy_at_and_under({no_attribute_copy => 1})} @kids);

		for ($sub_tree -> daughters)
		{
			$_ -> attributes({%{$_ -> attributes}, replaced => 1});
		}

		$node -> replace_with($sub_tree -> daughters);
	}

	return ({%seen}, $#stack);

} # End of process_tree_helper.

# ------------------------------------------------

sub process_tree
{
	my($tree)     = @_;
	my($finished) = 0;

	my(@result);
	my(%seen);

	while (! $finished)
	{
		@result   = process_tree_helper($tree);
		$seen{$_} = 1 for keys %{$result[0]};
		$finished = $result[1] < 0;
	}

	for my $child ($tree -> daughters)
	{
		$tree -> remove_daughter($child) if ($seen{$child -> name});
	}

} # End of process_tree.

# -----------------------------------------------

my($tree) = grow_tree;

my(@ascii_1)  = @{$tree -> draw_ascii_tree};
my(@string_1) = @{$tree -> tree2string};
my(@string_2) = @{$tree -> tree2string({no_attributes => 1})};
my(@string_3) = @{$tree -> tree2string({}, $starting_node)};

process_tree($tree);

print "1: draw_ascii_tree(): Before: \n";
print map{"$_\n"} @ascii_1;
print "2: draw_ascii_tree(): After: \n";
print map{"$_\n"} @{$tree -> draw_ascii_tree};
print '-' x 35, "\n";

print "3: tree2string(): Before: \n";
print map{"$_\n"} @string_1;
print "4: tree2string(): After: \n";
print map{"$_\n"} @{$tree -> tree2string};
print '-' x 35, "\n";

print "5: tree2string({no_attributes => 1}): Before: \n";
print map{"$_\n"} @string_2;
print "6: tree2string({no_attributes => 1}): After: \n";
print map{"$_\n"} @{$tree -> tree2string({no_attributes => 1})};
print '-' x 35, "\n";

print "5: tree2string({}, \$starting_node) before: \n";
print map{"$_\n"} @string_3;
print "6: tree2string({}, \$starting_node) after: \n";
print map{"$_\n"} @{$tree -> tree2string({}, $starting_node)};
print '-' x 35, "\n";

print "Warning: Don't try this at home kids. Some trees get into an infinite loop.\n";