Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister

Re^4: Derangements iterator (order)

by tye (Sage)
on Jan 02, 2006 at 20:42 UTC ( #520452=note: print w/ replies, xml ) Need Help??

in reply to Re^3: Derangements iterator (others)
in thread Derangements iterator

Thanks for the explanation.

The current interface guarantees lexicographic order

It is easy to adjust my iterator to get lexicographic order. For example, just add one reverse:

$left= [ @$left, reverse @{$redo[$i]} ];

I plan to add a version to Algorithm::Loops before I die. (:

- tye        

Replies are listed 'Best First'.
Re^5: Derangements iterator (NestedLoops implementation)
by Roy Johnson (Monsignor) on Jan 04, 2006 at 16:57 UTC
    Here's a version you can add to Algorithm::Loops. It uses NestedLoops and is comparatively efficient about skipping invalid combinations. It also puts its results in numeric/lexicographic order and handles duplicates. The commented-out code is for watching/debugging the management of the "pool" of available numbers.
    use strict; use warnings; use Algorithm::Loops 'NestedLoops'; sub derange { # Generate the list of possible values at each position # Skip a value if it's already used up (no more in the pool) or is i +n its original position my %pool; ++$pool{$_} for (@_); my @orig = @_; no warnings 'numeric'; my @values = sort {$a <=> $b or $a cmp $b} keys %pool; my @prev_values; NestedLoops( [(sub { # Generate all candidate values for this position # print "Generating with \@_ = @_\n"; my $pos = @_; # Update the pool: the last value on @_ has just changed, so # return the previous value(s) to the pool and remove the new # one. if (@_) { for (grep {defined $prev_values[$_]} $#_..$#orig-1) { #print "Returning $prev_values[$_] to the pool\n"; ++$pool{$prev_values[$_]}; undef $prev_values[$_]; } #print "Removing $_[-1] from the pool\n"; --$pool{$_[-1]}; #print "Valid values in the pool:\n"; #while (my ($k,$v) = each %pool) { # print "$k: $v\n" if $v; #} $prev_values[$#_] = $_[-1]; } [ grep {$orig[$pos] ne $_ and $pool{$_} > 0} @values ] }) x @orig] ); } my @results; my $iter = derange(@ARGV); print "@results\n" while @results = $iter->();
    As a possibly interesting note: if you simply remove $orig[$pos] ne $_ and, it becomes a permutations generator. But derange is not simply a permutations generator that filters out individual invalid permutations; it prunes entire sub-trees. (Similarly, the permutation generator doesn't loop through the whole cartesian space and filter it.)

    Caution: Contents may have been coded under pressure.

Log In?

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

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (5)
As of 2016-08-27 12:06 GMT
Find Nodes?
    Voting Booth?
    The best thing I ever won in a lottery was:

    Results (380 votes). Check out past polls.