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:
And there are tests: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;
---#!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!
|
---|
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 | |
Re: Solution to A simple but difficult arithmetic puzzle
by jdporter (Paladin) on Aug 13, 2016 at 03:50 UTC | |
Re: Solution to A simple but difficult arithmetic puzzle
by Anonymous Monk on Aug 11, 2016 at 11:02 UTC | |
Re: Solution to A simple but difficult arithmetic puzzle
by Linicks (Scribe) on Aug 28, 2016 at 11:57 UTC |