File Coverage

blib/lib/Math/Disarrange/List.pm
Criterion Covered Total %
statement 29 29 100.0
branch 6 6 100.0
condition n/a
subroutine 4 4 100.0
pod 0 1 0.0
total 39 40 97.5


line stmt bran cond sub pod time code
1             =head1 Name
2              
3             Math::Disarrange::List - Generate all the disarrangements of a list.
4              
5             =head1 Synopsis
6              
7             use Math::Disarrange::List;
8              
9             disarrange {say "@_"} qw(a b c);
10              
11             # c a b
12             # b c a
13              
14             =cut
15              
16 10     10   269964 use strict;
  10         22  
  10         30074  
17              
18             package Math::Disarrange::List;
19              
20 10     10 0 168 sub disarrange(&@) # Generate all the disarrangements of a list
21             {my $s = shift; # Subroutine to call to process each disarrangement
22              
23 10         29 my $n = scalar(@_); # Size of array to be disarranged
24             # return 0 if $n < 2; # Require at least two elements to disarrange - per Philipp Rumpf
25 10         20 my $m = 0; # Number of disarrangements
26 10         23 my $l = 0; # Item being disarranged
27 10         27 my @p = (); # Current disarrangements
28 10         30 my @P = @_; # Array to disarrange
29 10         100 my @Q = (); # Disarranged array
30              
31 10 100       23 my $p; $p = sub # Generate each disarrangement
  26778165         36308601  
32 4012921 100   4012921   4655290 {if ($l < $n)
33 2677898         2977119 {for(0..$n-1)
  1335023         1943902  
34             {next if $l == $_;
35 24100268 100       34574841 if (!$p[$_])
  4012911         3372060  
36             {$Q[$_] = $P[$l];
37 4012911         3046663 $p[$_] = ++$l;
38 4012911         4333897 &$p();
39 4012909         3197306 --$l;
40 4012909         4283071 $p[$_] = 0;
41             }
42             }
43             }
44             else
45 1335022         2450949 {&$s(@Q); ++$m;
46             }
47 10         69 };
48              
49 10         50 &$p;
50 9         19 $p = undef; # Break memory loop per Philipp Rumpf
51 9         242 $m
52             }
53              
54             # Export details
55            
56             require 5;
57             require Exporter;
58              
59 10     10   82 use vars qw(@ISA @EXPORT $VERSION);
  10         14  
  10         3251  
60              
61             @ISA = qw(Exporter);
62             @EXPORT = qw(disarrange);
63             $VERSION = '1.005'; # Monday 26 Jan 2015
64              
65             =head1 Description
66              
67             Generate and process all the disarrangements of a list using the standard
68             Perl metaphor. A disarrangement is a permutation of the original list in
69             which no element is in its original position.
70              
71             C returns the number of disarrangements in both scalar and
72             array context.
73              
74             C is easy to use and fast. It is written in 100% Pure Perl.
75              
76             Please note that the order in which the disarrangements are generated is not
77             guaranteed, so please do not rely on it.
78              
79             =head1 Export
80              
81             The C function is exported.
82              
83             =head1 Installation
84              
85             Standard Module::Build process for building and installing modules:
86              
87             perl Build.PL
88             ./Build
89             ./Build test
90             ./Build install
91              
92             Or, if you're on a platform (like DOS or Windows) that doesn't require the
93             "./" notation, you can do this:
94              
95             perl Build.PL
96             Build
97             Build test
98             Build install
99              
100             =head1 Author
101              
102             PhilipRBrenan@appaapps.com
103              
104             http://www.appappps.com
105              
106             =head1 Acknowledgements
107              
108             With extensive and unfailing advice from Philipp Rumpf to whom I am greatly
109             indebted.
110              
111             =head1 See Also
112              
113             =over
114              
115             =item L
116              
117             =item L
118              
119             =item L
120              
121             =back
122              
123             =head1 Copyright
124              
125             Copyright (c) 2009 Philip R Brenan.
126              
127             This module is free software. It may be used, redistributed and/or modified
128             under the same terms as Perl itself.
129              
130             =cut