package Canary;
my $canaries = 0;

sub new {
    my ($class, $value) = @_;
    $canaries++;
    return bless [$value], "Canary";
}

sub DESTROY {
    $canaries--;
}

sub inc {
    $canaries++;
}

sub count {
    return $canaries;
}

sub meth {
    return -shift->[0];
}

package FakeHeap;
use strict;
use warnings;	# Remove this for production. Assumes perl 5.6
use Carp;

use vars qw($VERSION);
$VERSION = "0.01";

my %order2code = 
    ("<"  => sub { shift() <  shift },
     ">"  => sub { shift() >  shift },
     "lt" => sub { shift() lt shift },
     "gt" => sub { shift() gt shift },
     );

my %order2prefix = 
    ("lt" => "A",
     "gt" => "A");

sub new {
    my ($class, %options) = @_;
    my $order = $options{order};
    $order = "<" unless defined $order;
    my $elements = $options{elements};
    $elements = "Scalar" if !defined $elements;
    $elements = [$elements] if !ref $elements;
    $elements->[0] = "Scalar" if lc($elements->[0]) eq "key";
    my $fake = bless {
        data      => [],
        heap      => Heap::Simple->new(%options),
        max_count => defined($options{max_count}) ? $options{max_count} : 9**9**9,
        prefix	  => $order2prefix{lc($order)},
        elements  => ucfirst(lc($elements->[0])),
        index	  => $elements->[1],
        num_order => $order !~ /t/,
        dirty	  => $options{dirty},
        less      => ref $order ? $order : $order2code{lc($order)} || 
            croak "Unhandled order '$order'",
    }, $class;
    my $t = $fake->{heap}->order;
    $order = lc($order) if !ref $order;
    $order eq $t || croak "Order is $t, but I expected $order";
    my @t = $fake->{heap}->elements;
    $fake->{elements} eq $t[0] || 
        croak "Element type is @t, but I expected $fake->{elements}";
    return $fake;
}

sub _make_element {
    my ($fake, $value) = @_;
    $value = $fake->{prefix} . $value if $fake->{prefix};
    my $type = $fake->{elements};
    return $value if $type eq "Scalar";
    if ($type eq "Array") {
        my $a = bless [], "Canary";
        $canaries++;
        $a->[$fake->{index} || 0] = $value;
        return $a;
    }
    if ($type eq "Hash") {
        $canaries++;
        return bless {$fake->{index} || croak("No index")=> $value }, "Canary";
    }
    if ($type eq "Function" || $type eq "Any" || 
        $type eq "Method" || $type eq "Object") {
        return Canary->new($value);
    }
    croak "Unknown element type $fake->{elements}";
}

sub _find_top_value {
    my ($fake, $top) = @_;
    defined $top || croak "_find_top_value should not be called on undef";
    my $less = $fake->{less};
    my @pos;
    my $i = 0;
    for (@{$fake->{data}}) {
        push @pos, $i if $_->{value} eq $top;
        $i++;
    }
    croak "Extracted value $top should not have been in the heap" if @pos == 0;
    my $pos = shift @pos;
    for (@pos) {
        $pos = $_ if 
            $less->($fake->{data}[$_]{key}, $fake->{data}[$pos]{key});
    }
    my $key = $fake->{data}[$pos]{key};
    for (@{$fake->{data}}) {
        croak "$_->{key}, not $key should have been the top key" if 
            $less->($_->{key}, $key);
    }
    return $pos;
}

sub _find_lowest_key {
    my $fake = shift;
    die "_find_lowest_key on empty heap" unless @{$fake->{data}};
    my $less = $fake->{less};
    my @pos = 0..$#{$fake->{data}};
    my $pos = 0;
    for (@pos) {
        $pos = $_ if 
            $less->($fake->{data}[$_]{key}, $fake->{data}[$pos]{key});
    }
    return $pos;
}

sub insert {
    my ($fake, $value) = @_;
    $value = $fake->_make_element($value);
    $fake->{heap}->insert($value);
    my $key = $fake->{heap}->key($value);
    if (@{$fake->{data}} == $fake->{max_count}) {
        return unless @{$fake->{data}};
        my $less = $fake->{less};
        my $pos = $fake->_find_lowest_key;
        return unless $less->($fake->{data}[$pos]{key}, $key);
        splice(@{$fake->{data}}, $pos, 1);
    }
    push @{$fake->{data}}, {
        key   => $key, 
        value => $value,
    };
}

