math_permutation_lexical.pl6

#!perl6

# math_permutation_lexical.pl6
# - simple perl6 experiments
# - dprelec, 2010

# Algorithm for lexical permutations taken from mr. Donald Knuth's 
# Pre-fascicle 2b of "The Art of Computer Programming"
# http://www-cs-faculty.stanford.edu/~uno/fasc2b.ps.gz

use v6;

role Permutation::Lexical {
    method next_permutation (@a) {
        my $n = @a.end; 
        my $j = $n-1;
        while (@a[$j] >= @a[$j+1]) and ($j >= 0) {
            $j--;
        }

        # if no workaround (see below) set cond to $j <= -1
        return if $j <= 0;
        
        my $l = $n;
        while @a[$j] >= @a[$l] {
            $l--;
        }
        swap(@a, $j, $l);

        my $k = $j + 1;
        $l = $n;
        while $k < $l {
            swap(@a, $k, $l);
            $k++;
            $l--;
        }

        return @a;
    }

    sub swap (@a, $i, $j) {
        (@a[$i], @a[$j]) = @a[$j], @a[$i];
    }

}

class Math::Permutation::Lexical {
    does Permutation::Lexical;

    has @.data is rw;

    has $.counter = -1;
    
    method next () {
        $!counter++;
        if $!counter == 0 {
            return @.data;
        }
        else {
            my @a = @.data;
            # workaround while() error in next_permutation():
            # we check @array[1..$#array] instead of @array[0..$#array]
            @a.unshift('SHROOM'); 
            if self.next_permutation(@a) {
                # getting rid of the workaround
                @a.shift;
                @.data = @a;
                return @a;
            }
            else {
                return;
            }
        }
    }
}

# lazy operator for listing lexical permutations
multi postfix:<|L|>(@a) {
    my $p = Math::Permutation::Lexical.new(data => @a);
    my $iter = gather while my @tmp = $p.next { take @tmp; }
    return $iter;
}

# non-lazy operator for listing lexical permutations
multi postfix:<|E|>(@a) {
    my @res;
    my $p = Math::Permutation::Lexical.new(data => @a);
    while my @tmp = $p.next {
        @res.push([@tmp]);
    }
    return @res;
}

# testing lazy operator: it works!
my @a = 1, 2, 3, 4, 5;
(@a|L|)[0 .. 3].perl.say;

=begin fff
my @a = 1, 2, 3, 4;
my $perm = Math::Permutation::Lexical.new(data => @a);

while my @tmp = $perm.next {
    @tmp.perl.say;
}

$perm.counter.say;
=end fff