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

Annotation of /FigKernelPackages/gjolists.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download) (as text)

1 : golsen 1.1 package gjolists;
2 :    
3 :     # Invoke with:
4 :     #
5 :     # use gjolists;
6 :     #
7 :     # List comparisons:
8 :     #
9 :     # @common = common_prefix( \@list1, \@list2 )
10 :     # @common = common_prefix_n( \@list1, \@list2, ... )
11 :     # ( \@pref, \@suf1, \@suf2 ) = common_and_unique( \@list1, \@list2 )
12 :     # ( \@suf1, \@suf2 ) = unique_suffixes( \@list1, \@list2 )
13 :     #
14 :     # List properties:
15 :     #
16 :     # @unique = unique_set( @list ) # Reduce a list to a set
17 :     # @dups = duplicates( @list )
18 :     #
19 :     # @random = random_order( @list )
20 :     #
21 :     # Set algebra:
22 :     #
23 :     # @A_or_B = union( \@list1, \@list2, ... )
24 :     # @A_and_B = intersection( \@list1, \@list2, ... )
25 :     # @A_not_B = set_difference( \@list1, \@list2 )
26 :    
27 :     require Exporter;
28 :    
29 :     our @ISA = qw(Exporter);
30 :     our @EXPORT_OK = qw(
31 :     common_prefix
32 :     common_prefix_n
33 :     common_and_unique
34 :     unique_suffixes
35 :    
36 :     unique_set
37 :     duplicates
38 :     random_order
39 :    
40 :     union
41 :     intersection
42 :     set_difference
43 :     );
44 :    
45 :     use strict;
46 :    
47 :    
48 :     #-----------------------------------------------------------------------------
49 :     # Return the common prefix of two lists:
50 :     #
51 :     # @common = common_prefix( \@list1, \@list2 )
52 :     #-----------------------------------------------------------------------------
53 :     sub common_prefix {
54 :     my ($l1, $l2) = @_;
55 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
56 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
57 :     my $i = 0;
58 :     my $l1_i;
59 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
60 :    
61 :     return @$l1[ 0 .. ($i-1) ]; # perl handles negative range
62 :     }
63 :    
64 :    
65 :     #-----------------------------------------------------------------------------
66 :     # Return the common prefix of two or more lists:
67 :     #
68 :     # @common = common_prefix_n( \@list1, \@list2, ... )
69 :     #-----------------------------------------------------------------------------
70 :     sub common_prefix_n {
71 :     my $n = @_;
72 :     $n > 1 || die "common_prefix: requires 2 or more arguments\n";
73 :     for (my $j = 1; $j <= $n; $j++) {
74 :     ref($_[$j-1]) eq "ARRAY" || die "common_prefix_n: arg $j is not an array ref\n";
75 :     }
76 :    
77 :     my $l0 = $_[0];
78 :     my $l0_i;
79 :     my $i;
80 :     for ( $i = 0; defined( $l0_i = $l0->[$i] ); $i++ ) {
81 :     for ( my $j = 1; $j < $n; $j++ ) {
82 :     $l0_i eq $_[$j]->[$i] || ( return @$l0[0 .. ($i-1)] )
83 :     }
84 :     }
85 :    
86 :     return @$l0[ 0 .. ($i-1) ]; # perl handles negative range
87 :     }
88 :    
89 :    
90 :     #-----------------------------------------------------------------------------
91 :     # Return the common prefix and unique suffixes of each of two lists:
92 :     #
93 :     # ( \@prefix, \@suffix1, \@suffix2 ) = common_and_unique( \@list1, \@list2 )
94 :     #-----------------------------------------------------------------------------
95 :     sub common_and_unique {
96 :     my ($l1, $l2) = @_;
97 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
98 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
99 :     my $i = 0;
100 :     my $l1_i;
101 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
102 :    
103 :     my $len1 = @$l1;
104 :     my $len2 = @$l2;
105 :     return ( [ @$l1[ 0 .. $i-1 ] ] # perl handles negative range
106 :     , [ @$l1[ $i .. $len1-1 ] ]
107 :     , [ @$l2[ $i .. $len2-1 ] ]
108 :     );
109 :     }
110 :    
111 :    
112 :     #-----------------------------------------------------------------------------
113 :     # Return the unique suffixes of each of two lists:
114 :     #
115 :     # ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )
116 :     #-----------------------------------------------------------------------------
117 :     sub unique_suffixes {
118 :     my ($l1, $l2) = @_;
119 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
120 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
121 :     my $i = 0;
122 :     my $l1_i;
123 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
124 :    
125 :     my $len1 = @$l1;
126 :     my $len2 = @$l2;
127 :     return ( [ @$l1[ $i .. $len1-1 ] ] # perl handles negative range
128 :     , [ @$l2[ $i .. $len2-1 ] ]
129 :     );
130 :     }
131 :    
132 :    
133 :     #-----------------------------------------------------------------------------
134 :     # Reduce a list to its unique elements (stable in order):
135 :     #
136 :     # @unique = unique_set( @list )
137 :     #-----------------------------------------------------------------------------
138 :     sub unique_set {
139 :     my %cnt = ();
140 :     map { ( $cnt{$_} = $cnt{$_} ? $cnt{$_}+1 : 1 ) == 1 ? $_ : () } @_;
141 :     }
142 :    
143 :    
144 :     #-------------------------------------------------------------------------------
145 :     # List of values duplicated in a list (stable in order by second occurance):
146 :     #
147 :     # @dups = duplicates( @list )
148 :     #-------------------------------------------------------------------------------
149 : golsen 1.2 sub duplicates
150 :     {
151 : golsen 1.1 my %cnt = ();
152 : golsen 1.2 grep { ++$cnt{$_} == 2 } @_;
153 : golsen 1.1 }
154 :    
155 :    
156 :     #-------------------------------------------------------------------------------
157 :     # Randomize the order of a list:
158 :     #
159 :     # @random = random_order( @list )
160 :     #-------------------------------------------------------------------------------
161 :     sub random_order {
162 :     my ( $i, $j );
163 :     for ( $i = @_ - 1; $i > 0; $i-- ) {
164 :     $j = int( ($i+1) * rand() );
165 :     ( $_[$i], $_[$j] ) = ( $_[$j], $_[$i] );
166 :     }
167 :    
168 :     @_
169 :     }
170 :    
171 :    
172 :     #-----------------------------------------------------------------------------
173 :     # Union of two or more sets (by reference):
174 :     #
175 :     # @union = union( \@set1, \@set2, ... )
176 :     #-----------------------------------------------------------------------------
177 : golsen 1.2 sub union
178 :     {
179 : golsen 1.1 my %cnt = ();
180 : golsen 1.2 grep { ++$cnt{$_} == 1 } map { @$_ } @_;
181 : golsen 1.1 }
182 :    
183 :    
184 :     #-----------------------------------------------------------------------------
185 :     # Intersection of two or more sets:
186 :     #
187 :     # @intersection = intersection( \@set1, \@set2, ... )
188 :     #-----------------------------------------------------------------------------
189 : golsen 1.2 sub intersection
190 :     {
191 : golsen 1.1 my $set = shift;
192 : golsen 1.2 my @intersection = @$set;
193 : golsen 1.1
194 : golsen 1.2 foreach $set ( @_ )
195 :     {
196 :     my %set = map { ( $_ => 1 ) } @$set;
197 :     @intersection = grep { exists $set{ $_ } } @intersection;
198 : golsen 1.1 }
199 : golsen 1.2
200 :     @intersection;
201 : golsen 1.1 }
202 :    
203 :    
204 :     #-----------------------------------------------------------------------------
205 :     # Elements in set 1, but not set 2:
206 :     #
207 :     # @difference = set_difference( \@set1, \@set2 )
208 :     #-----------------------------------------------------------------------------
209 : golsen 1.2 sub set_difference
210 :     {
211 : golsen 1.1 my ($set1, $set2) = @_;
212 : golsen 1.2 my %set2 = map { ( $_ => 1 ) } @$set2;
213 :     grep { ! ( exists $set2{$_} ) } @$set1;
214 : golsen 1.1 }
215 :    
216 :    
217 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3