sub key_insert {
    my ($fake, $key, $value) = @_;
    $value = $fake->_make_element($value);
    $key = $fake->{prefix} . $key if $fake->{prefix};
    $fake->{heap}->key_insert($key, $value);
    if (@{$fake->{data}} == $fake->{max_count}) {
        return unless @{$fake->{data}};
        my $less = $fake->{less};
        my $pos = $fake->_find_lowest_key;
        return unless $less->($fake->{data}[$pos]{key}, $key);
        splice(@{$fake->{data}}, $pos, 1);
    }
    push @{$fake->{data}}, {
        key   => $key,
        value => $value};
}

sub _key_insert {
    my ($fake, $element) = @_;
    my $value = $fake->_make_element($element->[1]);
    my $key = 
        $fake->{prefix} ? $fake->{prefix} . $element->[0] : $element->[0];
    {
        $element->[0] = $key;
        $element->[1] = $value;
        $fake->{heap}->_key_insert($element);
    }
    if (@{$fake->{data}} == $fake->{max_count}) {
        return unless @{$fake->{data}};
        my $less = $fake->{less};
        my $pos = $fake->_find_lowest_key;
        return unless $less->($fake->{data}[$pos]{key}, $key);
        splice(@{$fake->{data}}, $pos, 1);
    }
    push @{$fake->{data}}, {
        key   => $key,
        value => $value};
}

sub count {
    my $fake = shift;
    my $n2 = @{$fake->{data}};
    if (wantarray) {
        my @n1 = $fake->{heap}->count;
        croak "$fake->{heap} real count didn't return exactly 1 value" if 
            @n1 != 1;
        croak "$fake->{heap} real count $n1[0], expected $n2" if $n2 != $n1[0];
    } else {
        my $n1 = $fake->{heap}->count;
        croak "$fake->{heap} real count $n1, expected $n2" if $n2 != $n1;
    }
    return $n2;
}

sub extract_top {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = eval { $fake->{heap}->extract_top };
        carp "$fake->{heap} extract_top returned not exactly one value" if 
            @top != 1 && !$@;
        $top = $top[0];
    } else {
        $top = eval { $fake->{heap}->extract_top };
    }
    if (@{$fake->{data}}) {
        my $pos = $fake->_find_top_value($top);
        splice(@{$fake->{data}}, $pos, 1);
        return $top;
    } elsif ($@) {
        die $@;
    } else {
        carp("Supposedly empty didn't explode");
    }
}

sub extract_min {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = eval { $fake->{heap}->extract_min };
        carp "$fake->{heap} extract_min returned not exactly one value" if 
            @top != 1 && !$@;
        $top = $top[0];
    } else {
        $top = eval { $fake->{heap}->extract_min };
    }
    if (@{$fake->{data}}) {
        my $pos = $fake->_find_top_value($top);
        splice(@{$fake->{data}}, $pos, 1);
        return $top;
    } elsif ($@) {
        die $@;
    } else {
        carp("Supposedly empty didn't explode");
    }
}

sub extract_first {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = $fake->{heap}->extract_first;
        if (@{$fake->{data}}) {
            carp "$fake->{heap} extract_first returned not exactly one value" 
                if @top != 1;
        } else {
            carp "$fake->{heap} extract_first did not return zero values" 
                if @top;
        }
        $top = $top[0];
    } else {
        $top = $fake->{heap}->extract_first;
    }
    if (@{$fake->{data}}) {
        my $pos = $fake->_find_top_value($top);
        splice(@{$fake->{data}}, $pos, 1);
        return $top;
    } else {
        croak "top should be undef" if defined $top;
        return;
    }
}

