Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

Derangements iterator

by tye (Cardinal)
on Dec 29, 2005 at 18:05 UTC ( #519815=CUFP: print w/ replies, xml ) Need Help??

This iterator is my 'naive' approach to producing derangements via an iterator (at japhy's prompting so he can produce his "Secret Santa" lists). A derangement is a permutation where none of the elements remained in their starting positions.

#!/usr/bin/perl -w use strict; sub derange { my @set= @_; # items (strings) to be deranged my $last= $#set; # last index into our list my @stack= # lists of indices to be tried at each locatio +n [ reverse 0 .. $last ]; my @redo; # lists of indices already tried at each locat +ion my @ret; # offsets to each selected item my $i= 0; # which slot we are trying to fill my $left= $stack[$i]; # indices to consider for the current slot return sub { while( 1 ) { do { if( ! @$left ) { return if --$i < 0; $left= $stack[$i]; push @{$redo[$i]}, $ret[$i]; } if( @$left && $i == $left->[-1] ) { # skip this index as it'd not make a derangement push @{$redo[$i]}, pop @$left; } } while( ! @$left ); $ret[$i]= pop @$left; if( $i == $last ) { return @set[@ret]; } $left= [ @$left, @{$redo[$i]} ]; $redo[++$i]= []; $stack[$i]= $left; } }; } @ARGV= 1..5 if ! @ARGV; my $iter= derange( @ARGV ); my @list; while( @list= $iter->() ) { print "@list\n"; }

- tye        

Comment on Derangements iterator
Download Code
Re: Derangements iterator
by jdporter (Canon) on Dec 29, 2005 at 18:59 UTC

    I know it's cool to do iterators, but something about derange { print "@_\n" } 1 .. 5; seems more perlish to me...

    sub _derange { my( $cb, $todo, @v ) = @_; @$todo or return $cb->( @v ); my %seen; @seen{@v}=(); my( $range, @todo ) = @$todo; _derange( $cb, \@todo, @v, $_ ) for grep { ! exists $seen{$_} } @$range; } sub derange(&@) { my $cb = shift; _derange( $cb, [ map { my $x = $_; [ grep { $_ ne $x } @_ ] } @_ ] ); }

    Update

    If one needed to allow for deranging a list which contains duplicates, one could simply derange the list of its indices. E.g.:

    my @x = ( 1 .. 4, 4 ); derange { print "@x[@_]\n" } 0 .. $#x;
    We're building the house of the future together.

      I don't care about "cool". I care about "useful". Callbacks are fundamentally inflexible (Re: Are you looking at XML processing the right way? (merge)).

      Note that turning my iterator into your callback interface is trivial:

      sub forDerange(&@) { my $cv= shift @_; my $iter= genDerange( @_ ); my @list; while( @list= $iter->() ) { $cv->( @list ); } }

      Try to go the other way. (:

      - tye        

        Towards the best collection traversal interface
        Most programming languages support collections, represented by an in-memory data structure, a file, a database, or a generating function. A programming language system gives us typically one of the two interfaces to systematically access elements of a collection. One traversal API is based on enumerators -- e.g., for-each, map, filter higher-order procedures -- of which the most general is fold. The second approach relies on streams, a.k.a. cursors, lazy lists. Generators such as the ones in Icon, Ruby and Python are a hybrid approach.

        It is well-known that given a cursor interface to a collection, we can implement an enumerator. It is less appreciated that given an enumerator interface, we can always derive a cursor -- in an automatic way. We demonstrate that generic procedure for languages with and without first-class continuations.

        Now that cursors and enumerators are inter-convertible, an implementor of a collection has a choice: which of the two interfaces to implement natively? We argue that he should offer the enumerator interface as the native one. The paper elaborates that enumerators are superior: in efficiency; in ease of programming; in more predictable resource utilization and avoidance of resource leaks. We present a design of the overall optimal collection traversal interface, which is based on a left-fold-like combinator with premature termination. The design has been implemented and tested in practice.

      Update If one needed to allow for deranging a list which contains duplicates, one could simply derange the list of its indices.

      Um, not really. A derangement algorithm that "doesn't handle duplicates" is one that deranges "1 4 4" into "4 1 4" because it doesn't notice that the duplicates are the same and so doesn't realize that replacing the last 4 with the second 4 didn't actually cause the last item to be different. It also, when deranging "1 1 2 2" returns "2 2 1 1" four times instead of just once because it doesn't realize that reversing "1 1" (nor "2 2") gives the same thing.

      So your first algorithm simply breaks when presented with duplicates (it always finds zero derangements, for those who didn't notice) but your work-around just prevents this breakage while not actually correctly handling the duplicates. (So I'd suggest you document how it doesn't handle duplicates rather than suggest that work-around.)

      Just for fun, here is your algorithm modified to correctly handle duplicates:

      sub _derange { my( $cb, $av, $todo, @i ) = @_; return $cb->( @$av[@i] ) if ! @$todo; my( %iseen, %vseen ); @iseen{@i}= (); @vseen{@$av[@i]}= @i; my( $range, @todo )= @$todo; for( @$range ) { _derange( $cb, $av, \@todo, @i, $_ ) if ! exists $seen{$_} and ! exists $vseen{$av->[$_]} || $vseen{$av->[$_]} < $_; } } sub derange(&@) { my $cb= shift @_; _derange( $cb, \@_, [ map { my $x = $_[$_]; [ grep { $_[$_] ne $x } 0..$#_ ] } 0..$#_ ], ); } derange( sub { print "@_\n" }, 1,1,2,2,3 );

      Of course, if you try to look up a definition for "derangement", you won't find anything that makes much sense when considering duplicates because mathematicians define derangements in term of permutations which they define without considering duplicates either (though they usually don't use language that actually makes that clear, either).

      But the extension of these two concepts to cover lists with duplicate elements is natural, even obvious, as well as useful.

      - tye        

Re: Derangements iterator
by Roy Johnson (Monsignor) on Dec 29, 2005 at 19:03 UTC
    Producing a single derangement (such as might be needed for a Secret Santa list) is just a matter of doing a rotation. Of course, you'd want to randomize the order first, to keep things secret:
    use List::Util 'shuffle'; my @from = shuffle(@ARGV); print "$from[$_-1] => $from[$_]\n" for 0..$#from;

    Caution: Contents may have been coded under pressure.

      That doesn't guarantee that the constraint of derangement is met. Example scenario:

      1 2 3 # original 2 1 3 # shuffled 1 3 2 # rotated one place to the left.
      We're building the house of the future together.
        You misunderstood what was being deranged. What you list as the original is not the original, but merely the (unordered) set. Shuffling provides the "original" order, and rotation provides the derangement of that order.

        Caution: Contents may have been coded under pressure.
Re:Derangements iterator
by spiritway (Vicar) on Dec 30, 2005 at 09:58 UTC
    A derangement is a permutation where none of the elements remained in their starting positions.

    I seem to get that any time I try to use any sort I've written... or many other things I wrote, come to think of it...

Re: Derangements iterator
by jdporter (Canon) on Dec 30, 2005 at 15:56 UTC

    this version uses the services of The (Combinatorial) Object Server.

    use LWP::Simple; my $cosder = "http://www.theory.csc.uvic.ca/~cos/per/perm/perm.pl.cgi? +program=Derange&output1=true&n="; sub derangements { map[@_[split/, /]],get($cosder.@_)=~/<TD ALIGN=CENTER>(.*?) <BR>/g } print "@$_\n" for derangements( qw( aleph beth gimel daleth ) );

    Unfortunately, they don't appear to have an xml or text/plain option.

    We're building the house of the future together.
Re: Derangements iterator
by pKai (Priest) on Dec 31, 2005 at 09:20 UTC

      japhy claimed to have looked at several implementations but been disappointed with each of them. I think he said that each was either too esoteric for him to understand easily enough or did too much work generating permutations that had to be skipped.

      I felt that I had a rather straight-forward approach that wouldn't backtrack much at all. It is very much like Algorithm::Loops::NestedLoops(), except I attempt to build the list of values to loop over next (the offsets not currently selected) more efficiently by keeping track as I go. But I think I can do this more efficiently still.

      So the code just moves along selecting the next item (actually its offset) from the list of items not selected earlier in the list and not at the same offset (and not previously selected for this slot during the current 'round').

      This approach occasionally has to 'backtrack', but (I believe) this only happen when it gets to the last slot and does that at most once per derangement returned. So trying to look ahead to prevent this tiny amount of backtracking would actually be slower than the 'naive' approach.

      I looked at the code for Algorithm::Combinatorics and saw that it was using the lexical-order permutation algorithm1 modified to try to skip non-derangements somewhat efficiently. I had rejected this approach as a first choice because it contains a step where you reverse a part of your list and that can place one or more items back into their original positions in such a way that it would be tricky to quickly jump to the next permutation that is a derangement. And the comments implied that it did have to skip many permutations because of this.

      So, based on japhy's assessment I didn't look at other implementations. Thanks for pointing those out.

      1 The classical lexical-order permutation algorithm is very similar to Algorithm::Loops::NextPermute() except for not dealing with duplicate values, something that I have yet to see done outside of my Algorithm::Loops.

      - tye        

        (Re: Algorithm::Combinatorics) the logic in principle can be refined to skip some more permutations, but benchmarks showed no difference whatsoever, so I left the code that is easier to understand and added a comment about it:

            /* I tried an alternative approach that would in theory avoid the
            generation of some permutations with fixed-points: keeping track of
            the leftmost fixed-point, and reversing the elements to its right.
            But benchmarks up to n = 11 showed no difference whatsoever.
            Thus, I left this version, which is simpler.
        
            That n = 11 does not mean there was a difference for n = 12, it
            means I stopped benchmarking at n = 11. */
        

        The current interface guarantees lexicographic order, but I plan to provide more algorithms that relax that condition if you don't need it and faster generators are available. I will write it before I die ideally.

Re: Derangements iterator (handles duplicate values)
by Roy Johnson (Monsignor) on Jan 03, 2006 at 19:34 UTC
    I've come up with a solution that handles duplicate values properly: that is,
    a b b a
    generates exactly
    b a a b
    I wrote it as a recursive sub, and then converted it to be an iterator. The commented-out code at the end is for verifying that the iterator generates the same output as the recursive version. But don't uncomment it if you want to run on large inputs. The iterator will spit out the first 50 values almost immediately; the recursive version will hang/crash.

    Caution: Contents may have been coded under pressure.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://519815]
Approved by coreolyn
Front-paged by kutsu
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others perusing the Monastery: (8)
As of 2014-11-26 03:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (160 votes), past polls