dprelec · October 29, 2010 14:25 · Oct 29, 2010
diff --git a/math_permutation_lexical.pl6 b/math_permutation_lexical.pl6
@@ -0,0 +1,109 @@
+#!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
+
+