File Coverage

blib/lib/List/Compare/Functional.pm

Criterion	Covered	Total	%
statement	270	270	100.0
branch	44	44	100.0
condition			n/a
subroutine	56	56	100.0
pod	0	30	0.0
total	370	400	92.5

package List::Compare::Functional;
our $VERSION = '0.54';
our @ISA = qw(Exporter);
our @EXPORT_OK = qw|
    get_intersection
    get_intersection_ref
    get_union
    get_union_ref
    get_unique
    get_unique_ref
    get_unique_all
    get_complement
    get_complement_ref
    get_complement_all
    get_symmetric_difference
    get_symmetric_difference_ref
    is_LsubsetR
    is_RsubsetL
    is_LequivalentR
    is_LdisjointR
    is_member_which
    is_member_which_ref
    are_members_which
    is_member_any
    are_members_any
    print_subset_chart
    print_equivalence_chart
    get_shared
    get_shared_ref
    get_nonintersection
    get_nonintersection_ref
    get_symdiff
    get_symdiff_ref
    is_LeqvlntR
    get_bag
    get_bag_ref
    get_version
|;
our %EXPORT_TAGS = (
    main => [ qw(
        get_intersection
        get_union
        get_unique
        get_complement
        get_symmetric_difference
        is_LsubsetR
    ) ],
    mainrefs => [ qw(
        get_intersection_ref
        get_union_ref
        get_unique_ref
        get_complement_ref
        get_symmetric_difference_ref
    ) ],
    originals => [ qw(
        get_intersection
        get_intersection_ref
        get_union
        get_union_ref
        get_unique
        get_unique_ref
        get_unique_all
        get_complement
        get_complement_ref
        get_complement_all
        get_symmetric_difference
        get_symmetric_difference_ref
        get_shared
        get_shared_ref
        get_nonintersection
        get_nonintersection_ref
        is_LsubsetR
        is_RsubsetL
        is_LequivalentR
        is_LdisjointR
        is_member_which
        is_member_which_ref
        are_members_which
        is_member_any
        are_members_any
        print_subset_chart
        print_equivalence_chart
        get_bag
        get_bag_ref
        get_version
    ) ],
    aliases => [ qw(
        get_symdiff
        get_symdiff_ref
        is_LeqvlntR
    ) ],
);
use strict;
local $^W = 1;
use Carp;
use List::Compare::Base::_Auxiliary qw(
    _subset_subengine
    _chart_engine_multiple
    _equivalent_subengine
    _calc_seen1
);
use List::Compare::Base::_Auxiliary qw(:calculate :checker :tester);
use List::Compare::Base::_Engine qw(
    _unique_all_engine
    _complement_all_engine
);


sub get_union {
    return @{ get_union_ref(@_) };
}

sub get_union_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _union_engine(_argument_checker($argref))
        : return [ sort @{_union_engine(_argument_checker($argref))} ];
}

sub _union_engine {
    my $seenrefsref = _calc_seen1(@_);
    my $unionhashref = _calculate_union_only($seenrefsref);
    return [ keys %{$unionhashref} ];
}

sub get_intersection {
    return @{ get_intersection_ref(@_) };
}

sub get_intersection_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _intersection_engine(_argument_checker($argref))
        : return [ sort @{_intersection_engine(_argument_checker($argref))} ];
}

sub _intersection_engine {
    my $seenrefsref = _calc_seen1(@_);
    my @vals = sort { scalar(keys(%{$a})) <=> scalar(keys(%{$b})) }
        @{$seenrefsref};
    my %intersection = map { $_ => 1 } keys %{$vals[0]};
    for my $l ( 1..$#vals ) {
        %intersection = map { $_ => 1 }
            grep { exists $intersection{$_} }
            keys %{$vals[$l]};
    }
    return [ keys %intersection ];
}

sub get_unique {
    return @{ get_unique_ref(@_) };
}

sub get_unique_ref {
    my ($argref, $unsorted) = _alt_construct_tester_3(@_);
    $unsorted
        ? return          _unique_engine(_argument_checker_3($argref))
        : return [ sort @{_unique_engine(_argument_checker_3($argref))} ];
}

sub get_unique_all {
    my ($argref, $unsorted) = _alt_construct_tester_3(@_);
    # currently it doesn't appear that &_unique_all_engine can make use of
    # $unsorted
    return _unique_all_engine(_argument_checker_3a($argref));
}

sub _unique_engine {
    my $index = pop(@_);
    my $seenref = _calculate_seen_only(_calc_seen1(@_));

    my %seen_in_all_others = ();
    my @seenthis = ();
    for my $i (keys %{$seenref}) {
        unless ($i == $index) {
            for my $k (keys %{$seenref->{$i}}) {
                $seen_in_all_others{$k}++;
            }
        }
        else {
            @seenthis = keys %{$seenref->{$index}};
        }
    }
    my @unique_to_this_index = ();
    for my $s (@seenthis) {
        push @unique_to_this_index, $s
            unless $seen_in_all_others{$s};
    }
    return \@unique_to_this_index;
}

