in reply to Simple add and multiply subroutines

++ to all proposed solutions and explanations.

If I may add my $0.02, there is something to be said for minimising repetition of similar looking code, particularly if it is likely that the number of repetitions may increase. With that in mind, may I offer: 

#!/usr/bin/perl -w
use strict;

my %do_op=(
  add       => sub{$_[0] +  $_[1]},
  multiply  => sub{$_[0] *  $_[1]},
  divide    => sub{$_[0] /  $_[1]},
  subtract  => sub{$_[0] -  $_[1]},
  power       => sub{$_[0] ** $_[1]}, 
  equal      => sub{$_[0] == $_[1]? $_[0]:0},
  max        => sub{$_[0] >  $_[1]? $_[0]:$_[1]}, 
  min        => sub{$_[0] <  $_[1]? $_[0]:$_[1]},        
);

sub operate{ 
        my $op=shift;
        my $tot = shift;           
        while (defined (my $x=shift)){
                   $tot = $do_op{$op}->($tot,$x);
          }
          $tot;
};            

my $op = shift or die "You must specify an operation followed by numbe
+rs.\n";
die "Non-numeric input.\n" if grep /\D/, @ARGV;
die "Invalid operation.\n" unless exists $do_op{$op};

print "$op (@ARGV)= ". operate($op, @ARGV) . "\n";

[download]
Now, you are on your way to implementing a reverse polish engine ...

     "As you get older three things happen. The first is your memory goes, and I can't remember the other two... " - Sir Norman Wisdom

Replies are listed 'Best First'.
Re^2: Simple add and multiply subroutines
by dragonchild (Archbishop) on Apr 13, 2008 at 02:02 UTC 
    use List::Util qw( reduce );

my %ops = (
    add => sub { reduce { $a + $b } @_ },
    multiply => sub { reduce { $a * $b } @_ },
    # etc ...
);

my $op = shift or die "You must specify an operation followed by numbe
+rs.\n";
die "Non-numeric input.\n" if grep /\D/, @ARGV;
die "Invalid operation.\n" unless exists $ops{$op};

print "$op (@ARGV)= ". $ops->(@ARGV) . "\n";

    [download]
    Except, even that's too much repetition. 
    use List::Util qw( reduce );

my %ops = (
    add => '+',
    multiply => '*',
    # etc ...
);

%ops = map {
    $_ => eval q(sub { reduce { $a ) . $ops{$_} . q( $b } @_ })
} keys %ops;

# And so forth.

    [download]
    Learn CPAN, young padawan. It is rare that someone hasn't already solved at least part of whatever it is you're looking at. Writing core Perl for more than 50% of a program is a sign of "I don't know CPAN," not brilliance.

    Update: Fixed typo s/op/ops/ inside eval.

    My criteria for good software:
    1. Does it work?
    2. Can someone else come in, make a change, and be reasonably certain no bugs were introduced?
[reply]
[d/l]
[select]
      Brilliant!(++) ( Except for a small typo: s/\$op/\$ops/ , inside the "eval").

      Education never stops.

      Update:Code Re-written incorporating dragonchild and mr_mischief's ideas: 

      #!/usr/bin/perl -w
use strict;
use List::Util qw( reduce );

# Definition Syntax: <verb> <operation>;   <operation> can be SIMPLE, 
+as in "+"
#   COMPLEX ops are defined by arrayref, and contain an array of <term
+s>.
#   <complex-op> = [<simple-op>,<pre-code>,<post-code>,<last-code>]  (
+all ,<*-code> is optional)
#   <*-code> can use pre-defined vars: ($a,$b)=@_[0,1];  $count=scalar
+ @_; $result=result


my %ops = ( qw|add + subtract - multiply * divide / power ** |,
             qw|greater > lesser < |,
                 #OP  ,Pre,Post,LAST
    xor      => ["&&",'$a=~$a'],
    all      => ["&&",'', '1 : 0'], 
    none     => ["||",'', '1 : 0', '!$result'], 
    any      => ["||",'', '1 : 0'],
    min      => ["<",'', '$a: $b'],
    max      => [">",'', '$a: $b'],
    mean     => ["+",'','','$result /=$count'],
    geomean  => ["*",'','','$result ** (1/$count)' ], 
    equal    => ["-",'','0:$b', '$result &&=1'], 
);

sub op_JIT_compile{
   my $op = shift;
   return if ref $ops{$op} eq 'CODE'; # Optimize for "Already compiled
+"
   my $opval = $ops{$op};
   # Complex case first - Handle "pre,post" op requirements.
   if (ref $opval eq 'ARRAY'){ # Allow for "pre", "post", and "last" o
+peratons 
         ##  Avoid "undef",s by passing in extra "?'s at end.      
      my ($realop,$pre,$post,$last) = (@$opval,('') x 4); 
      my $post_ternary = $post eq '' ? '' : qq|?$post|; 
      my $eval_this_sub = q|sub { ($a,$b) = my @F=@_; my $count=scalar
+ @F;| . 
                                      q|;my $result= reduce {|
                                                  . $pre . 
                                                   q|; $a | 
                                                  .  $realop  .
                                                  q| $b| 
                                                  . $post_ternary . 
                                                  q| } @F ;|
                                        . $last .
                                      q| }|;
      #print qq[$op = $eval_this_sub\n\tOPS(realop,pre,post,last;)=$re
+alop,$pre,$post,$last;\n];                            
       $ops{$op} = eval $eval_this_sub;
       return;
   }
   # This is the "simple" operator case ..
    $ops{$op} = eval q| sub { reduce { $a | .  $opval  . q| $b } @_ }|
