Playing with Heap’s Algorithm

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;
	}

2 comments

    1. I didn’t use gather because I was playing with the … operator. I’ll see about adding another example.

Leave a Reply

Your email address will not be published. Required fields are marked *