sub get_complement {
    return @{ get_complement_ref(@_) };
}

sub get_complement_ref {
    my ($argref, $unsorted) = _alt_construct_tester_3(@_);
    $unsorted
        ? return          _complement_engine(_argument_checker_3($argref))
        : return [ sort @{_complement_engine(_argument_checker_3($argref))} ];
}

sub get_complement_all {
    my ($argref, $unsorted) = _alt_construct_tester_3(@_);
    return _complement_all_engine(_argument_checker_3a($argref), $unsorted);
}

sub _complement_engine {
    my $tested = pop(@_);
    my $seenrefsref = _calc_seen1(@_);
    my ($unionref, $seenref) = _calculate_union_seen_only($seenrefsref);

    # Calculate %xcomplement
    # Inputs:  $seenrefsref @union (keys %$unionref)
    my (%xcomplement);
    for (my $i = 0; $i <= $#{$seenrefsref}; $i++) {
        my @complementthis = ();
        foreach my $k (keys %{$unionref}) {
            push(@complementthis, $k) unless (exists $seenref->{$i}->{$k});
        }
        $xcomplement{$i} = \@complementthis;
    }
    return [ @{$xcomplement{$tested}} ];
}

sub get_symmetric_difference {
    return @{ get_symmetric_difference_ref(@_) };
}

sub get_symmetric_difference_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _symmetric_difference_engine(_argument_checker($argref))
        : return [ sort @{_symmetric_difference_engine(_argument_checker($argref))} ];
}

sub _symmetric_difference_engine {
    #  Get those items which do not appear in more than one of several lists (their symmetric_difference);
    my $seenrefsref = _calc_seen1(@_);

    my $unionref = _calculate_union_only($seenrefsref);

    my $sharedref = _calculate_sharedref($seenrefsref);

    my (@symmetric_difference);
    for my $k (keys %{$unionref}) {
        push(@symmetric_difference, $k) unless exists $sharedref->{$k};
    }
    return \@symmetric_difference;
}

{
    no warnings 'once';
    *get_symdiff  = \&get_symmetric_difference;
    *get_symdiff_ref  = \&get_symmetric_difference_ref;
}

sub get_shared {
    return @{ get_shared_ref(@_) };
}

sub get_shared_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _shared_engine(_argument_checker($argref))
        : return [ sort @{_shared_engine(_argument_checker($argref))} ];
}

sub _shared_engine {
    my $seenrefsref = _calc_seen1(@_);

    my $sharedref = _calculate_sharedref($seenrefsref);
    return [ keys %{$sharedref} ];
}

sub get_nonintersection {
    return @{ get_nonintersection_ref(@_) };
}

sub get_nonintersection_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _nonintersection_engine(_argument_checker($argref))
        : return [ sort @{_nonintersection_engine(_argument_checker($argref))} ];
}

sub _nonintersection_engine {
    my $seenrefsref = _calc_seen1(@_);
    my $unionref =
        _calculate_union_only($seenrefsref);
    my @vals = sort { scalar(keys(%{$a})) <=> scalar(keys(%{$b})) }
        @{$seenrefsref};
    my %intersection = map { $_ => 1 } keys %{$vals[0]};
    for my $l ( 1..$#vals ) {
        %intersection = map { $_ => 1 }
            grep { exists $intersection{$_} }
            keys %{$vals[$l]};
    }
    # Calculate nonintersection
    # Inputs:  @union (keys %$unionref)    %intersection
    my (@nonintersection);
    for my $k (keys %{$unionref}) {
        push(@nonintersection, $k) unless exists $intersection{$k};
    }
    return \@nonintersection;
}

sub is_LsubsetR {
    my $argref = _alt_construct_tester_4(@_);
    return _is_LsubsetR_engine(_argument_checker_4($argref));
}

sub _is_LsubsetR_engine {
    my $testedref = pop(@_);
    my $xsubsetref = _subset_engine(@_);
    return ${$xsubsetref}[${$testedref}[0]][${$testedref}[1]];
}

sub is_RsubsetL {
    my $argref = _alt_construct_tester_4(@_);
    return _is_RsubsetL_engine(_argument_checker_4($argref));
}

sub _is_RsubsetL_engine {
    my $testedref = pop(@_);
    my $xsubsetref = _subset_engine(@_);
    return ${$xsubsetref}[${$testedref}[1]][${$testedref}[0]];
}

sub _subset_engine {
    my $seenrefsref = _calc_seen1(@_);
    my $xsubsetref = _subset_subengine($seenrefsref);
    return $xsubsetref;
}

sub is_LequivalentR {
    my $argref = _alt_construct_tester_4(@_);
    return _is_LequivalentR_engine(_argument_checker_4($argref));
}

{ no warnings 'once'; *is_LeqvlntR = \&is_LequivalentR; }

sub _is_LequivalentR_engine {
    my $testedref = pop(@_);
    my $seenrefsref = _calc_seen1(@_);
    my $xequivalentref = _equivalent_subengine($seenrefsref);
    return ${$xequivalentref}[${$testedref}[1]][${$testedref}[0]];
}

