derangements

Figures out the derangements for an arbitary length of n. A derangement is a word of numbers where the number does not appear in its numbered column. i.e. you cannot have 1234, 3214 but 4321 and 3421 is acceptable. The combinations sub is barrowed from here.

$length = 5; #Set to the size of derangment
my @results = &combinations(1..$length);

$comb = 0;
foreach (@results) {
    $found = 0;
    foreach my $num (1..$length){
        if(@$_[$num-1] == $num) {$found = 1;} #If true then not a dera
+ngement
    }
    if($found == 0) {print "@$_\n";$comb++;}
}
print "Number of derangements: $comb\n";

sub combinations {
  my @array = @_;
  if ($#array == 0) {return [ $array[0] ]; }
  my @results;
  my $element;
  foreach $element (0..$#array) {
    my @leftovers = @array;
    my $chosen_one = splice(@leftovers, $element, 1);
    foreach (&combinations(@leftovers)) {
      push(@results, [ $chosen_one, @{$_} ]);
    }
  }
  return @results;
}
[download]

Comment on derangements Download Code

Replies are listed 'Best First'.
Re: derangements by BrowserUk (Patriarch) on Apr 26, 2003 at 05:47 UTC
Couldn't resist having a go at something that fits my way of thinking:) `#! perl -slw use strict; our $orig; sub deranged{ my ( $ary, $ref, $n ) = @_; ($orig ^ $$ref) !~ m[\0] and push( @$ary, $$ref ) , return unless +--$n; deranged( $ary, $ref, $n ) , $$ref =~ s[^(.{ $n })(.)(.*?)$][$2$1$ +3] for 0 .. $n; $ary; } $orig = $ARGV[0]; my $ary = deranged( [], \$ARGV[0], length $ARGV[0] ); print $_ for @$ary;` [download] Examine what is said, not who speaks. 1) When a distinguished but elderly scientist states that something is possible, he is almost certainly right. When he states that something is impossible, he is very probably wrong. 2) The only way of discovering the limits of the possible is to venture a little way past them into the impossible 3) Any sufficiently advanced technology is indistinguishable from magic. Arthur C. Clarke.	[reply] [d/l]
Re: derangements by hv (Prior) on Apr 26, 2003 at 04:32 UTC
You're handling the input as an array, which is fine, but if you take a string of characters instead it can be useful to know that there is a neat trick to check whether `$derange` is a derangement of `$string`: `if (($derange ^ $string) !~ /\0/) { print "'$derange' is a derangement\n"; }` [download] I suspect there is a way to solve the complete problem for strings using a single `s///` substitution to generate the "next" permutation (starting with a Unicodabetically-sorted string), but I don't see an easy way to do it off the top of my head - you need to replace the character preceding the longest reverse-sorted trailing substring with the next available character and sort what's left, which sounds likely to involve some fairly ugly `(??{...})` code. Hugo	[reply] [d/l] [select]
Re: derangements by thealienz1 (Pilgrim) on Apr 26, 2003 at 06:41 UTC
My one question is how do you guys do this? I have no idea how you guys/gals see this in your head, and right a reg exp. :) Always more to learn. There are things that may come, and things that may leave, but all in all, we are still looking for the magical mushroom goats.	[reply]


Think about Loose Coupling
	PerlMonks