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 |