view release on metacpan or  search on metacpan

Tools.pm  view on Meta::CPAN

 my @top10           = rank(-10, [1..100]);     # 100, 99, 98, 97, 96, 95, 94, 93, 92, 91
 my $max             = rank(-1, [101,102,103,102,101]); #103
 my @contest         = ({name=>"Alice",score=>14},{name=>"Bob",score=>13},{name=>"Eve",score=>12});
 my $second          = rank(2, \@contest, sub{$_[1]{score}<=>$_[0]{score}})->{name}; #Bob

=head2 rankstr

Just as C<rank> but sorts alphanumerically (strings, cmp) instead of numerically.

=cut

sub rank {
  my($rank,$aref,$cmpsub)=@_;
  if($rank<0){
    $cmpsub||=sub{$_[0]<=>$_[1]};
    return rank(-$rank,$aref,sub{0-&$cmpsub});
  }
  my @sort;
  local $Pushsort_cmpsub=$cmpsub;
  for(@$aref){
    pushsort @sort, $_;
    pop @sort if @sort>$rank;
  }
  return wantarray ? @sort : $sort[$rank-1];
}
sub rankstr {wantarray?(rank(@_,sub{$_[0]cmp$_[1]})):rank(@_,sub{$_[0]cmp$_[1]})}

=head2 egrep

Extended grep.

Works like L<grep> but with more insight: local vars $i, $n, $prev, $next, $prevr and $nextr are available:

$i is the current index, starts with 0, ends with the length of the input array minus one

$n is the current element number, starts with 1, $n = $i + 1

$prev is the previous value (undef if current is first)

$next is the next value (undef if current is last)

$prevr is the previous value, rotated so that the previous of the first element is the last element

$nextr is the next value, rotated so that the next of the last element is the first element

$_ is the current value, just as with Perls built-in grep

 my @a = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20);  # 1..20
 my @r = egrep { $_ % 3 == 0 } @a;  # @r is 3, 6, 9, 12, 15, 18. Plain grep could have been used here
 my @r = egrep { $i==1 or $next==12 or $prev==14 } @a;  # @r is now 2, 11, 15

 my @a=2..44;
 egrep { $prev =~/4$/ or $next =~/2$/ } @a;  # 5, 11, 15, 21, 25, 31, 35, 41
 egrep { $prevr=~/4$/ or $nextr=~/2$/ } @a;  # 2, 5, 11, 15, 21, 25, 31, 35, 41, 44
 egrep { $i%7==0 } @a;                       # 2, 9, 16, 23, 30, 37, 44
 egrep { $n%7==0 } @a;                       # 8, 15, 22, 29, 36, 43

=cut

sub egrep (&@) {
    my($code,$i,$package)=(shift,-1,(caller)[0]);
    my %h=map{($_=>"${package}::$_")}qw(i n prev next prevr nextr);
    no strict 'refs';
    grep {
	#no strict 'refs'; #not here! "no" not allowed in expression in perl5.16
	local ${$h{i}}     = ++$i;
	local ${$h{n}}     = $i+1;
	local ${$h{prev}}  = $i>0?$_[$i-1]:undef;
	local ${$h{next}}  = $i<$#_?$_[$i+1]:undef;
	local ${$h{prevr}} = $_[$i>0?$i-1:$#_];
	local ${$h{nextr}} = $_[$i<$#_?$i+1:0];
	&$code;
    }
    @_;
}

=head2 eqarr

B<Input:> Two or more references to arrays.

B<Output:> True (1) or false (0) for whether or not the arrays are numerically I<and> alphanumerically equal.
Comparing each element in each array with both C< == > and C< eq >.

Examples:

 eqarr([1,2,3],[1,2,3],[1,2,3]); # 1 (true)
 eqarr([1,2,3],[1,2,3],[1,2,4]); # 0 (false)
 eqarr([1,2,3],[1,2,3,4]);       # undef (different size, false)
 eqarr([1,2,3]);                 # croak (should be two or more arrays)
 eqarr([1,2,3],1,2,3);           # croak (not arraysrefs)

=cut

sub eqarr {
  my @arefs=@_;
  croak if @arefs<2;
  ref($_) ne 'ARRAY' and croak for @arefs;
  @{$arefs[0]} != @{$arefs[$_]} and return undef for 1..$#arefs;
  my $ant;

  for my $ar (@arefs[1..$#arefs]){
    for(0..@$ar-1){
      ++$ant and $ant>100 and croak ">100";  #TODO: feiler ved sammenligning av to tabeller > 10000(?) tall
      return 0 if $arefs[0][$_] ne $$ar[$_]
   	       or $arefs[0][$_] != $$ar[$_];
    }
  }
  return 1;
}

=head2 sorted

Return true if the input array is numerically sorted.

  @a=(1..10); print "array is sorted" if sorted @a;  #true

Optionally the last argument can be a comparison sub:

  @person=({Rank=>1,Name=>'Amy'}, {Rank=>2,Name=>'Paula'}, {Rank=>3,Name=>'Ruth'});
  print "Persons are sorted" if sorted @person, sub{$_[0]{Rank}<=>$_[1]{Rank}};