You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
385 lines
9.0 KiB
385 lines
9.0 KiB
package NGCP::BulkProcessor::Array;
|
|
use strict;
|
|
|
|
## no critic
|
|
|
|
use NGCP::BulkProcessor::Table;
|
|
|
|
require Exporter;
|
|
our @ISA = qw(Exporter);
|
|
our @EXPORT_OK = qw(
|
|
mergearrays
|
|
removeduplicates
|
|
itemcount
|
|
grouparray
|
|
reversearray
|
|
contains
|
|
arrayeq
|
|
mapeq
|
|
seteq
|
|
setcontains
|
|
filter
|
|
getroundrobinitem
|
|
getrandomitem
|
|
array_to_map);
|
|
|
|
sub mergearrays {
|
|
|
|
my ($array_ptr1,$array_ptr2) = @_;
|
|
my @result = ();
|
|
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
|
foreach my $element (@$array_ptr1) {
|
|
push @result,$element;
|
|
}
|
|
}
|
|
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
|
foreach my $element (@$array_ptr2) {
|
|
push @result,$element;
|
|
}
|
|
}
|
|
return \@result;
|
|
|
|
}
|
|
|
|
sub removeduplicates {
|
|
|
|
my ($array_ptr,$case_insensitive) = @_;
|
|
my @result = ();
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
|
|
foreach my $element (@$array_ptr) {
|
|
if (not contains($element,\@result,$case_insensitive)) {
|
|
push @result,$element;
|
|
}
|
|
}
|
|
}
|
|
return \@result;
|
|
|
|
}
|
|
|
|
sub itemcount {
|
|
|
|
my ($item,$array_ptr,$case_insensitive) = @_;
|
|
my $itemcount = 0;
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
if ($case_insensitive) {
|
|
foreach my $element (@$array_ptr) {
|
|
if (lc($element) eq lc($item)) {
|
|
$itemcount += 1;
|
|
}
|
|
}
|
|
} else {
|
|
foreach my $element (@$array_ptr) {
|
|
if ($element eq $item) {
|
|
$itemcount += 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $itemcount;
|
|
|
|
}
|
|
|
|
sub grouparray {
|
|
|
|
my ($array_ptr,$case_insensitive) = @_;
|
|
my $result = new NGCP::BulkProcessor::Table();
|
|
my $reducedarray = removeduplicates($array_ptr,$case_insensitive);
|
|
my $sort_occurencecount_desc;
|
|
if ($case_insensitive) {
|
|
$sort_occurencecount_desc = sub {
|
|
|
|
return ((lc($NGCP::BulkProcessor::Table::b->[1]) <=> lc($NGCP::BulkProcessor::Table::a->[1])) or (lc($NGCP::BulkProcessor::Table::a->[0]) cmp lc($NGCP::BulkProcessor::Table::b->[0])));
|
|
|
|
};
|
|
} else {
|
|
$sort_occurencecount_desc = sub {
|
|
|
|
return (($NGCP::BulkProcessor::Table::b->[1] <=> $NGCP::BulkProcessor::Table::a->[1]) or ($NGCP::BulkProcessor::Table::a->[0] cmp $NGCP::BulkProcessor::Table::b->[0]));
|
|
|
|
};
|
|
}
|
|
foreach my $element (@$reducedarray) {
|
|
$result->addrow_ref([$element,itemcount($element,$array_ptr,$case_insensitive)]);
|
|
}
|
|
$result->sortrows($sort_occurencecount_desc);
|
|
return $result;
|
|
|
|
}
|
|
|
|
sub reversearray {
|
|
|
|
my ($array_ptr) = @_;
|
|
my @result = ();
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
my $ubound = (scalar @$array_ptr) - 1;
|
|
for (my $i = $ubound; $i >= 0; $i -= 1) {
|
|
$result[$i] = $array_ptr->[$ubound - $i];
|
|
}
|
|
}
|
|
return \@result;
|
|
|
|
}
|
|
|
|
sub contains {
|
|
|
|
my ($item,$array_ptr,$case_insensitive) = @_;
|
|
my $result = 0;
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
if ($case_insensitive) {
|
|
foreach my $element (@$array_ptr) {
|
|
if (lc($element) eq lc($item)) {
|
|
$result = 1;
|
|
last;
|
|
}
|
|
}
|
|
} else {
|
|
foreach my $element (@$array_ptr) {
|
|
if ($element eq $item) {
|
|
$result = 1;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $result;
|
|
|
|
}
|
|
|
|
sub arrayeq {
|
|
|
|
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
|
my $ubound1;
|
|
my $ubound2;
|
|
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
|
$ubound1 = (scalar @$array_ptr1) - 1;
|
|
} else {
|
|
$ubound1 = -1;
|
|
}
|
|
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
|
$ubound2 = (scalar @$array_ptr2) - 1;
|
|
} else {
|
|
$ubound2 = -1;
|
|
}
|
|
my $result = 1;
|
|
if ($ubound1 != $ubound2) {
|
|
return 0;
|
|
} else {
|
|
if ($case_insensitive) {
|
|
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
|
if (lc($array_ptr1->[$i]) ne lc($array_ptr2->[$i])) {
|
|
return 0;
|
|
}
|
|
}
|
|
} else {
|
|
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
|
if ($array_ptr1->[$i] ne $array_ptr2->[$i]) {
|
|
return 0;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
sub seteq {
|
|
|
|
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
|
my $ubound1;
|
|
my $ubound2;
|
|
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
|
$ubound1 = (scalar @$array_ptr1) - 1;
|
|
} else {
|
|
$ubound1 = -1;
|
|
}
|
|
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
|
$ubound2 = (scalar @$array_ptr2) - 1;
|
|
} else {
|
|
$ubound2 = -1;
|
|
}
|
|
# every element of array1 must be existent in array2 ...
|
|
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
|
if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
|
return 0;
|
|
}
|
|
}
|
|
# ... and every element of array2 must be existent in array1
|
|
for (my $i = 0; $i <= $ubound2; $i += 1) {
|
|
if (not contains($array_ptr2->[$i],$array_ptr1,$case_insensitive)) {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
sub setcontains {
|
|
|
|
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
|
my $ubound1;
|
|
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
|
$ubound1 = (scalar @$array_ptr1) - 1;
|
|
} else {
|
|
$ubound1 = -1;
|
|
}
|
|
# every element of array1 must be existent in array2:
|
|
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
|
if (not contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
sub filter {
|
|
|
|
my ($array_ptr1,$array_ptr2,$case_insensitive) = @_;
|
|
my $ubound1;
|
|
my $ubound2;
|
|
if (defined $array_ptr1 and ref $array_ptr1 eq 'ARRAY') {
|
|
$ubound1 = (scalar @$array_ptr1) - 1;
|
|
} else {
|
|
return [];
|
|
}
|
|
if (defined $array_ptr2 and ref $array_ptr2 eq 'ARRAY') {
|
|
$ubound2 = (scalar @$array_ptr2) - 1;
|
|
} else {
|
|
return $array_ptr1;
|
|
}
|
|
my @result = ();
|
|
# every element of array1 must be existent in array2 ...
|
|
for (my $i = 0; $i <= $ubound1; $i += 1) {
|
|
if (contains($array_ptr1->[$i],$array_ptr2,$case_insensitive)) {
|
|
push @result,$array_ptr1->[$i];
|
|
}
|
|
}
|
|
|
|
return \@result;
|
|
|
|
}
|
|
|
|
sub getroundrobinitem {
|
|
|
|
my ($array_ptr,$recentindex) = @_;
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
my $size = (scalar @$array_ptr);
|
|
if ($size == 1) {
|
|
return (@{$array_ptr}[0],0);
|
|
} elsif ($size > 1) {
|
|
if (!defined $recentindex or $recentindex < 0) {
|
|
$recentindex = -1;
|
|
}
|
|
my $newindex = ($recentindex + 1) % $size;
|
|
return (@{$array_ptr}[$newindex],$newindex);
|
|
}
|
|
}
|
|
return (undef,undef);
|
|
|
|
}
|
|
|
|
sub getrandomitem {
|
|
|
|
my ($array_ptr) = @_;
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
my $size = (scalar @$array_ptr);
|
|
if ($size == 1) {
|
|
return (@{$array_ptr}[0],0);
|
|
} elsif ($size > 1) {
|
|
my $newindex = int(rand($size));
|
|
return (@{$array_ptr}[$newindex],$newindex);
|
|
}
|
|
}
|
|
return (undef,undef);
|
|
|
|
}
|
|
|
|
sub array_to_map {
|
|
|
|
my ($array_ptr,$get_key_code,$get_value_code,$mode) = @_;
|
|
my $map = {};
|
|
my @keys = ();
|
|
my @values = ();
|
|
if (defined $array_ptr and ref $array_ptr eq 'ARRAY') {
|
|
if (defined $get_key_code and ref $get_key_code eq 'CODE') {
|
|
if (not (defined $get_value_code and ref $get_value_code eq 'CODE')) {
|
|
$get_value_code = sub { return shift; };
|
|
}
|
|
$mode = lc($mode);
|
|
if (not ($mode eq 'group' or $mode eq 'first' or $mode eq 'last')) {
|
|
$mode = 'group';
|
|
}
|
|
foreach my $item (@$array_ptr) {
|
|
my $key = &$get_key_code($item);
|
|
if (defined $key) {
|
|
my $value = &$get_value_code($item);
|
|
if (defined $value) {
|
|
if (not exists $map->{$key}) {
|
|
if ($mode eq 'group') {
|
|
$map->{$key} = [ $value ];
|
|
} else {
|
|
$map->{$key} = $value;
|
|
}
|
|
push(@keys,$key);
|
|
} else {
|
|
if ($mode eq 'group') {
|
|
push(@{$map->{$key}}, $value);
|
|
} elsif ($mode eq 'last') {
|
|
$map->{$key} = $value;
|
|
}
|
|
}
|
|
push(@values,$value);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return ($map,\@keys,\@values);
|
|
|
|
}
|
|
|
|
sub mapeq {
|
|
my ($map_prt1,$map_prt2,$case_insensitive) = @_;
|
|
my $key_count1;
|
|
my $key_count2;
|
|
if (defined $map_prt1 and ref $map_prt1 eq 'HASH') {
|
|
$key_count1 = (scalar keys %$map_prt1);
|
|
} else {
|
|
$key_count1 = 0;
|
|
}
|
|
if (defined $map_prt2 and ref $map_prt2 eq 'HASH') {
|
|
$key_count2 = (scalar keys %$map_prt2);
|
|
} else {
|
|
$key_count2 = 0;
|
|
}
|
|
if ($key_count1 != $key_count2) {
|
|
return 0; #print "they don't have the same number of keys\n";
|
|
} else {
|
|
my %cmp = map { $_ => 1 } keys %$map_prt1;
|
|
if ($case_insensitive) {
|
|
for my $key (keys %$map_prt2) {
|
|
last unless exists $cmp{$key};
|
|
last unless $map_prt1->{$key} eq $map_prt2->{$key};
|
|
delete $cmp{$key};
|
|
}
|
|
} else {
|
|
for my $key (keys %$map_prt2) {
|
|
last unless exists $cmp{$key};
|
|
last unless lc($map_prt1->{$key}) eq lc($map_prt2->{$key});
|
|
delete $cmp{$key};
|
|
}
|
|
}
|
|
if (%cmp) {
|
|
return 0; #print "they don't have the same keys or values\n";
|
|
} else {
|
|
return 1; #print "they have the same keys or values\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
1;
|