#!/usr/bin/perl

use constant PARTITION_SIZE => 5;

# NOTE 1: the $index in selection() is one-based, not zero-based as usual.
# NOTE 2: when $N is even, selection() returns the larger of
#         "two medians", not their average as is customary--
#         write a wrapper if this bothers you.

sub selection {
    # $array:   an array reference from which the selection is made.
    # $compare: a code reference for comparing elements,
    #           must return -1, 0, 1.
    # $index:   the wanted index in the array.
    my ($array, $compare, $index) = @_;

    my $N = @$array;

    # Short circuit for partitions.
    return (sort { $compare->($a, $b) } @$array)[ $index-1 ]
         if $N <= PARTITION_SIZE;

    my $medians;

    # Find the median of the about $N/5 partitions.
    for ( my $i = 0; $i < $N; $i += PARTITION_SIZE ) {
        my $s =                 # The size of this partition.
            $i + PARTITION_SIZE < $N ?
                PARTITION_SIZE : $N - $i;

        my @s =                 # This partition sorted.
            sort { $array->[ $i + $a ] cmp $array->[ $i + $b ] }
                 0 .. $s-1;
        push @{ $medians },     # Accumulate the medians.
             $array->[ $i + $s[ int( $s / 2 ) ] ];
    }

    # Recurse to find the median of the medians.
    my $median = selection( $medians, $compare, int( @$medians / 2 ) );
    my @kind;

    use constant LESS    => 0;
    use constant EQUAL   => 1;
    use constant GREATER => 2;

    # Less-than    elements end up in @{$kind[LESS]},
    # equal-to     elements end up in @{$kind[EQUAL]},
    # greater-than elements end up in @{$kind[GREATER]}.
    foreach my $elem (@$array) {
        push @{ $kind[$compare->($elem, $median) + 1] }, $elem;
    }

    return selection( $kind[LESS], $compare, $index )
        if $index <= @{ $kind[LESS]  };

    $index -= @{ $kind[LESS] };

    return $median
        if $index <= @{ $kind[EQUAL] };
 
    $index -= @{ $kind[EQUAL] };

    return selection( $kind[GREATER], $compare, $index );
}

sub median {
    my $array = shift;
    return selection( $array,
                      sub { $_[0] <=> $_[1] },
                      @$array / 2 + 1 );
}

sub percentile {
    my ($array, $percentile) = @_;
    return selection( $array,
                      sub { $_[0] <=> $_[1] },
                      (@$array * $percentile) / 100 );
}

@scores = qw(40 53 77 49 78 20 89 35 68 55 52 71);

print percentile(\@scores, 90), "\n";