use strict;
use warnings;

use Benchmark q{cmpthese};

my @tiny   = do
   {
       map { int rand 100 } 1 .. 1000
   };
my @small  = do
   {
       map { int rand 100 } 1 .. 5000
   };
my @medium = do
   {
       map { int rand 100 } 1 .. 10000
   };
my @large  = do
   {
       map { int rand 100 } 1 .. 50000
   };
my @cutoffs = map { $_ * 10 } 1, 3, 5, 7, 9;

my ( @array, @extracted );
my $rsCutoff = \ do { my $anon };

my $rcSift = sub
   {
       my $toTest = shift;
       return $toTest >= ${ $rsCutoff } ? 0 : 1;
   };

foreach my $cutoff ( @cutoffs )
{
    print qq{\n@{ [ q{=} x 60 ] }\n} unless $cutoff == 10;
    ${ $rsCutoff } = $cutoff;
    foreach my $raOrig ( \ @tiny, \ @small, \ @medium, \ @large )
    {
        print
           qq{\n},
           qq{Sifting approx. $cutoff% from },
           qq{array of @{ [ scalar @$raOrig ] } },
           qq{integers from 0 to 99\n},
           ;
        cmpthese (
           -3,
           {
               johngg   => sub
                  {
                      my @array = @$raOrig;
                      my @extracted = johngg( $rcSift, \ @array );
                  },
               lodin    => sub
                  {
                      my @array = @$raOrig;
                      my @extracted = lodin( $rcSift, \ @array );
                  },
               merlyn   => sub
                  {
                      my @array = @$raOrig;
                      my @extracted = merlyn( $rcSift, \ @array );
                  },
               twoGreps => sub
                  {
                      my @array = @$raOrig;
                      my @extracted = twoGreps( $rcSift, \ @array );
                  },
           }
           );
    }
}

sub johngg
{
    my ( $rcSift, $raOrig ) = @_;
    return
       reverse
       map  { splice @$raOrig, $_, 1 }
       grep { $rcSift->( $raOrig->[ $_ ] ) }
       reverse 0 .. $#$raOrig;
}

sub lodin
{
    my ($code, $list) = @_;
    my @extracted;
    my $c = 0;
    while ($c < @$list) {
        local *_ = \$list->[$c];
        if ($code->($_)) {
            push @extracted, splice @$list, $c, 1;
        }
        else {
            $c++;
        }
    }
    return @extracted;
}

sub merlyn {
  my ($code, $aref) = @_;
  my @return;
  my @replace;
  for (@$aref) {
    if ($code->($_)) {
      push @return, $_;
    } else {
      push @replace, $_;
    }
  }
  @$aref = @replace;
  return @return;
}

sub twoGreps
{
    my ( $rcSift, $raOrig ) = @_;
    my @extracted = grep { $rcSift->( $_ ) } @$raOrig;
    @$raOrig = grep { ! $rcSift->( $_ ) } @$raOrig;
    return @extracted;
}