The 24 Puzzle, in Perl 6, using Channels and Promises

Mark Jason Dominus solved the 24 Puzzle in Perl, then explicated some non-Perl solutions other people sent him. RJBS tried it in Forth. I’ve been meaning to try it in Perl 6. I bumbled around as I stubbornly tried to include language features I didn’t really need., but that’s part of the fun.

Here’s the problem:

Given 6,6,5,2, make 17 using the operators +, -, *, and /.

The trick with these puzzles is to not read mjd’s solution before struggling with it yourself. Also, I wanted to do this with Perl 6 features that I wouldn’t be able to use in Perl or C. If the program looks the same in a different language, who cares? It’s done. A mere translation is not that interesting.

I started with the idea that I wanted to use the cross and hyper operations to make the lists of things I’d want to process, and I wanted to use a Channel to hold the list of candidate solutions that various Promises would try to solve. Something would fill the channel, and a set of promises running in other threads would grab candidates. Perl 6 has asynchronous support builtin and I wanted to play with that.

I want my program’s invocation to take a list of numbers where the last number was the goal:

$ perl6 24-problems.p6 [digits] [goal]

To solve this problem, I’d run it as:

$ perl6 24-problems.p6 6 6 5 2 17

Here’s my solution, which is still a bit messy. For any list of N digits, I need N – 1 operators to insert between the digits. I use the cross operator in the reduction operator, [X], with a list of N – 1 copies of @operations. That xx operator is the list replication operator. That’s a lot of work for a single statement (and isn’t that great?).

Ignore the middle of MAIN for a moment. In that for loop I cross all the permutations of digits with all the combinations of the operators. These are all of the candidate solutions. I end up with a bunch of two element lists; the first element is the digits in some order and the second is the list of operators. Perl 6 maintains that structure, so I send a two element thing into the channel.

Now, back up. I have another for that creates a bunch of promises with start. These will run in separate threads in the background. The whenever in react grabs an item from the channel and does some work. An item in a channel is guaranteed to be handled only once, so the promises do their work then fight it out to get another candidate to try.

So, this has the Perl 6 structure I want:

sub MAIN (*@) {
	my $goal       = @*ARGS.pop;
	my @numbers    = @*ARGS.clone.flat;
	my @operations = < + - * / >;

	# I need N - 1 operators, with repeats (so, + + + is fine)
	my @cross = [X] @operations xx (@numbers.elems - 1);
	my @perms = @numbers.permutations.unique( :with(&[eqv]) );

	put "Total candidates: " ~ ( @cross.elems * @perms.elems );

	my $channel = Channel.new;

	my @p;
	my $total = 0;
	for 1 .. 1 {
		@p.push: start {
			react  {
				whenever $channel -> $item {
					state $count = 0; $count++;
					my $result = evaluate( $item );
					put "SOLUTION! $result[*-1] = $goal" if $result[0] == $goal;
					LAST {
						$total += $count;
						put "Thread {$*THREAD.id} handled $count candidates"
						}
					}
				}
			};
		}

	my $start = now;
	put "Starting to send to channels";
	for @perms X @cross -> $i {
		$channel.send( $i )
		}
	put "Done sending to channels: " ~ (now - $start) ~ " seconds";

	$channel.close;

	await [email protected];

	put "Total handled was $total";
	}

sub evaluate ( $item ) {
	my @digits  = $item[0].flat;
	my @ops     = $item[1].flat;

	my @ops2 = ( [email protected], '' );

	my $string = @digits >>~<< @ops2;

	while @ops.elems > 0 {
		splice(
			@digits, 0, 2,
			op( @ops.shift, [email protected][0,1] )
			);
		}

	return [ @digits[0], $string ];
	}

multi op ( '+', $m, $n ) { $m + $n }
multi op ( '-', $m, $n ) { $m - $n }
multi op ( '/', $m, $n ) { $m / $n }
multi op ( '*', $m, $n ) { $m * $n }

I struggled for a bit to figure out what I wanted to do in evaluate. For a long time I tried to force a situation where I’d use the zip meta operator, Z, to merge the digits and the operators. If I could do that, I could stringify and EVAL that. Yeah, that’s disgusting and requires a secret pragma, but I got stuck on that idea. The problem was the ugliness of operator list having one less item than the digits list. The Z wants to use the same number of elements from both sides and will cycle back to the beginning of the shorter list. For awhile I’d mutate the operator list to add the empty string at the end. I never liked this and it made everything harder than it needed to be.

While I was goofing around with that, I had the idea that I could zip the lists myself. As long as there was something in @ops, take one item from that list and two items from @digits and push them onto a new array:

@temp-array.push: @digits[0], @ops[0], @digits[1];

It took me much longer that it should have to realize that I didn’t need the temporary array. I’ll grab the same elements, figure out the result, and replace those two numbers with the single number I just computed. When @ops was empty, I should have the answer in @digits. Boom. But, I still did the zip thing to make a string that represented the operation so I know how I got it.

To compute the intermediate results, I created some multi subs with similar signatures, but I used a literal string as the first thing in the signature. This is how I’d translate the strings representing the operators into actual operations. I could have done the same thing with given, but I didn’t:

my $result = do {
	given $o {
		when '+' { $m + $n }
		when '-' { $m - $n }
		when '*' { $m * $n }
		when '/' { $m / $n }
		}
	};

When I run this, I get output like this:

Total candidates: 768
Starting to send to channels
SOLUTION! 5/ 6+ 2* 6 = 17
Done sending to channels: 1.5209437 seconds
Thread 13 handled 55 candidates
Thread 6 handled 57 candidates
Thread 3 handled 656 candidates
Total handled was 768

A digression of threading

Notice that one of the threads handled many more candidates. This isn’t true for every run. More often, all threads handle close to the same number of candidates. But, whenever that happened the program was much slower by about half a second. That probably means I’m using too many threads. If I changed the code to create only one promise, it’s very fast:

Total candidates: 768
Starting to send to channels
Done sending to channels: 0.24503289 seconds
SOLUTION! 5/ 6+ 2* 6 = 17
Thread 4 handled 768 candidates
Total handled was 768

This sniffs of a synchronization problem. If threads compete for the same physical processor, they have to cooperate (and something has to help them do that). I wasn’t concerned about making this fast because I wanted to play with the features, but its something to think about for production programming.

Here’s the overall timing for three promises. Notice the user time is about two times the real time because multiple threads are working at the same time:

$ time perl6 pick-* 6 6 5 2 17
Total candidates: 768
Starting to send to channels
Done sending to channels: 2.0787578 seconds
Thread 6 handled 50 candidates
SOLUTION! 5/ 6+ 2* 6 = 17
Thread 4 handled 344 candidates
Thread 3 handled 374 candidates
Total handled was 768

real	0m3.294s
user	0m7.836s
sys	0m0.843s

And for one promise, the user time and real time are about the same, and both are lower than using three threads:

$ time perl6 pick-* 6 6 5 2 17
Total candidates: 768
Starting to send to channels
Done sending to channels: 0.2340613 seconds
SOLUTION! 5/ 6+ 2* 6 = 17
Thread 4 handled 768 candidates
Total handled was 768

real	0m2.088s
user	0m2.148s
sys	0m0.276s

If there’s a lot of lag in the processing (like fetching a resource or waiting), slicing operations into threads can have them wait together. Since those threads don’t need to use the processor to wait, they aren’t competing and getting in each other’s way.

Here’s a stripped down version of my previous program where most of the processing of each item isn’t actual work:

my $channel = Channel.new;

my $threads = @*ARGS[0] // 1;
put "Using $threads threads";

my @promises;
for 0 ... ^$threads {
	@promises.push: start {
		react  {
			whenever $channel -> $item {
				put "Thread {$*THREAD.id} handing $item";
				sleep $item % 3
				}
			}
		};
	}

for ^37 {
	$channel.send( $_ )
	}

$channel.close;

await [email protected];

With one thread, it takes about 37 seconds on the wallclock, but notice the user time is really low:

$ time perl6 wait.p6
Using 1 threads
Thread 3 handing 0
...
Thread 3 handing 34
Thread 3 handing 35
Thread 3 handing 36

real	0m36.359s
user	0m0.278s
sys	0m0.067s

Three threads can sleep simultaneously and can be much faster. The user time is about the same, but the wallclock time is less than half what it was before:

$ time perl6 wait.p6 3
Using 3 threads
Thread 4 handing 0
Thread 3 handing 1
...
Thread 3 handing 33
Thread 3 handing 36

real	0m15.637s
user	0m0.281s
sys	0m0.112s

A slight digression on EVAL

As part of my initial idea, I tried to create a string version of the solution and EVAL the whole thing. That’s expedient if not prudent, but sometimes you want the answer any way you can get it and don’t care about the purity or cleverness. I can easily make a list of all of the combinations of three operators (one less than the number of digits):

$ perl6
> my @a = < + - / * >

