#!/usr/bin/env perl

use warnings;

#use strict;

# 'Flippo-spel'  ('pog game'?)
#
# $Id$
#
# usage: flip target number1 [number2 [number3 [...]]]
# checks whether or not target can be formed by an expression involving
# all of the remaining numbers, and the normal operations of arithmetic +-*/

# the sig structure is unused, except when $scan_dup is on which is a bad idea
# so it only costs time and space at the moment :(

# algorithm: expressions of size n are built for increasing n
# until one is found that uses all numbers and is equal to the target

# opt1: left operand >= right operand (thanks to properties +-*/) except for /
# remark: intermediate result is *not* always integer! (try 24 3 3 8 8)
# opt2: if the value and bag of used numbers of an expression is equal
#   to that of a previous one, don't use it
# opt3: to avoid checking over and over whether two expressions can be
#  combined or not, we build a data structure of 'sigs': sorted sublists of
#  the numbers supplied as arguments: the sorted list of sigs, and a mapping
#  from concatenated pairs of sigs to their result (ie. the same but sorted,
#  or undefined if the result sig is not a sublist of the initial arguments)
#  we wish to build the expressions by increasing sig rather than increasing
#  size but I'm not sure if this can be done efficiently

# config
$verbose  = 0;    # explain what you're doing?
$continue = 1;    # go on after finding one solution?
$scan_dup = 0;    # scan for prior expressions with same value?
# this eliminates about 1/3 of all exprs, and adds an order
# of magnitude searching - NOT COST EFECTIVE
$blunt = 0;    # use the 'blunt axe' method instead of all this administration
# well, this is *much* slower

# end of config

sub msg
{
  warn("@_\n") if $verbose;
}

goto blunt_way if $blunt;

# data structures
# an expression is identified by a cardinal number ('expr id')
undef(%v);    # maps expr id to expression value (teller [<-- word?] only)
undef(%q);    # maps expr id to denominator, if non-integer expression value
undef(%l);    # maps expr id to left operand id
undef(%r);    # maps expr id to right operand id
undef(%o);    # maps expr id to operator
undef(%x);    # maps expr id to human-readable expression
undef(%f);    # maps size to expr id of first expr of that size
undef(%s);    # maps expr id to its sig (formed by its leaves)
undef(%q);    # maps non-rational quotient to normalised quotient

# a 'sig' is a space-separated sorted list of numbers (duplicates allowed)
undef(%sigsz);    # maps every valid sig to its size (number of members - 1)
undef(%m);        # maps space-separated sig pair to resulting sig, if valid
# (this reduces the check whether or not two exprs combine
#  to a hash table lookup, which MAY speed up things)
undef(@sig);      # the sorted list of sigs - sorting MUST respect size
# (used in creating %m)
undef($sig);      # the largest sig: the sig of all numbers suppl. as arguments

undef($lastx);    # the id of the last expression added
undef($size);     # the size of the expressions we're creating
undef($fullsize); # the size of a complete expression (in # operations)

sub xpr2string

 # given an expression, produces a human readable string
{
  local ($x) = $_[0];

  if ( defined( $o{$x} ) )
  {
    '(' . &xpr2string( $l{$x} ) . $o{$x} . &xpr2string( $r{$x} ) . ')';
  }
  else
  {
    $v{$x};
  }
}

# initialise

$target = shift(@ARGV);

$f{ $size = 0 } = 1;

# expressions start at 1
# the first expressions are plain numbers, having size 0 (not 1!)

@numbers = sort { $a <=> $b } @ARGV;

