From mjd's post A simple but difficult arithmetic puzzle, I present my solution.

First, a module that does Permutation. Yes, I'm aware that there are modules on CPAN that do this, but I was inspired to write mine from scratch -- I'd written this code before, but had to leave it behind at a previous job, so I knew it was possible.

Permute.pm:

package Permute; # Accept an array reference (arrayref), and return an arrayref of # arrayrefs of all of the possible permutations of the original # array. Recursive code. # # T. Alex Beamish / August 11, 2016 sub possibilities { my ( $list ) = @_; my $len = scalar @{$list}; # This is the trivial case: if there's just a single element # in the array, then there's only a single permutation. if ( $len == 1 ) { return [ [ $list->[0] ] ]; } my @output; # OK -- there are at least two elements in the array. Here's # the approach: each of the elements is going to get a chance # to be the first element. We're calling that element the # pivot in the comments below. for my $p ( 0 .. $len-1 ) { my @work; # We're building a work array consisting of everything after # the pivot, followed by everything before the pivot. if ( $p < $len-1 ) { push @work, @{$list}[$p+1..$len-1]; } if ( $p > 0 ) { push @work, @{$list}[0..$p-1]; } # We call ourselves recursively to get all permutations of # the work array, then add each of those possibilities to # the list, with our pivot as the first element. my $poss = possibilities ( \@work ); foreach my $soln ( @{$poss} ) { push ( @output, [ $list->[$p], @{ $soln } ] ); } } return \@output; } 1;
And there are tests:
#!perl use strict; use warnings; use Test::More tests => 1; use lib 'lib'; BEGIN { use_ok ( 'Permute' ); }
---
#!perl use strict; use warnings; use Test::More; use lib 'lib'; use Permute; { my @a1 = ( 4 ); my $possibilities = Permute::possibilities ( \@a1 ); ok ( defined $possibilities, "Got result back" ); is ( scalar @{$possibilities}, 1, "Have just one row" ); is ( $a1[0], $possibilities->[0]->[0], "Value matches" ); done_testing; }
---
#!perl use strict; use warnings; use Test::More; use lib 'lib'; use Permute; { my @a2 = ( 3, 44 ); my $possibilities = Permute::possibilities ( \@a2 ); ok ( defined $possibilities, "Got result back" ); is ( scalar @{$possibilities}, 2, "Have just two rows" ); my %correct = ( '3:44' => 1, '44:3' => 1 ); my %results; foreach my $soln ( @{$possibilities} ) { $results{ join(':',@{$soln}) }++; } foreach my $try ( keys %results ) { ok ( exists $correct{ $try }, "Result $try exists" ); is ( $correct{ $try }, $results{ $try }, "Result count matches" ); } done_testing; }

Now, it could be that more tests than these are require to prove that this is a comprehensive check of the correctness of this module, but I reasoned that if I got the correct result with an array of two, then by mathematical induction, my solution would work for an array of n elements.

OK, I admit that I tested it manually with an array of three elements, and I got the expected six different permutations. So it seems OK

Finally, the script that use Permute to solve mjd's puzzle:

#!perl use strict; use warnings FATAL => 'uninitialized'; use lib 'lib'; # In response to mjd's comments on his blog post at # # http://blog.plover.com/math/17-puzzle.html # # I present my solution to the problem. Most entertaining. # # T. Alex Beamish / August 11, 2016 use Permute; { my @values = ( 6, 6, 5, 2 ); my @ops = qw/+ - \/ */; my $possibilities = Permute::possibilities( \@values ); foreach my $v ( @{$possibilities} ) { for my $o1 ( @ops ) { for my $o2 ( @ops ) { for my $o3 ( @ops ) { my @list = ( $v->[0], $o1, $v->[1], $o2, $v->[2], $o3, $v->[3] ); # Just try the expression as-is, without any brackets. display ( \@list ); # Now we're going to insert a pair of brackets into the # expression, making sure that a) they encompass at least # a number, an operation, and another number, and b) we # don't bother by bracketing the entire expression, as # that's redundant. for my $lb ( 0, 2, 4 ) { for my $rb ( 4, 6, 8 ) { next unless ( $lb + 2 < $rb ); # a) next if ( $lb == 0 && $rb == 8 ); # b) my @blist = @list; splice ( @blist, $lb, 0, '(', @blist[ $lb .. -1 ] ); splice ( @blist, $rb, 0, ')', @blist[ $rb .. -1 ] ); display ( \@blist ); } } } } } } } # Since we have a duplicated value, we can add a hash to catch # expressions identical to the ones we've evaluated already. # It won't catch the similarity between '2*5' and '5*2' that # evaluate to the same value. Oh well. my %tried_that; sub display { my ( $list ) = @_; my $expression = join('',@{$list}); if ( exists $tried_that{ $expression } ) { return; } $tried_that{ $expression } = 1; my $result = eval $expression; if ( defined $result ) { print "$expression = $result\n"; } else { print "$expression is undefined.\n"; } }

