| File: | blib/lib/Math/Permute/Array.pm |
| Coverage: | 100.0% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Math::Permute::Array; | ||||||
| 2 | |||||||
| 3 | 6 6 6 | 274249 9 167 | use strict; | ||||
| 4 | 6 6 6 | 21 13 5765 | use warnings; | ||||
| 5 | |||||||
| 6 | require Exporter; | ||||||
| 7 | |||||||
| 8 | our @ISA = qw(Exporter); | ||||||
| 9 | |||||||
| 10 | # Items to export into callers namespace by default. Note: do not export | ||||||
| 11 | # names by default without a very good reason. Use EXPORT_OK instead. | ||||||
| 12 | # Do not simply export all your public functions/methods/constants. | ||||||
| 13 | |||||||
| 14 | # This allows declaration use Math::Permute::Array ':all'; | ||||||
| 15 | # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | ||||||
| 16 | # will save memory. | ||||||
| 17 | our %EXPORT_TAGS = ( 'all' => [ qw()], | ||||||
| 18 | 'Permute' => [ qw(Permute) ], | ||||||
| 19 | 'Apply_on_perms' => [ qw(Apply_on_perms) ] | ||||||
| 20 | ); | ||||||
| 21 | |||||||
| 22 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | ||||||
| 23 | |||||||
| 24 | our @EXPORT = qw( | ||||||
| 25 | Permute | ||||||
| 26 | Apply_on_perms | ||||||
| 27 | ); | ||||||
| 28 | |||||||
| 29 | our $VERSION = '0.0421'; | ||||||
| 30 | |||||||
| 31 | |||||||
| 32 | sub new | ||||||
| 33 | { | ||||||
| 34 | 4 | 1 | 444926 | my $class = shift; | |||
| 35 | 4 | 14 | my $self = {}; | ||||
| 36 | 4 | 10 | $self->{array} = shift; | ||||
| 37 | 4 | 7 | $self->{iterator} = 0; | ||||
| 38 | 4 | 6 | $self->{cardinal} = undef; | ||||
| 39 | 4 | 33 | bless($self, $class); | ||||
| 40 | 4 | 24 | return undef unless (defined $self->{array}); | ||||
| 41 | 3 | 22 | return $self; | ||||
| 42 | } | ||||||
| 43 | |||||||
| 44 | #nice implementation from the cookbook | ||||||
| 45 | #but mine seems lightly more efficient | ||||||
| 46 | #sub N2Permute | ||||||
| 47 | #{ | ||||||
| 48 | # my $rank = shift; | ||||||
| 49 | # my $size = shift; | ||||||
| 50 | # my @res; | ||||||
| 51 | # | ||||||
| 52 | # my $i=1; | ||||||
| 53 | # while($i<=$size){ | ||||||
| 54 | # push @res, $rank % ($i); | ||||||
| 55 | # $rank = int($rank / ($i)); | ||||||
| 56 | # $i++; | ||||||
| 57 | # } | ||||||
| 58 | # return @res; | ||||||
| 59 | #} | ||||||
| 60 | |||||||
| 61 | sub Permute | ||||||
| 62 | { | ||||||
| 63 | 80643 | 1 | 77673 | my $rest = shift; | |||
| 64 | 80643 | 67399 | my $array = shift; | ||||
| 65 | 80643 | 405380 | return undef unless (defined $rest and defined $array); | ||||
| 66 | 80640 80640 | 66775 182789 | my @array = @{$array}; | ||||
| 67 | 80640 | 86656 | my @res; | ||||
| 68 | |||||||
| 69 | # my $size = $#$array+1; | ||||||
| 70 | # my @perm = N2Permute($k,$size); | ||||||
| 71 | #push @res, splice(@array, (pop @perm), 1 )while @perm; | ||||||
| 72 | |||||||
| 73 | 80640 | 70271 | my $i = 0; | ||||
| 74 | 80640 | 120932 | while($rest != 0){ | ||||
| 75 | 506558 | 742141 | $res[$i] = splice @array, $rest % ($#array + 1), 1; | ||||
| 76 | 506558 | 561672 | $rest = int($rest / ($#array + 2)); | ||||
| 77 | 506558 | 698586 | $i++; | ||||
| 78 | } | ||||||
| 79 | 80640 | 105564 | push @res, @array; | ||||
| 80 | |||||||
| 81 | 80640 | 676811 | return \@res; | ||||
| 82 | } | ||||||
| 83 | |||||||
| 84 | sub permutation | ||||||
| 85 | { | ||||||
| 86 | 7 | 1 | 217 | my $self = shift; | |||
| 87 | 7 | 8 | my $rest = shift; | ||||
| 88 | 7 | 17 | return undef unless (defined $rest); | ||||
| 89 | 6 6 | 7 19 | my @array = @{$self->{array}}; | ||||
| 90 | 6 | 7 | my @res; | ||||
| 91 | 6 | 3 | my $i = 0; | ||||
| 92 | 6 | 11 | while($rest != 0){ | ||||
| 93 | 8 | 16 | $res[$i] = splice @array, $rest % ($#array + 1), 1; | ||||
| 94 | 8 | 10 | $rest = int($rest / ($#array + 2)); | ||||
| 95 | 8 | 15 | $i++; | ||||
| 96 | } | ||||||
| 97 | 6 | 7 | push @res, @array; | ||||
| 98 | 6 | 100 | return \@res; | ||||
| 99 | } | ||||||
| 100 | |||||||
| 101 | sub Apply_on_perms(&@) | ||||||
| 102 | { | ||||||
| 103 | 4 | 1 | 150460 | my $func = shift; | |||
| 104 | 4 | 4 | my $array = shift; | ||||
| 105 | 4 | 44 | return undef unless (defined $func and defined $array); | ||||
| 106 | 1 | 1 | my $rest; | ||||
| 107 | 1 | 1 | my $i; | ||||
| 108 | 1 | 1 | my $j; | ||||
| 109 | 1 1 | 1 3 | my @array = @{$array}; | ||||
| 110 | 1 | 2 | my $size = $#array+1; | ||||
| 111 | 1 | 2 | my $card = factorial($size); | ||||
| 112 | 1 | 1 | my @res; | ||||
| 113 | for($j=0;$j<$card;$j++){ | ||||||
| 114 | 40320 | 39305 | @res = (); | ||||
| 115 | 40320 | 33021 | $rest = $j; | ||||
| 116 | 40320 | 31398 | $i = 0; | ||||
| 117 | 40320 | 57935 | while($rest != 0){ | ||||
| 118 | 253279 | 314229 | $res[$i] = splice @array, $rest % ($#array + 1), 1; | ||||
| 119 | 253279 | 274728 | $rest = int($rest / ($#array + 2)); | ||||
| 120 | 253279 | 351172 | $i++; | ||||
| 121 | } | ||||||
| 122 | 40320 | 38548 | push @res, @array; | ||||
| 123 | 40320 | 264765 | &$func(@res); | ||||
| 124 | 40320 40320 | 1167044 137007 | @array = @{$array}; | ||||
| 125 | 1 | 1 | } | ||||
| 126 | 1 | 9 | return 0; | ||||
| 127 | } | ||||||
| 128 | |||||||
| 129 | sub cur | ||||||
| 130 | { | ||||||
| 131 | 2 | 1 | 65 | my $self = shift; | |||
| 132 | 2 | 6 | return Math::Permute::Array::Permute($self->{iterator},$self->{array}); | ||||
| 133 | } | ||||||
| 134 | |||||||
| 135 | sub prev | ||||||
| 136 | { | ||||||
| 137 | 40320 | 1 | 1177760 | my $self = shift; | |||
| 138 | 40320 | 75572 | return undef if($self->{iterator} == 0); | ||||
| 139 | 40319 | 35328 | $self->{iterator}--; | ||||
| 140 | 40319 | 61674 | return Math::Permute::Array::Permute($self->{iterator},$self->{array}); | ||||
| 141 | } | ||||||
| 142 | |||||||
| 143 | sub next | ||||||
| 144 | { | ||||||
| 145 | 40320 | 1 | 1166829 | my $self = shift; | |||
| 146 | 40320 | 68646 | return undef if($self->{iterator} >= $self->cardinal() - 1); | ||||
| 147 | 40319 | 36528 | $self->{iterator}++; | ||||
| 148 | 40319 | 58381 | return Math::Permute::Array::Permute($self->{iterator},$self->{array}); | ||||
| 149 | } | ||||||
| 150 | |||||||
| 151 | sub cardinal | ||||||
| 152 | { | ||||||
| 153 | 40322 | 1 | 35869 | my $self = shift; | |||
| 154 | 40322 | 70010 | unless(defined $self->{cardinal}){ | ||||
| 155 | 2 2 | 3 14 | $self->{cardinal} = factorial($#{$self->{array}} + 1); | ||||
| 156 | } | ||||||
| 157 | 40322 | 87294 | return $self->{cardinal}; | ||||
| 158 | } | ||||||
| 159 | |||||||
| 160 | #this part come from: | ||||||
| 161 | # www.theperlreview.com/SamplePages/ThePerlReview-v5i1.p23.pdf | ||||||
| 162 | # Author: Alberto Manuel Simoes | ||||||
| 163 | sub factorial | ||||||
| 164 | { | ||||||
| 165 | 3 | 1 | 5 | my $value = shift; | |||
| 166 | 3 | 4 | my $res = 1; | ||||
| 167 | 3 | 9 | while ($value > 1) { | ||||
| 168 | 16 | 17 | $res *= $value; | ||||
| 169 | 16 | 21 | $value--; | ||||
| 170 | } | ||||||
| 171 | 3 | 6 | return $res; | ||||
| 172 | } | ||||||
| 173 | |||||||
| 174 | 1; | ||||||
| 175 | |||||||