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;

##</code><code>##

#!perl

use strict;
use warnings;

use Test::More tests => 1;

use lib 'lib';

BEGIN  { use_ok ( 'Permute' ); }

##</code><code>##

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

##</code><code>##

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

##</code><code>##

#!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";
    }
}