Re: make a 24(another practical problem)

[Greg Bacon]

In message <[EMAIL PROTECTED]>,
    Rick Klement writes:

: most straightforward (ducks...)
:
: [...]
: 
: It prints 20 results.

Using Jonathan's RPN evaluator (code below), I get 16 results:

5 7 + 2 / 4 * = 24
7 5 + 2 / 4 * = 24
5 7 + 4 2 - * = 24
5 7 + 4 * 2 / = 24
5 7 + 4 2 / * = 24
7 5 + 4 2 - * = 24
7 5 + 4 * 2 / = 24
7 5 + 4 2 / * = 24
4 5 7 + * 2 / = 24
4 5 7 + 2 / * = 24
4 7 5 + * 2 / = 24
4 7 5 + 2 / * = 24
4 2 - 5 7 + * = 24
4 2 / 5 7 + * = 24
4 2 - 7 5 + * = 24
4 2 / 7 5 + * = 24
 
When I disable the integer pragma, I get 20 results with the four
extra being:

5 7 + 2 4 / / = 24
7 5 + 2 4 / / = 24
4 2 5 7 + / / = 24
4 2 7 5 + / / = 24

These are using intermediate results that are real numbers.

Greg

#! /usr/local/bin/perl -w

use strict;
use integer;

sub usage { "Usage: $0 target number_1 number_2 [ ... number_n ]\n" }

my @stack;

# Setup function table and pattern
my %ops = ( '+' => sub { $stack[-2] += pop @stack       },
            '-' => sub { $stack[-2] -= pop @stack       },
            '*' => sub { $stack[-2] *= pop @stack       },
            '/' => sub { $stack[-2] /= pop @stack       },
            '^' => sub { $stack[-2] ^= pop @stack       },
          # '!' => sub { $stack[-1]  = fact($stack[-1]) },
            'd' => sub { pop @stack                     },
            'p' => sub { print $stack[-1]               },
            'P' => sub { print pop @stack               },
            'r' => sub { return $stack[-1]              },
            's' => sub { @stack[-2,-1] = @stack[-1,-2]  },
            'c' => sub { @stack = ()                    }
          );

# Create re patterns
my $ops = join("|", map { quotemeta } keys %ops);
my $num = qr/\d+(?:\.\d+)?/;

# RPN Expression Evaluator
sub eval_RPN {
  $_=shift;

  while (/($ops|$num|\s+|.+)/go) {
    my $token = $1;

    if (exists $ops{$token}) {
      $ops{$token}->();
    }

    elsif ($token =~ /\s+/) {
      # Do nothing
    }

    elsif ($token =~ /^$num$/) {
      push @stack, $token;
    }

    else {
      die "Don't know what to do with: $_";
    }
  }
  return pop @stack;
}

sub permute {
    my @items = @{ $_[0] };
    my @perms = @{ $_[1] || [] };

    unless (@items) {
        return [ @perms ];
    }
    else {
        my(@newitems,@newperms,$i);
        my @result;

        foreach $i (0 .. $#items) {
            @newitems = @items;
            @newperms = @perms;

            unshift @newperms, splice @newitems, $i, 1;
            push @result, permute([@newitems], [@newperms]);
        }

        @result;
    }
}

my %seen;
sub arrange {
    my $t = shift;
    my $n = shift;
    my $o = shift;
    my @f = @_;

    if (@$n == 0) {
        push @f, @$o;

#       print "[@f]\n";

        local $@;
        my $result = eval { eval_RPN "c @f r" };
        if (!$@ && $result == $t) {
            print "@f = $result\n";
        }

        return;
    }

    if (@f == 0) {
        push @f, splice @$n, 0, 2;
        arrange($t, $n, $o, @f);
    }
    else {
        return unless @$o;

        my $num = shift @$n;
        arrange($t, $n, $o, @f, $num);
        unshift @$n, $num;

        if (@$o > @$n) {
            my $op = shift @$o;
            arrange($t, $n, $o, @f, $op);
            unshift @$o, $op;
        }
    }
}

sub find_formula {
    my $targ = shift;
    my $nums = shift;
    my @toke = @_;

    if (@toke < @$nums) {
        foreach my $perm (permute $nums) {
            find_formula($targ, $nums, @$perm);
        }
    }
    elsif (@toke < @$nums + @$nums - 1) {
        foreach my $op (qw[ + - * / ]) {
            find_formula($targ, $nums, @toke, $op);
        }
    }
    else {
        my @n = splice @toke, 0, @$nums;

        arrange $targ, \@n, \@toke;
    }
}

## main
if (@ARGV < 3) {
    die usage;
}

my $target = shift;
my $nums   = [ @ARGV ];

find_formula $target, $nums;