+;
}
 

my $op = lc shift or die "You must specify an operation followed by nu
+mbers.\n";
die "Non-numeric input. $_\n" if grep /\[^-]?\D/, @ARGV;
die "Invalid operation ($op).\n" unless exists $ops{$op};
op_JIT_compile($op);
print "$op (@ARGV)= ". $ops{$op}->(@ARGV) . "\n";

      [download]
      Note that the eval used is a string eval, using only program variables (no user-supplied data). This eval can be performed ahead of time, or JIT (as programmed). The eval is performed only once per function-name. Specifically, it would NOT be performed every time the user provides input (if the program had an input loop).

      Thanks to dragonchild, and mr_mischief for making this interesting/educational.

           "As you get older three things happen. The first is your memory goes, and I can't remember the other two... " - Sir Norman Wisdom

[reply]
[d/l]
Re^2: Simple add and multiply subroutines
by mr_mischief (Monsignor) on Apr 10, 2008 at 17:09 UTC
    Your equal sub has a painful concession to a special case. The value presented for 0 equaling 0 is false. I prefer it to be true, although then the concession is that the return is no longer the value from the call.

    BTW, if you're really wanting to cut down on duplicated code and don't mind torturing the language a bit, you can do this: 

    #!/usr/bin/perl --
use strict;
use warnings;

my $op = shift @ARGV;

my $minmax = '$result ? $_[0] : $_[1];';
my $settruth = '$result ? 1 : 0;';

my %ops = (
    'add'      => { 'op' => '+' },
    'multiply' => { 'op' => '*' },
    'subtract' => { 'op' => '-' },
    'divide'   => { 'op' => '/' },
    'lesser'   => { 'op' => '<' },
    'greater'  => { 'op' => '>' },
    'power'    => { 'op' => '**' },
    'xor'      => { 'op' => '&&', 'pre'  => '$_[0] = ! $_[0];' },
    'all'      => { 'op' => '&&', 'post' => $settruth },
    'none'     => { 'op' => '||', 'post' => $settruth, 'last' => '$tot
+ = ! $tot; $tot += 0;' },
    'any'      => { 'op' => '||', 'post' => $settruth },
    'min'      => { 'op' => '<',  'post' => $minmax },
    'max'      => { 'op' => '>',  'post' => $minmax },
    'mean'     => { 'op' => '+',  'last' => '$tot /= scalar (@_ + 1);'
+ },
    'geomean'  => { 'op' => '*',  'last' => '$tot = $tot ** ( 1 / scal
+ar (@_ + 1) );' },
    'equal'    => { 'op' => '-',  'post' => '$result = $result ? 0 : $
+_[1];',
        'last' => 'local $" = "||"; $tot = 1 if 0 == $tot && 0 == eval
+ "@_";'}
);

sub make_op {
    my $op = shift;
    my $result = 0;
    $ops{$op}{'sub'} = sub {
        ( eval $ops{$op}{'pre'} ) if defined $ops{$op}{'pre'};
        $result = ( eval $_[0] . $ops{$op}{'op'} . $_[1] ) + 0;
        $result = ( eval $ops{$op}{'post'} ) if defined $ops{$op}{'pos
+t'};
        return $result;
    };
}

sub do_op {
    my $op = shift;
    my $tot =  shift;
    make_op( $op ) unless (
        exists $ops{$op}{'sub'}
        && defined $ops{$op}{'sub'}
        && ref $ops{$op}{'sub'} eq 'CODE'
    );
    foreach ( @_ ) {
        $tot = $ops{$op}{'sub'}( $tot, $_ );
    }
    if ( exists $ops{$op}{'last'} ) {
        eval $ops{$op}{'last'};
    }
    return $tot;
}

printf "%-0.03f\n",  do_op( $op, @ARGV );

    [download]

    I know, I know... It's ugly to do from 1 to 3 evals for each iteration and possibly another one or two at the end. The data structures could have clearer names. At least only the op you need gets its sub created. I did say the language would be tortured a bit, didn't I? It's kind of a fun little toy, though.

[reply]
[d/l]
[select]
Re^2: Simple add and multiply subroutines
by oko1 (Deacon) on Apr 09, 2008 at 01:08 UTC

    Might as well toss this in, then: 

    ...
my $op = shift or die "You must specify an operation followed by numbe
+rs.\n";
###########################################################
die "At least two numbers required.\n" unless @ARGV > 1;
###########################################################
die "Non-numeric input.\n" if grep /\D/, @ARGV;
...

    [download]

    Despite jwkrahn's warning, I'd want to implement an "eval" wrapped around the operation, too - after carefully vetting the data. It's quite nice for those "Divide by zero" errors. 

    
-- 
Human history becomes more and more a race between education and catastrophe. -- HG Wells
[reply]
[d/l]

In Section Seekers of Perl Wisdom