> [X] @a xx 3
((+ + +) (+ + -) (+ + /) (+ + *) (+ - +) (+ - -) (+ - /) (+ - *) (+ / +) (+ / -) (+ / /) (+ / *) (+ * +) (+ * -) (+ * /) (+ * *) (- + +) (- + -) (- + /) (- + *) (- - +) (- - -) (- - /) (- - *) (- / +) (- / -) (- / /) (- / *) (- * +) (- * -) (- * /) (- * *) (/ + +) (/ + -) (/ + /) (/ + *) (/ - +) (/ - -) (/ - /) (/ - *) (/ / +) (/ / -) (/ / /) (/ / *) (/ * +) (/ * -) (/ * /) (/ * *) (* + +) (* + -) (* + /) (* + *) (* - +) (* - -) (* - /) (* - *) (* / +) (* / -) (* / /) (* / *) (* * +) (* * -) (* * /) (* * *))

If I wanted to make a string like 6+6+5-2 with the Z operator, I’d need something at the end to come after the 2. It can’t be another operator though. I wanted something like this:

my @digits = 6, 6, 5, 2;
my @ops    = < + - / * >;
my @perms  = @digits.permutations.unique( :with(&[eqv]) );

my @cross = [X] @ops xx ( @digits.elems - 1 );

my @results = ( @perms X @cross )
	.map(  { my @d= (|.[1], ''); .[0] >>~>> @d } )
	.map(  { say "$_ = " ~ EVAL ~$_; $_  } )
	.grep( { 17 == EVAL $_ } )

Even when I solved that, another problem came up. When I EVAL the statement, Perl 6 has a particular order of operations where the problem actually goes from left to right without precedence. That’s not explicitly stated in the problem, but it’s part of the problem. It took me a bit to figure out why I wasn’t seeing any solutions this way.

Besides, I was trying to avoid the combinatorial explosion and the time to create the giant list only to go through it to tear it apart when I can do it in fewer steps.

I’d later discover that although I’d found a candidate for the the 6 6 5 2 situation, I hadn’t actually solved the puzzle correctly. Besides the combinations of digits and operators, there was a third set of permutations. I needed all the orders of operations. But, let’s think about Mark Jason’s solution now.

Back to Mark Jason’s solution

After I’d figured out what I wanted to do, I looked back to see what Mark Jason had done. I won’t re-explicate his approach, but I do want to see how similar we were.

He also used a queue. I had mine in a channel and he maintained a list. I’d say that was about the same idea with different phenotypes.

He created a way to process two numbers at a time and replace them with their result. His added to a history string each time whereas I made the history string ahead of time. His solution was different because each combination of digits and operators represented a tree of solutions. You can do the first pair of digits first, or the last pair first, or the middle pair first. Then, you go through that for what’s left. I’d accidentally found a solution to the particular digits because those worked in left to right order. But, I couldn’t find a solution to 8 8 3 3 == 24 because there isn’t one that evaluates left to right. I hadn’t handled the situation where I do the operations in other orders, like this:

8 ÷ (3 - (8÷3)) = 24

There are actually six paths through the possible combinations of four digits and three operators. There were various ways that I could handle this. I could make all of those candidates and add them to the channel, or I could have the thing that takes the existing candidates generate sub problems and add those to the channel. This would mess up my tidy and apparently unclever solution to getting the history.

And, here’s a good place to back up for a moment. Had I thought about this problem more and paid attention to his note about 8 8 3 3 == 24, I would have made a test case for that and noticed I couldn’t solve it. I do that when I’m doing production programming and am very careful about the specification, but I wasn’t fastidious here. I think my hubris got in the way. However, I did notice my omission as I was double-checking my work. It’s a bit heart stopping to realize such a thing right before you were about to push to master though. 😉

After playing with this much longer than I should have, I came up with something close to what Mark Jason did. I took longer because I was trying quite hard to avoid his solution and I was trying to be clever in Perl 6. He created nodes for each computation (with the starting trivial case of the result being the starting digit). As he carried those along, he combined two nodes to create a new node with the new result but also a new string version of the combined history of those two nodes. While I was trying to avoid this, I was doing the same idea with a differen’t implementation. I didn’t have a fresh idea (other that creating an RPN calculator class, until I realized that it was still the same idea).

I’ve adjusted a few things from my previous program and explained some
of the trickier accounting to get the history. There’s plenty more I don’t like about my implementation, but it’s good enough that I can move on to other problems:

