Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

derangements

by thealienz1 (Pilgrim)
on Apr 25, 2003 at 03:19 UTC ( #253056=snippet: print w/replies, xml ) Need Help??
Description: 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;
}
Replies are listed 'Best First'.
Re: derangements
by BrowserUk (Pope) 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;

    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.
Re: derangements
by hv (Parson) 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"; }

    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
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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://253056]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (7)
As of 2019-10-22 13:27 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Notices?