I implemented Heap’s algorithm, which generates all permutations of a list, in Perl 6. It’s the end of the year and I’m cleaning out all the things I marked to read later. Sometimes I’ll take something simple, such as a famous algorithm, and try to do it on my own. It’s good practice for language skills but it’s also a good education on languages.
I was reading David M.Bradford’s Heap’s Algorithm and Generating Perl Code From Pseudocode, which referenced the Wikipedia entry for Heap’s Algorithm.
There’s already a method that does this, but I’m not going to let that stand in my way:
> my @array = <a b c> [a b c] > @array.permutations ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))
The structure of my solution is mostly the same (mutatis mutandi) that I’d read on either of those pages:
my @array = <a b c>; for heaps-algorithm( @array, ) -> $permutation { put $permutation; } sub heaps-algorithm ( *@array ) { state $i = 0; state @permutations = [ @array.clone, ]; state @A = |@permutations.[0].clone; state @c = (0) xx @A.elems; loop { if @c[$i] < $i { my $swap-index = $i %% 2 ?? 0 !! @c[$i]; @A[$swap-index, $i] = @A[$i, $swap-index]; @permutations.push: @A.clone; @c[$i]++; $i = 0; } else { @c[$i] = 0; $i++; } last unless $i < @array.elems; } return @permutations; }
There are a few interesting bits of Perl 6 syntax. It’s the end of the year and I have many other things to use or lose so I’ll merely point out a few things:
The single argument rule
I wanted to build up an array of permutations. For the first item I store the original array. I have a significant trailing comma there:
state @permutations = [ @array.clone, ];
If I only use a single array argument (the single argument), the array is automatically flattened. The comma means that it’s not a single argument even though there isn’t a second argument. That isn’t flattened. Notice the extra structure:
% perl 6 > my @array = <a b c> [a b c] > my @p = [ @array ] [a b c] > my @p = [ @array, ] [[a b c]]
When I initialize @A
, which is the structure that I want to change, I flatten the first element with the |
.
In-place swapping
Many other places I looked followed the pseudocode that checked the cursor and then called one of two swap operations:
if i is even then swap(A[0], A[i]) else swap(A[c[i]], A[i]) end if
I’ll choose the right index and put that into the slices:
my $swap-index = $i %% 2 ?? 0 !! @c[$i]; @A[$swap-index, $i] = @A[$i, $swap-index];
Cloning
Each time I create a new permutation I add it to @permutations
. But, I don’t want to keep adding the same object because that object will keep moving it’s elements around. I want to preserve the order each time so I call clone
. I probably overuse that method.
@permutations.push: @A.clone;
I could have done something different, such as using .List
to make a new list out of the current state of the array. I wasn’t thinking too hard about what I wanted on the other side but it’s unlikely that I’d want something mutable.
@permutations.push: @A.List;
Make it a sequence, part 1
The solution that I translated created all the permutations. That’s okay for small lists but not so good for bigger ones. Perl 6 has user-defined sequences. These are lazy and don’t create the next item until it needs to. Could I make this a sequence using the ...
operator? Mostly I’m doing this to see if it would work because I’ve been playing with other weird sequences. I certainly don’t encourage this.
I can use a code reference to decide the next thingy. If that code reference takes arguments, it gets that number of the prior elements in the sequence. I’d like to get the first element to initialize the @A
. After that I just ignore the argument.
I have to adjust the code a bit to end with the right thing. I can’t return
because this is not a routine. It’s just a Block
. I’ll use $next
for that.
I don’t particularly like my solution but this is where I ran out of steam:
my $array = [ 1, 2, 3 ]; my $code-ref = -> ( *@a ) { state $i = 0; state @A = @a.clone; state @c = (0) xx @A.elems; my $next; loop { if @c[$i] < $i { my $swap-index = $i %% 2 ?? 0 !! @c[$i]; @A[$swap-index, $i] = @A[$i, $swap-index]; $next = @A.clone; @c[$i]++; $i = 0; last; } else { @c[$i] = 0; $i++; } last unless $i < @A.elems; } $next; } sub make-sequence ( $a --> Seq ) { $a, $code-ref ...^ !*.defined } my $seq = make-sequence( $array ); for @$seq -> $next { put $next; }
Make it a sequence, part 2
The ...
worked but is pretty ugly. As Michael mentioned in the comments I should have used gather
for this. This generates a Seq
(similar to Python’s yield
). The gather
block is the sequence and every take
can generate one or more elements for the sequence. The code only runs to the point that it gets another element; when you want another element the code resumes where it left off. If the code finishes without encountering another take
(like when this while
is done) the sequence is exhausted:
sub heaps-sequence ( *@a --> Seq:D ) { gather { state $i = 0; state @c = (0) xx @a.elems; take @a.List; while $i < @a.elems { if @c[$i] < $i { my $swap-index = $i %% 2 ?? 0 !! @c[$i]; @a[$swap-index, $i] = @a[$i, $swap-index]; take @a.List; @c[$i]++; $i = 0; } else { @c[$i] = 0; $i++ } } } } my $seq = heaps-sequence( <1 2 3> ); for @$seq -> $next { put $next; last if $next > 10; }
How about using gather/take for the latter solution? Much cleaner.
I didn’t use
gather
because I was playing with the … operator. I’ll see about adding another example.