sub MAIN (*@) {
	my $goal       = @*ARGS.pop;
	my @numbers    = @*ARGS.clone.flat;
	my @operations = < + - * / >;

	my @cross = [X] @operations xx (@numbers.elems - 1);
	my @perms = @numbers.permutations.unique( :with(&[eqv]) );
	my @orders = ( 0 .. (@numbers.elems - 2) ).permutations;

	put "Total candidates: " ~
		( @cross.elems * @perms.elems * @orders.elems );

	my $channel = Channel.new;

	my @promises;
	my $total = 0;
	#`(
		probably need to make fewer threads since this is
		computation heavy, but here's where you can adjust
		that.
		)
	my $max_promises = 1;  # 1 seems to be the right number
	for 1 ..  $max_promises {
		@promises.push: start {
			react  {
				whenever $channel -> $item {
					state $count = 0; $count++;
					my $result = evaluate( $item );
					next unless defined $result[0];
					put "SOLUTION! $result[1] = $goal"
						if $result[0] == $goal;
					}
				}
			};
		}

	my $start = now;
	put "Starting to send to channels";
	#`(
		Don't really need the double X here, but it saves a
		hardcoded series of next loops. With 4 digits, the
		maximum list size is under 10,000. The nested loop
		version ran in about the same time
		)
	for @perms X @cross X @orders -> $i {
		$channel.send( $i )
		}
	put "Done sending to channels: "
		~ (now - $start) ~ " seconds";

	$channel.close;

	await [email protected];

	put "Total handled was $total";
	}

sub evaluate ( $item ) {
	#`(
		Each entry in digits is a tuple that represents a
		sub computation. The first item in there is a number
		and the second is a string that represents the
		history of the prior computations. At the start, the
		history is simply the digit for that tuple
		)
	my @digits  = |$item[0].map: { [ $_, $_ ] };
	#`(
		Ops is a list of mathematical operators, and should
		have one fewer elements that @digits since every
		operator needs two operands
		)
	my @ops     = |$item[1];
	#`(
		The orders represents the order of operations. Think
		of this as implementing implied parens around
		operations. With this, you aren't stuck with issues
		of precedence or left-to-right evaluation.
		)
	my @orders  = |$item[2];
	#`(
		@orders_offset tracks and adjusts positions in the
		operation. It's important with you want to do the
		3rd operation last, for instance, but doing the 1st
		and 2nd operations has removed elements from
		@digits. Later operations need to adjust their
		offsets when they look for operands in @digits.

		The indices in @orders_offset correspond to the
		values @orders. Use the value from @orders as the
		index into @orders_offset to get the offset.
		)
	my @orders_offset = 0 xx @orders.elems;


	#`(
		Go through all the values in @orders, which
		correspond to the index to look up the operation in
		@ops and the index for the offsets in @digits (which
		reduces as we do work).
		)

	for [email protected] {
		my ( $real_order ) = @orders[$_];
		my ( $order )      = $real_order -
			@orders_offset[$real_order];
		my ( $op )         = @ops[$real_order];

		my $result = op( $op, @digits[$order], @digits[$order+1] );
		return [ NaN, Str ] unless defined $result;

		my $string =
			"([email protected][$order][1]} $op [email protected][$order+1][1]})";

		# splice is slurpy, so do extra work to maintain the tuple
		@digits.splice: $order, 2, [ $[ $result, $string ] ];

		#`(
			if this step combined elements, adjust offsets for
			later operations. That is, when the list shrinks,
			increase offsets after that point so the offsets
			still refer to the same items.
			)
		for [email protected]_offset [email protected]_offset[$_]++ if $order < $_ }
		}

	return @digits[0];
	}

# all of these get a tuple from @digits
multi op ( '+', $m, $n ) { $m[0] + $n[0] }
multi op ( '-', $m, $n ) { $m[0] - $n[0] }
multi op ( '/', $m, $n ) { $n[0] == 0 ?? fail() !! $m[0] / $n[0] }
multi op ( '*', $m, $n ) { $m[0] * $n[0] }

2 comments

  1. FWIW: .unique’s `:with` has complexity of something around O(n²/2) and you should try to avoid it whenever you can and use `:as` arg instead. In this case, since all lists have the same number of elements, `:as(*.Str)` can be used:

    m: my @p = 1..2000; @ = @p.unique: :with(&[eqv]); say now – INIT now
    rakudo-moar 6f3de6: OUTPUT: «7.468134␤»
    m: my @p = 1..2000; @ = @p.unique: :as(*.Str); say now – INIT now
    rakudo-moar 6f3de6: OUTPUT: «0.00771542␤»

    1. When stringifying lists, you can get the same string from lists with different elements. That would potentially discard some lists that should be kept.

Leave a Reply

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