[Bio] / FigKernelPackages / gjolists.pm Repository:
ViewVC logotype

View of /FigKernelPackages/gjolists.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (download) (as text) (annotate)
Sun Feb 11 22:41:37 2007 UTC (12 years, 9 months ago) by golsen
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0806, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2011_0928, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24, rast_rel_2008_08_07, HEAD
Changes since 1.1: +19 -35 lines
Updates for cleaner faster code.

package gjolists;

#  Invoke with:
#
#     use gjolists;
#
#  List comparisons:
#
#  @common = common_prefix( \@list1, \@list2 )
#  @common = common_prefix_n( \@list1, \@list2, ... )
#  ( \@pref, \@suf1, \@suf2 ) = common_and_unique( \@list1, \@list2 )
#  ( \@suf1, \@suf2 )         = unique_suffixes( \@list1, \@list2 )
#
#  List properties:
#
#  @unique = unique_set( @list )     #  Reduce a list to a set
#  @dups   = duplicates( @list )
#
#  @random = random_order( @list )
#
#  Set algebra:
#
#  @A_or_B  = union( \@list1, \@list2, ... )
#  @A_and_B = intersection( \@list1, \@list2, ... )
#  @A_not_B = set_difference( \@list1, \@list2 )

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
        common_prefix
        common_prefix_n
        common_and_unique
        unique_suffixes
        
        unique_set
        duplicates
        random_order

        union
        intersection
        set_difference
        );

use strict;


#-----------------------------------------------------------------------------
#  Return the common prefix of two lists:
#
#  @common = common_prefix( \@list1, \@list2 )
#-----------------------------------------------------------------------------
sub common_prefix {
    my ($l1, $l2) = @_;
    ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
    ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
    my $i = 0;
    my $l1_i;
    while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }

    return @$l1[ 0 .. ($i-1) ];  # perl handles negative range
}


#-----------------------------------------------------------------------------
#  Return the common prefix of two or more lists:
#
#  @common = common_prefix_n( \@list1, \@list2, ... )
#-----------------------------------------------------------------------------
sub common_prefix_n {
    my $n = @_;
    $n > 1 || die "common_prefix: requires 2 or more arguments\n";
    for (my $j = 1; $j <= $n; $j++) {
        ref($_[$j-1]) eq "ARRAY" || die "common_prefix_n: arg $j is not an array ref\n";
    }

    my $l0 = $_[0];
    my $l0_i;
    my $i;
    for ( $i = 0; defined( $l0_i = $l0->[$i] ); $i++ ) {
        for ( my $j = 1; $j < $n; $j++ ) {
            $l0_i eq $_[$j]->[$i] || ( return @$l0[0 .. ($i-1)] )
        }
    }

    return @$l0[ 0 .. ($i-1) ];  # perl handles negative range
}


#-----------------------------------------------------------------------------
#  Return the common prefix and unique suffixes of each of two lists:
#
#  ( \@prefix, \@suffix1, \@suffix2 ) = common_and_unique( \@list1, \@list2 )
#-----------------------------------------------------------------------------
sub common_and_unique {
    my ($l1, $l2) = @_;
    ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
    ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
    my $i = 0;
    my $l1_i;
    while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }

    my $len1 = @$l1;
    my $len2 = @$l2;
    return ( [ @$l1[ 0  .. $i-1    ] ]  # perl handles negative range
           , [ @$l1[ $i .. $len1-1 ] ]
           , [ @$l2[ $i .. $len2-1 ] ]
           );
}


#-----------------------------------------------------------------------------
#  Return the unique suffixes of each of two lists:
#
#  ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )
#-----------------------------------------------------------------------------
sub unique_suffixes {
    my ($l1, $l2) = @_;
    ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
    ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
    my $i = 0;
    my $l1_i;
    while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }

    my $len1 = @$l1;
    my $len2 = @$l2;
    return ( [ @$l1[ $i .. $len1-1 ] ]  # perl handles negative range
           , [ @$l2[ $i .. $len2-1 ] ]
           );
}


#-----------------------------------------------------------------------------
#  Reduce a list to its unique elements (stable in order):
#
#  @unique = unique_set( @list )
#-----------------------------------------------------------------------------
sub unique_set {
    my %cnt = ();
    map { ( $cnt{$_} = $cnt{$_} ? $cnt{$_}+1 : 1 ) == 1 ? $_ : () } @_;
}


#-------------------------------------------------------------------------------
#  List of values duplicated in a list (stable in order by second occurance):
#
#  @dups = duplicates( @list )
#-------------------------------------------------------------------------------
sub duplicates
{
    my %cnt = ();
    grep { ++$cnt{$_} == 2 } @_;
}


#-------------------------------------------------------------------------------
#  Randomize the order of a list:
#
#  @random = random_order( @list )
#-------------------------------------------------------------------------------
sub random_order {
    my ( $i, $j );
    for ( $i = @_ - 1; $i > 0; $i-- ) {
        $j = int( ($i+1) * rand() );
        ( $_[$i], $_[$j] ) = ( $_[$j], $_[$i] );
    }

   @_
}


#-----------------------------------------------------------------------------
#  Union of two or more sets (by reference):
#
#  @union = union( \@set1, \@set2, ... )
#-----------------------------------------------------------------------------
sub union
{
    my %cnt = ();
    grep { ++$cnt{$_} == 1 } map { @$_ } @_;
}


#-----------------------------------------------------------------------------
#  Intersection of two or more sets:
#
#  @intersection = intersection( \@set1, \@set2, ... )
#-----------------------------------------------------------------------------
sub intersection
{
    my $set = shift;
    my @intersection = @$set;

    foreach $set ( @_ )
    {
        my %set = map { ( $_ => 1 ) } @$set;
        @intersection = grep { exists $set{ $_ } } @intersection;
    }

    @intersection;
}


#-----------------------------------------------------------------------------
#  Elements in set 1, but not set 2:
#
#  @difference = set_difference( \@set1, \@set2 )
#-----------------------------------------------------------------------------
sub set_difference
{
    my ($set1, $set2) = @_;
    my %set2 = map { ( $_ => 1 ) } @$set2;
    grep { ! ( exists $set2{$_} ) } @$set1;
}


1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3