sub extract_upto {
    my $fake = shift;
    my @top;
    if (wantarray) {
        @top = $fake->{heap}->extract_upto(@_);
    } else {
        @top = scalar $fake->{heap}->extract_upto(@_);
    }
    @_ || croak "No limit was passed to extract_upto";
    my $limit = shift;
    my $less = $fake->{less};
    for my $top (@top) {
        @{$fake->{data}} || croak "Extracted value $top that should not exist";
        my $key = $fake->{heap}->key($top);
        my $i = 0;
        my $pos;
        for (@{$fake->{data}}) {
            croak "$_->{key}, not $key should have been the next key" if 
                $less->($_->{key}, $key);
            $pos = $i if $_->{value} eq $top;
            $i++;
        }
        defined $pos || 
            croak "Extracted value $top should not have been in the heap";
        splice(@{$fake->{data}}, $pos, 1);
    }
    for (@{$fake->{data}}) {
        croak "$_->{value} should have been returned too" if 
            !$less->($limit, $_->{key});
    }
    return wantarray ? @top : $top[0];
}

sub top {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = eval { $fake->{heap}->top };
        carp "$fake->{heap} top returned not exactly one value" if 
            @top != 1 && !$@;
        $top = $top[0];
    } else {
        $top = eval { $fake->{heap}->top };
    }
    if (@{$fake->{data}}) {
        $fake->_find_top_value($top);
        return $top;
    } elsif ($@) {
        die $@;
    } else {
        carp("Supposedly empty didn't explode");
    }
}

sub first {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = eval { $fake->{heap}->first };
        if (@top == 0) {
            croak "Got no first value on non-empty heap" if @{$fake->{data}};
            return;
        }         
        croak "Got multiple values from first" if @top != 1;
        $top = $top[0];
        croak "Got first value on empty heap" if 
            !@{$fake->{data}} && defined $top;
    } else {
        $top = eval { $fake->{heap}->first };
    }
    if (@{$fake->{data}}) {
        $fake->_find_top_value($top);
        return $top;
    } elsif (defined($top)) {
        croak "Got a defined first from an empty heap";
    } else {
        return undef;
    }
}

sub top_key {
    my $fake = shift;
    my ($top, $n);
    if (wantarray) {
        my @top = eval { $fake->{heap}->top_key };
        $n = @top;
        $top = $top[0];
    } else {
        $top = eval { $fake->{heap}->top_key };
        $n = 1;
    }
    if (@{$fake->{data}}) {
        $n == 1 || croak "top_key should have returned one value";
        my $less = $fake->{less};
        my $key = $top;
        my $i = 0;
        my $pos;
        my $numeric = $fake->{num_order} && $fake->{dirty};
        for (@{$fake->{data}}) {
            croak "$_->{key}, not $key should have been the top key" if 
                $less->($_->{key}, $key);
            $pos = $i if $numeric ? $_->{key} == $key : $_->{key} eq $key;
            $i++;
        }
        defined $pos || 
            croak "Extracted key $top should not have been in the heap";
    } else {
        my $err = $@;
        if (defined(my $inf = $fake->{heap}->infinity)) {
            $top eq $inf || 
                croak "Should have gotten infinity $inf, but got $top";
            $n == 1 || croak "top_key should have returned one value";
        } elsif ($err) {
            die $err;
        } else {
            carp("Supposedly empty didn't explode");
        }
    }
    return $top;
}

sub min_key {
    my $fake = shift;
    my ($top, $n);
    if (wantarray) {
        my @top = eval { $fake->{heap}->min_key };
        $n = @top;
        $top = $top[0];
    } else {
        $top = eval { $fake->{heap}->min_key };
        $n = 1;
    }
    if (@{$fake->{data}}) {
        $n == 1 || croak "min_key should have returned one value";
        my $less = $fake->{less};
        my $key = $top;
        my $i = 0;
        my $pos;
        my $numeric = $fake->{num_order} && $fake->{dirty};
        for (@{$fake->{data}}) {
            croak "$_->{key}, not $key should have been the top key" if 
                $less->($_->{key}, $key);
            $pos = $i if $numeric ? $_->{key} == $key : $_->{key} eq $key;
            $i++;
        }
        defined $pos || 
            croak "Extracted key $top should not have been in the heap";
    } else {
        my $err = $@;
        if (defined(my $inf = $fake->{heap}->infinity)) {
            $top eq $inf || 
                croak "Should have gotten infinity $inf, but got $top";
            $n == 1 || croak "min_key should have returned one value";
        } elsif ($err) {
            die $err;
        } else {
            carp("Supposedly empty didn't explode");
        }
    }
    return $top;
}