$lastx = 0;
for ( $i = 0 ; $i <= $#numbers ; ++$i )
{
  ++$lastx;
  $s{$lastx} = $x{$lastx} = $v{$lastx} = $numbers[$i];
  $sigsz{ $s{$lastx} } = $size{$lastx} = $size;

  # treat a number as an expression without l, r, o fields
}

$fullsize = $#numbers;
$sig      = "@numbers";

&msg("trying to make $target from @numbers");

# build sig structure
&msg("building sig structure ... this may take lots of space");

# this is not a simple iteration
sub addsigs

 # given $prev and a list, adds $prev with all sublists (joint with ' ')
{
  local ( $prev, $next, @rest ) = @_;

  if ( !defined($next) )
  {
    $sigsz{$prev} = 1;    # corrected later
  }
  else
  {
    &addsigs( $prev,               @rest );
    &addsigs( $prev . ' ' . $next, @rest );
  }
}
{
  local (@n) = @numbers;
  local ($first);

  while ( $first = shift(@n) )
  {
    &addsigs( $first, @n );
  }
}

foreach ( keys(%sigsz) ) { $sigsz{$_} = tr/ / /; }    # correct sizes
@sig = sort { $sigsz{$a} <=> $sigsz{$b} } ( keys(%sigsz) );

&msg( "sigs are", join( ', ', @sig ) );

for ( $i = 0 ; $i <= $#sig ; ++$i )
{
  local ($x) = $sig[$i];

  for ( $j = 0 ; $sigsz{$x} + $sigsz{ $sig[$j] } < $fullsize ; ++$j )
  {
    local ($y) = $sig[$j];
    local ($z);

    $z = join( ' ', sort { $a <=> $b } ( split( ' ', $x ), split( ' ', $y ) ) );
    &msg("$x and $y yield $z");

    if ( defined( $sigsz{$z} ) )
    {
      &msg("adding match '$x $y' -> '$z'");
      $m{ $x . ' ' . $y } = $z;
    }
  }
}

# for Perl4 - in Perl5 we can use nested lists and avoid the splitting/joining

# we can be more efficient by maintaining the size of our sigs ... naaah

&msg( "precomputation finished ...", $#sig + 1, "occurrence patterns sorted" );
&msg("starting to build expressions sorted by occurrence pattern");

# compute

# the trick is to build the expressions in an order that the applicable
# arguments for combinations can be found quickly
#
# building them sorted by size is a good idea already, and we'll settle for
# that now, but there may be a better way

undef(%found);    # store for the results, if $continue

while ( ++$size <= $fullsize )
{
  &msg("creating the expressions of size $size");
  $f{$size} = $lastx + 1;    # important, we depend on setting it here

  # create them by combining expressions $x,$y of size $k and $size-$k
  for ( $k = 0 ; $k <= $size - $k ; ++$k )
  {
    for ( $x = $f{$k} ; $x < $f{ $k + 1 } ; ++$x )
    {
      # $x has size $k, we need size $size, so $y must have size $size-$k-1
      for ( $y = $f{ $size - $k - 1 } ; $y < $f{ $size - $k } ; ++$y )
      {
        # we'll be swapping $x and $y as required, so take $y >= $x
        next if $y < $x;

        # combine this pair $x,$y
        #&msg("combining #$x and #$y");
        $res_sig = $m{ $s{$x} . ' ' . $s{$y} };
        next if !defined($res_sig);

        # that is, if they don't combine: if numbers get used too often

        # there's only one way: the expr with the larger value first (opt1)
        # except for '/', so we'll cheat and introduce a '\' to make up for that!
        ( $l, $r ) = ( $x, $y );
        ( $vl, $ql, $vr, $qr ) = ( $v{$l}, $q{$l} || 1, $v{$r}, $q{$r} || 1 );
        ( $l, $r, $vl, $ql, $vr, $qr ) = ( $r, $l, $vr, $qr, $vl, $ql )
         if ( $ql ? $vl / $ql : $vl ) < ( $qr ? $vr / $qr : $vr );
        $opindex = 0;

        #&msg("still using #$x and #$y");
       OP: while ( $op = ( '-', '+', '*', '/', '\\' )[ $opindex++ ] )
        {
          if ( $op eq '\\' )
          {
            # 'uncheat'
            ( $l, $r, $vl, $ql, $vr, $qr ) = ( $r, $l, $vr, $qr, $vl, $ql );
            $op = '/';
          }
          $xpr = '(' . &xpr2string($l) . $op . &xpr2string($r) . ')';

          # MUST be in &xpr2string format; might be used in comparisons (isn't)
          &msg("trying #$l $op #$r = $xpr = $vl/$ql $op $vr/$qr");
          next if $op eq '/' && ( $vr eq 0 );    # don't divide by 0
          # laws:	vl/ql + vr/qr = (vl*qr+vr*ql)/ql*qr; same for -;
          #	(vl/ql) * (vr/qr) = vl*vr/ql*qr; (vl/ql)/(vr/qr) = vl*qr/ql*vr
          $fraction = ( $ql || $qr || $op eq '/' );    # flag fraction
          ( $v, $q ) =
            !$fraction ? ( eval( $vl . $op . $vr ), 1 )
           : $op eq '*' ? ( $vl * $vr, $ql * $qr )
           : $op eq '/' ? ( $vl * $qr, $vr * $ql )
           : $op eq '+' ? ( $vl * $qr + $vr * $ql, $ql * $qr )
           : $op eq '-' ? ( $vl * $qr - $vr * $ql, $ql * $qr )
           :              die("bug: unknown operator '$op'\n");
          $vq = $v / $q;
          &msg("found $xpr = $v/$q");

          if ($scan_dup)
          {
            # ignore it if we already have an expression with this sig and value
            # currently, this test is *very* expensive, adding an order
            for ( $prev = $f{$size} ; $prev <= $lastx ; ++$prev )
            {
              next
               if (( $s{$prev} ne $res_sig )
                || ( ( $q{$prev} ? $v{$prev} / $q{$prev} : $v{$prev} ) ne $vq )
               );

              # passed? then we found one
              &msg( "cancelled by the equivalent or equal expression",
                &xpr2string($prev), "(#$prev)" );
              next OP;
            }
          }

          # it's really new - if we're at full size, just test it
          if ( $size eq $fullsize )
          {
            if ( $vq eq $target )
            {
              if ( !$continue )
              {
                print "$target = $xpr\n";
                &msg("  using expressions #$l and #$r; $lastx were stored)");
                exit(0);
              }
              $found{$xpr} = 1;
            }
          }
          else    # not at full size yet - this is a partial expression, add it
          {
            ++$lastx;
            $x{$lastx}    = $xpr;
            $v{$lastx}    = $v;
            $q{$lastx}    = $q unless $q eq 1;
            $o{$lastx}    = $op;
            $l{$lastx}    = $l;
            $r{$lastx}    = $r;
            $size{$lastx} = $size;
            $s{$lastx}    = $res_sig;
            &msg( "adding #$lastx = #$l $op #$r,",
              " value $v/$q, occurrence pattern $res_sig" );
          }

          # next $op
        }

        # next $y
      }

      # next $x
    }

    # next $k
  }

  # next $size
}

if ( !%found )
{
  die( "$target could not be made\n",
    "  (combinations exhausted after $lastx iteration steps)\n" );
}
else
{
  print grep( $_ = "$target = $_\n", keys(%found) );
  &msg("this may not be all, due to optimisations") if $scan_dup;
  &msg("  (combinations exhausted after $lastx iteration steps)");
  exit(0);
}

blunt_way: { 1; }

# this is a very different method:
# simply generate all valid, fully bracketed expressions, and eval them ...
#
# generation: in each step, we generate expressions of the next size
# as in the other method

# data structures
undef(%x);    # maps expr id to expression
undef(%f);    # maps size to expr id of first expr of that size

undef($lastx);       # the id of the last expression added
undef($size);        # the current expression size
undef($fullsize);    # the size of a complete expression (in # operations)

# initialisation

$target = shift(@ARGV);

$f{ $size = 0 } = 1;

# expressions start at 1
# the first expressions are plain numbers, having size 0 (not 1!)

@numbers = sort { $a <=> $b } @ARGV;

$lastx = 0;
for ( $i = 0 ; $i <= $#numbers ; ++$i )
{
  ++$lastx;
  $x{$lastx} = $v{$lastx} = $numbers[$i];
  $size{$lastx} = $size;

  # treat a number as an expression without l, r, o fields
}

$fullsize = $#numbers;

&msg("trying to make $target from @numbers");

undef(%found);    # store for the results, if $continue

# this loop is copy & paste from above - only the interior is different
while ( ++$size <= $fullsize )
{
  &msg("creating the expressions of size $size");
  $f{$size} = $lastx + 1;    # important, we depend on setting it here

  # create them by combining expressions $x,$y of size $k and $size-$k
  for ( $k = 0 ; $k <= $size - $k ; ++$k )
  {
    for ( $x = $f{$k} ; $x < $f{ $k + 1 } ; ++$x )
    {
      # $x has size $k, we need size $size, so $y must have size $size-$k-1
      for ( $y = $f{ $size - $k - 1 } ; $y < $f{ $size - $k } ; ++$y )
      {
        for $op ( '+', '-', '*', '/' )
        {
          # don't divide by 0
          next if ( $op eq '/' && !$y );

          $xpr = "$x{$x}$op$x{$y}";

          # if we're at full size, just test it
          if ( $size eq $fullsize )
          {
            if ( eval($xpr) eq $target )
            {
              if ( !$continue )
              {
                print "$target = $xpr\n";
                &msg("  using expressions #$x and #$y; $lastx were stored)");
                exit(0);
              }
              $found{$xpr} = 1;
            }
          }
          else    # not at full size yet - this is a partial expression, add it
          {
            ++$lastx;
            $x{$lastx} = $xpr;
            &msg("adding #$lastx = #$x $op #$y");
          }

          # next $op
        }

        # next $y
      }

      # next $x
    }

    # next $k
  }

  # next $size
}

if ( !%found )
{
  die( "$target could not be made\n",
    "  (combinations exhausted after $lastx iteration steps)\n" );
}
else
{
  print grep( $_ = "$target = $_\n", keys(%found) );
  &msg("this may not be all, due to optimisations") if $scan_dup;
  &msg("  (combinations exhausted after $lastx iteration steps)");
  exit(0);
}