1package mix_tests; 2 3use strict; 4use warnings; 5use vars qw(@EXPORT @EXPORT_OK @ISA); 6 7use Exporter; 8 9@ISA = qw(Exporter); 10@EXPORT = qw(variegate_list combine_list combine_nk totalcombs); 11@EXPORT_OK = @EXPORT; 12 13sub variegate_list($@); 14sub combine_list($@); 15 16sub variegate_list($@) { 17 my ($amount, @items) = @_; 18 my @result; 19 20 $amount == 1 and return map { [ $_ ] } @items; 21 22 foreach my $idx ( 0 .. $#items ) { 23 my @copy = @items; 24 my @round_item = splice( @copy, $idx, 1 ); 25 my @round_list = variegate_list( $amount - 1, @copy ); 26 foreach my $sublist (@round_list) { 27 push( @result, [ @round_item, @{$sublist} ] ); 28 } 29 } 30 31 return @result; 32} 33 34sub totalcombs($$){ 35 my ($n, $k) = @_; 36 my $c = 1; 37 $k > $n and return 0; 38 for my $d ( 1 .. $k ) { 39 $c *= $n--; 40 $c /= $d; 41 $c = int($c); 42 } 43 return $c; 44} 45 46sub combine_nk($$) { 47 my ($n, $k) = @_; 48 my @indx; 49 my @result; 50 51 @indx = map { $_ } ( 0 .. $k - 1 ); 52 53LOOP: 54 while( 1 ) { 55 my @line = map { $indx[$_] } ( 0 .. $k - 1 ); 56 push( @result, \@line ) if @line; 57 for( my $iwk = $k - 1; $iwk >= 0; --$iwk ) { 58 if( $indx[$iwk] <= ($n-1)-($k-$iwk) ) { 59 ++$indx[$iwk]; 60 for my $swk ( $iwk + 1 .. $k - 1 ) { 61 $indx[$swk] = $indx[$swk-1]+1; 62 } 63 next LOOP; 64 } 65 } 66 last; 67 } 68 69 return @result; 70} 71 72sub combine_list($@) { 73 my ($amount, @items) = @_; 74 my @result; 75 76 $amount == 1 and return map { [ $_ ] } @items; 77 78 foreach my $idx ( 0 .. $#items ) { 79 my @copy = @items; 80 my @round_item = splice( @copy, $idx, 1 ); 81 my @round_list = combine_list( $amount - 1, @copy ); 82 foreach my $sublist (@round_list) { 83 push( @result, [ @round_item, @{$sublist} ] ); 84 } 85 } 86 87 my @sorted = map { [ sort { $a <=> $b } @{$_} ] } @result; 88 my %uniq_sorted; 89 foreach my $si (@sorted) { 90 my $si_key = join(",", @{$si}); 91 $uniq_sorted{$si_key} = $si; 92 } 93 @result = values(%uniq_sorted); 94 95 return @result; 96} 97 981; 99