sub first_key {
    my $fake = shift;
    my $top;
    if (wantarray) {
        my @top = $fake->{heap}->first_key;
        if (@top == 0) {
            croak "Got no first_key value on non-empty heap" if
                @{$fake->{data}};
            return;
        }         
        croak "Got multiple values from first_key" if @top != 1;
        $top = $top[0];
        croak "Got first_key value on empty heap" if 
            !@{$fake->{data}} && defined $top;
    } else {
        $top = eval { $fake->{heap}->first_key };
    }
    if (@{$fake->{data}}) {
        my $less = $fake->{less};
        my $key = $top;
        my $i = 0;
        my $pos;
        my $numeric = $fake->{num_order} && $fake->{dirty};
        for (@{$fake->{data}}) {
            croak "$_->{key}, not $key should have been the top key" if 
                $less->($_->{key}, $key);
            $pos = $i if $numeric ? $_->{key} == $key : $_->{key} eq $key;
            $i++;
        }
        defined $pos || 
            croak "Extracted key $top should not have been in the heap";
        return $top;
    } elsif (defined($top)) {
        croak "Got a defined first_key from an empty heap";
    } else {
        return undef;
    }
}

sub values {
    my $fake = shift;
    my @values = $fake->{heap}->values;
    my @svalues = sort @values;
    my @fvalues = sort map $_->{value}, @{$fake->{data}};
    @fvalues == @svalues || croak "Number of returned values differ";
    for (@svalues) {
        my $n = shift @fvalues;
        $n eq $_ || croak "values: Unexpected value, either $_ or $n";
    }
    # No check for heap property. test suite will implicitely test it
    # when it checks compatibility of keys and values order
    return @values;
}

sub keys {
    my $fake = shift;
    my @keys = $fake->{heap}->keys;
    my (@skeys, @fkeys);
    if ($fake->{num_order}  && $fake->{dirty}) {
        @skeys = sort { $a <=> $b } @keys;
        @fkeys = sort { $a <=> $b } map $_->{key}, @{$fake->{data}};
    } else {
        @skeys = sort @keys;
        @fkeys = sort map $_->{key}, @{$fake->{data}};
    }
    @skeys == @fkeys || croak "Number of returned keys differ";
    for (@skeys) {
        my $n = shift @fkeys;
        if ($fake->{num_order}  && $fake->{dirty}) {
            $n == $_ || croak "keys: Unexpected numeric key, either $_ or $n";
        } else {
            $n eq $_ || croak "keys: Unexpected key, either $_ or $n";
        }
    }
    # Check heap property
    my $less = $fake->{less};
    my $n = 0;
    for (0..$#keys) {
        last if ++$n > $#keys;
        croak "heap property violated" if $less->($keys[$n], $keys[$_]);
        last if ++$n > $#keys;
        croak "heap property violated" if $less->($keys[$n], $keys[$_]);
    }
    return @keys;
}

sub key_index {
    my $fake = shift;
    my $pos;
    if (wantarray) {
        my @pos = eval { $fake->{heap}->key_index(@_) };
        croak "key_index returned multiple values: @pos" if @pos > 1;
        croak "key_index didn't return any values" if !@pos && !$@;
        $pos = $pos[0];
    } else {
        $pos = eval { $fake->{heap}->key_index(@_) };
    }
    if ($@) {
        die $@ if $fake->{elements} ne "Array";
        carp "key_index should not have died";
        croak "key_index should not have died";
    }
    croak "key_index should have died" if $fake->{elements} ne "Array";
    $pos eq ($fake->{index} || 0) || croak "key_index: Unexpected key index";
    return $pos;
}

sub key_name {
    my $fake = shift;
    my $pos;
    if (wantarray) {
        my @pos = eval { $fake->{heap}->key_name(@_) };
        croak "key_name returned multiple values: @pos" if @pos > 1;
        croak "key_name didn't return any values" if !@pos && !$@;
        $pos = $pos[0];
    } else {
        $pos = eval { $fake->{heap}->key_name(@_) };
    }
    if ($@) {
        die $@ if $fake->{elements} ne "Hash";
        carp "key_name should not have died";
        croak "key_name should not have died";
    }
    croak "key_name should have died" if $fake->{elements} ne "Hash";
    $pos eq ($fake->{index} || 0) || croak "key_name: Unexpected key name";
    return $pos;
}