sub is_LdisjointR {
    my $argref = _alt_construct_tester_4(@_);
    return _is_LdisjointR_engine(_argument_checker_4($argref));
}

sub _is_LdisjointR_engine {
    my $testedref = pop(@_);
    my $seenrefsref = _calc_seen1(@_);
    my $disjoint = 1; # start out assuming disjoint status
    OUTER: for my $k (keys %{$seenrefsref->[$testedref->[0]]}) {
        if ($seenrefsref->[$testedref->[1]]->{$k}) {
            $disjoint = 0;
            last OUTER;
        }
    }
    return $disjoint;
}

sub print_subset_chart {
    my $argref = _alt_construct_tester_5(@_);
    _print_subset_chart_engine(_argument_checker($argref));
}

sub _print_subset_chart_engine {
    my $seenrefsref = _calc_seen1(@_);
    my $xsubsetref = _subset_subengine($seenrefsref);
    my $title = 'Subset';
    _chart_engine_multiple($xsubsetref, $title);
}

sub print_equivalence_chart {
    my $argref = _alt_construct_tester_5(@_);
    _print_equivalence_chart_engine(_argument_checker($argref));
}

sub _print_equivalence_chart_engine {
    my $seenrefsref = _calc_seen1(@_);
    my $xequivalentref = _equivalent_subengine($seenrefsref);
    my $title = 'Equivalence';
    _chart_engine_multiple($xequivalentref, $title);
}

sub is_member_which {
    return @{ is_member_which_ref(@_) };
}

sub is_member_which_ref {
    my $argref = _alt_construct_tester_1(@_);
    return _is_member_which_engine(_argument_checker_1($argref));
}

sub _is_member_which_engine {
    my $arg = pop(@_);
    my $seenrefsref = _calc_seen1(@_);
    my $seenref = _calculate_seen_only($seenrefsref);
    my (@found);
    foreach (sort keys %{$seenref}) {
        push @found, $_ if (exists ${$seenref}{$_}{$arg});
    }
    return \@found;
}

sub is_member_any {
    my $argref = _alt_construct_tester_1(@_);
    return _is_member_any_engine(_argument_checker_1($argref));
}

sub _is_member_any_engine {
    my $tested = pop(@_);
    my $seenrefsref = _calc_seen1(@_);
    my $seenref = _calculate_seen_only($seenrefsref);
    my ($k);
    while ( $k = each %{$seenref} ) {
        return 1 if (defined ${$seenref}{$k}{$tested});
    }
    return 0;
}

sub are_members_which {
    my $argref = _alt_construct_tester_2(@_);
    return _are_members_which_engine(_argument_checker_2($argref));
}

sub _are_members_which_engine {
    my $testedref = pop(@_);
    my @tested = @{$testedref};
    my $seenrefsref = _calc_seen1(@_);
    my $seenref = _calculate_seen_only($seenrefsref);
    my (%found);
    for (my $i=0; $i<=$#tested; $i++) {
        my (@not_found);
        foreach (sort keys %{$seenref}) {
            exists ${${$seenref}{$_}}{$tested[$i]}
                ? push @{$found{$tested[$i]}}, $_
                : push @not_found, $_;
        }
        $found{$tested[$i]} = [] if (@not_found == keys %{$seenref});
    }
    return \%found;
}

sub are_members_any {
    my $argref = _alt_construct_tester_2(@_);
    return _are_members_any_engine(_argument_checker_2($argref));
}

sub _are_members_any_engine {
    my $testedref = pop(@_);
    my @tested = @{$testedref};
    my $seenrefsref = _calc_seen1(@_);
    my $seenref = _calculate_seen_only($seenrefsref);
    my (%present);
    for (my $i=0; $i<=$#tested; $i++) {
        foreach (keys %{$seenref}) {
            unless (defined $present{$tested[$i]}) {
                $present{$tested[$i]} = 1 if ${$seenref}{$_}{$tested[$i]};
            }
        }
        $present{$tested[$i]} = 0 if (! defined $present{$tested[$i]});
    }
    return \%present;
}

sub get_bag {
    return @{ get_bag_ref(@_) };
}

sub get_bag_ref {
    my ($argref, $unsorted) = _alt_construct_tester(@_);
    $unsorted
        ? return          _bag_engine(_argument_checker($argref))
        : return [ sort @{_bag_engine(_argument_checker($argref))} ];
}

sub _bag_engine {
    my @listrefs = @_;
    my (@bag);
    if (ref($listrefs[0]) eq 'ARRAY') {
        foreach my $lref (@listrefs) {
            foreach my $el (@{$lref}) {
                push(@bag, $el);
            }
        }
    } else {
        foreach my $lref (@listrefs) {
            foreach my $key (keys %{$lref}) {
                for (my $j=1; $j <= ${$lref}{$key}; $j++) {
                    push(@bag, $key);
                }
            }
        }
    }
    return \@bag;
}

sub get_version {
    return $List::Compare::Functional::VERSION;
}

1;

__END__