I ran this script and piped to output through egrep '17$' which gave me the answer (well, the four different arrangements of the answer that are mathematically equivalent). I won't reveal the solution to the puzzle, but suffice to say it's one of those solutions where you go, "Oh, right", but it's difficult enough that unlikely you'd come up with it quickly.

Thanks mjd!

Alex / talexb / Toronto

Thanks PJ. We owe you so much. Groklaw -- RIP -- 2003 to 2013.

Replies are listed 'Best First'.
Re: Solution to A simple but difficult arithmetic puzzle
by choroba (Cardinal) on Aug 11, 2016 at 17:32 UTC
    Here's a recursive solution I kept carrying in my head for the whole day:
    #!/usr/bin/perl use warnings; use strict; use feature qw{ say }; my %ops = map eval "'$_' => sub { \$_[0] $_ \$_[1] }", qw( + - * / ); sub show { my ($x, $op, $y) = @{ $_[0] }[ 1 .. 3 ]; return join q(), '(', $#$x ? show($x) : $x->[0], $op, $#$y ? show($y) : $y->[0], ')' } my %shown; sub num { my ($result, @nums) = @_; if (1 == @nums) { if ($result == $nums[0][0]) { my $r = show($nums[0]); say $r unless $shown{$r}; $shown{$r} = 1; } return } for my $i (0 .. $#nums - 1) { for my $j ($i + 1 .. $#nums) { for my $op (keys %ops) { my @couples = ([ $i, $j ]); push @couples, [ $j, $i ] if $op !~ /[+*]/; for my $couple (@couples) { my ($x, $y) = @$couple; next if '/' eq $op && 0 == $nums[$y][0]; my $r = $ops{$op}->(map $_->[0], @nums[ $x, $y ]); num($result, [ $r, $nums[$x], $op, $nums[$y] ], @nums[grep $_ != $x && $_ != $y, 0 .. $#nums]) +; } } } } } num(17, map [$_], 2, 5, 6, 6);

    Update: Bugfix: x-y and x/y were not tested for y-x and y/x.

    ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
Re: Solution to A simple but difficult arithmetic puzzle
by jdporter (Paladin) on Aug 13, 2016 at 03:50 UTC

    Here's my solution. Rather than mess with brackets, it implements a very simple stack-based calculator. First it generates all possible permutations of the arguments (input operands), and all possible combinations of the available operators, and all possible RPN expressions (trees). Then it evaluates each expression, with each permutation of the arguments, with each combination of operators. .

    One cool thing about this solution is that it doesn't require exactly four operands. It can take any number of operands (minimum of two). To run it for MJD's problem:

    prog.pl 6 6 5 2 -goal 17
    I reckon we are the only monastery ever to have a dungeon stuffed with 16,000 zombies.
Re: Solution to A simple but difficult arithmetic puzzle
by Anonymous Monk on Aug 11, 2016 at 11:02 UTC

    Couldn't sleep, so I put some stuff I had together:

    #!/usr/bin/perl -l # http://perlmonks.org/?node_id=1169564 use strict; $_ = 6652; 1 while do { /\d.*?\d(?{ 17 == eval "$`($&)$'" and print "$`($&)$'" })(*FAIL)/ for map tr#a-d#-+*/#r, glob join '{a,b,c,d}', split // }, s/.*\K # find the last (.) # digit such that (.*) # there is a later (latest) (.)(??{$1 <= $3 and '(*FAIL)'}) # digit less than it (.*) # and get rest # swap those two digits ( $1 & $3 ) # then reverse everything after the first swapped digit / $3 . reverse $2.$1.$4 /xe;
Re: Solution to A simple but difficult arithmetic puzzle
by Linicks (Scribe) on Aug 28, 2016 at 11:57 UTC

    See one of my pages here:

    https://linicks.net/cdn1/

    Not my code, but I had a real big fight getting the pascal to compile and run on my RaspberryPi!

    Nick