sub key_method {
    my $fake = shift;
    my $pos;
    if (wantarray) {
        my @pos = eval { $fake->{heap}->key_method(@_) };
        croak "key_method returned multiple values: @pos" if @pos > 1;
        croak "key_method didn't return any values" if !@pos && !$@;
        $pos = $pos[0];
    } else {
        $pos = eval { $fake->{heap}->key_method(@_) };
    }
    if ($@) {
        die $@ if 
            $fake->{elements} ne "Method" && $fake->{elements} ne "Object";
        carp "key_method should not have died";
        croak "key_method should not have died";
    }
    croak "key_method should have died" if
            $fake->{elements} ne "Method" && $fake->{elements} ne "Object";
    $pos eq ($fake->{index} || 0) || croak "key_method: Unexpected key method";
    return $pos;
}

sub key_function {
    my $fake = shift;
    my $pos;
    if (wantarray) {
        my @pos = eval { $fake->{heap}->key_function(@_) };
        croak "key_function returned multiple values: @pos" if @pos > 1;
        croak "key_function didn't return any values" if !@pos && !$@;
        $pos = $pos[0];
    } else {
        $pos = eval { $fake->{heap}->key_function(@_) };
    }
    if ($@) {
        die $@ if 
            $fake->{elements} ne "Function" && $fake->{elements} ne "Any";
        carp "key_function should not have died";
        croak "key_function should not have died";
    }
    croak "key_function should have died" if
            $fake->{elements} ne "Function" && $fake->{elements} ne "Any";
    $pos eq ($fake->{index} || 0) || 
        croak "key_function: Unexpected key function";
    return $pos;
}

sub absorb {
    my ($fake1, $fake2) = @_;
    my @k2 = $fake2->keys;
    my @v2 = $fake2->values,
    $fake1->{heap}->absorb($fake2);
    my $less = $fake1->{less};
    while (@v2) {
        my $value = shift @v2;
        my $key   = shift @k2;
        if (@{$fake1->{data}} == $fake1->{max_count}) {
            next unless @{$fake1->{data}};
            my $pos = $fake1->_find_lowest_key;
            next unless $less->($fake1->{data}[$pos]{key}, $key);
            splice(@{$fake1->{data}}, $pos, 1);
        }
        push @{$fake1->{data}}, {
            key   => $key, 
            value => $value,
        };
    }
}

sub key_absorb {
    my ($fake1, $fake2) = @_;
    my @k2 = $fake2->keys;
    my @v2 = $fake2->values,
    $fake1->{heap}->key_absorb($fake2);
    my $less = $fake1->{less};
    while (@v2) {
        my $value = shift @v2;
        my $key   = shift @k2;
        if (@{$fake1->{data}} == $fake1->{max_count}) {
            next unless @{$fake1->{data}};
            my $pos = $fake1->_find_lowest_key;
            next unless $less->($fake1->{data}[$pos]{key}, $key);
            splice(@{$fake1->{data}}, $pos, 1);
        }
        push @{$fake1->{data}}, {
            key   => $key, 
            value => $value,
        };
    }
}

sub _absorb {
    my ($fake1, $fake2) = @_;
    $fake1->{heap}->_absorb($fake2);
    @{$fake1->{data}} = ();
}

sub _key_absorb {
    my ($fake1, $fake2) = @_;
    $fake1->{heap}->_key_absorb($fake2);
    @{$fake1->{data}} = ();
}

sub clear {
    my $fake = shift;
    @{$fake->{data}} = ();    
    return $fake->{heap}->clear(@_);
}

sub user_data {
    return shift->{heap}->user_data(@_);
}

sub infinity {
    return shift->{heap}->infinity(@_);
}

sub order {
    return shift->{heap}->order(@_);
}

sub elements {
    return shift->{heap}->elements(@_);
}

sub wrapped {
    return shift->{heap}->wrapped(@_);
}

sub key {
    return shift->{heap}->key(@_);
}

sub max_count {
    return shift->{heap}->max_count(@_);
}

sub dirty {
    return shift->{heap}->dirty(@_);
}

sub can_die {
    return shift->{heap}->can_die(@_);
}

sub implementation {
    return shift->{heap}->implementation(@_);
}

sub heap {
    return shift->{heap};
}

1;
