File Coverage

blib/lib/Math/Disarrange/List.pm
Criterion Covered Total %
statement 34 34 100.0
branch 6 6 100.0
condition n/a
subroutine 6 6 100.0
pod 0 1 0.0
total 46 47 97.8


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