package Conway;
use overload
'+'     => \&Add,
'-'     => \&Sub,
'*'     => \&Mul,
'>='    => \&Geq,
'<='    => \&Leq,
'=='    => \&eql,
'<=>'   => \&Cmp,
'neg'   => \&Neg,
'++'    => \&Succ,
'""'    => \&Name,
'0+'    => \&Value,
'='     => \&Copy,
bool    => sub{my $x = shift; return !Eql($x,$zero)},
;

sub Geq{
    my($x,$y) = @_;
    my @xL = @{$x->[0]};
    my @xR = @{$x->[1]};
    my @yL = @{$y->[0]};
    my @yR = @{$y->[1]};
    return !(grep{Leq($_,$y)}@xR) && !(grep{Leq($x,$_)}@yL);
}
sub Leq{
    my($x,$y) = @_;
    return Geq($y,$x);
}
sub Eql{
   my($x,$y) = @_;
   return Geq($x,$y) && Geq($y,$x)
}
sub Gtr{
   my($x,$y) = @_;
   return Geq($x,$y) && !Geq($y,$x);
}
sub Cmp{
   my($x,$y) = @_;
   my $g = Geq($x,$y);
   my $l = Leq($x,$y);
   return undef unless $g || $l;
   return  0 if $g &&  $l;
   return  1 if $g && !$l;
   return -1 if !$g && $l
}
sub Neg{
   my $x = shift;
   my @xL = @{$x->[0]};
   my @xR = @{$x->[1]};
   
   return bless [
     [map{Neg($_)}@xR], 
     [map{Neg($_)}@xL]
   ];
}
sub Add{
    my($x,$y) = @_;
    my @xL = @{$x->[0]};
    my @xR = @{$x->[1]};
    my @yL = @{$y->[0]};
    my @yR = @{$y->[1]};
    bless[
     [
        (map{Add($_,$y)} @xL),
        (map{Add($x,$_)} @yL),
     ],
     [
        (map{Add($_,$y)} @xR),
        (map{Add($x,$_)} @yR),
     ]
    ];
 }
sub Sub{
    my($x,$y) = @_;
    Add($x,Neg($y));
}
sub dmap(&$$){
        my $f = shift;
        my @a = @{shift @_};
        my @b = @{shift @_};
        map{
            local $a = $_;
            map{ local $b=$_; &$f } @b;
        } @a;
}
sub Mul{
   my($x,$y) = @_;
   my @xL = @{$x->[0]};
   my @xR = @{$x->[1]};
   my @yL = @{$y->[0]};
   my @yR = @{$y->[1]};
   bless [
      [
         (dmap{Sub(Add(Mul($a,$y),Mul($x,$b)),Mul($a,$b))} \@xL,\@yL),
         (dmap{Sub(Add(Mul($a,$y),Mul($x,$b)),Mul($a,$b))} \@xR,\@yR),
      ],
      [
         (dmap{Sub(Add(Mul($a,$y),Mul($x,$b)),Mul($a,$b))} \@xL,\@yR),
         (dmap{Sub(Add(Mul($a,$y),Mul($x,$b)),Mul($a,$b))} \@xR,\@yL),
      ]
   ]
}
sub L{
   my $x = shift;
   return @{$x->[0]};
};
sub R{
   my $x = shift;
   return @{$x->[1]};
}
sub normalize{
  my($x,$y) = @_;
  my @xL = map{normalize($_)} @{$x->[0]};
  my @xR = map{normalize($_)} @{$x->[1]};
  
  while( @xR > 1 ){
    if( Geq(@xR[0],@xR[-1]) ){
      shift @xR; 
    }elsif( Geq(@xR[-1],@xR[0]) ){
      pop @xR;
    }else{
       warn "NaN"; last;
    }
  }
  while( @xL > 1 ){
    if( Geq(@xL[0],@xL[-1]) ){
      pop @xL; 
    }elsif( Geq(@xL[-1],@xL[0]) ){
      shift @xL;
    }else{
       warn "NaN"; last;
    }
  }
  bless [[@xL],[@xR]];
}
sub Succ{
   my $x = shift;
   bless [[$x],[]];
}
sub Copy{
   my $x = shift;
   normalize($x);
}
sub new{
    my $class = shift;
    my ($L, $R) = @_;
    my $n = [$L,$R];
    bless $n,$class;
    return $n;
}
sub Name{
   my $x = shift;
#  return 0 if Eql($x,$zero);
   my @xL = @{$x->[0]};
   my @xR = @{$x->[1]};
   my $L=join",",map{Name($_)} @xL;
   my $R=join",",map{Name($_)} @xR;
   return "{$L|$R}";
}

sub Value{
   my $x = normalize(shift);
   my $g = Geq($x,$zero);
   my $l = Leq($x,$zero);
   return NaN unless $g || $l;
   return 0 if $g && $l;
   return -Value(Neg($x)) if $l && !$g;
   return 1+Value(Sub($x,$one) ) if( Geq($x,$one));
   return Value( Mul($x,$two) )/2;
}
$zero = new Conway [],[]; 
$one = $zero->Succ; 


$two = $one+$one;
#print "$one+$one=$two\n";
#print Value($one),"+",Value($one),"=",Value($two),"\n";
$two = normalize($two);
#print "$one+$one=$two\n";
#print Value($one),"+",Value($one),"=",Value($two),"\n";

print "$two+$two=",$two+$two,"\n";
print Value($two),"+",Value($two),"=",Value($two+$two),"\n";

#print Value(Mul($two,$two)),"\n";
#print Value([[$zero],[$one]]),"\n";

1;
[download]

Anyone who doesn't understand this post should go read about Conway's surreal numbers. This is very, very cool! :-)

UPDATE
Thanks to coreolyn the link should now work.

sub add {
    my( $a, $b, $bit, $cary, $sum ) = ( @{$_[0]}, 1, 0, 0 );
    $sum |= $bit   if  1 & ( $a ^ $b ^ $cary );
    $cary = 1 & ( $a & $b | ( $cary & ($a|$b) ) );
    return $a | $b ? [$a>>1,$b>>1,$bit<<1,$cary,$sum] : $sum;
}
my @args = map {0+$_} (@ARGV,2,2)[0,1];
my $acc = add( [@args] );
$acc = add($acc)   while  ref $acc;
print "add[@args] = $acc\n";
[download]

perl -MFcntl=:flock -e 'print 2+LOCK_EX'
[download]

Or (cheap way)

perl -wle 'print $^W*2**$^W*2'
[download]

Or (Only works if you follow the directions ;-)

#!/usr/bin/perl -w

use strict;

print "Pick an integer between 1 and 3\n";
my $num = <STDIN>;
print "Pick another integer between 1 and 3\n";
$num += <STDIN>;
print "The sum is " . $num;
[download]

Or

perl -wle '%h =  map {(qq{sum}) => $h{'sum'}+=$_ } qw/2 2/; print $h{s
+um}'
[download]

Or (a long version of the above one liner)

#!/usr/bin/perl -w

use strict;

my %foo;
%foo =  map {('sum') => $foo{'sum'}+=$_ } qw/2 2/;
print $foo{sum};
[download]

More later if I have time.

Cheers,
KM

I follow the directions, but it tells me that the sum is 3. Did you mean to write directions that do not allow 1.5 as input?

Haha.. I made the directions more clear.

Cheers,
KM

perl -wle 'print $^W*2**$^W*2'
[download]

That's not 2 + 2, thats 2 squared.
(Ok, I know... the answer is the same... but the route is different.)

Well, speaking as a engineer by training, the program meets spec... where's the problem? <G>

If you wanted flexibility and easy upgrades, you should have made sure that was part of the original program spec.

Ozymandias pries tongue from cheek...

- email Ozymandias

Uh, I thought 2 squared was just a shorthand for 2 + 2, er, or inherently linked or something. Sure, it a ... what's that word, pathological? case but ...

a

*bends down on knee*
Will you marry me? ;)

$_="2+2";
print $_."=".eval;
[download]

How many ways are there?

I'm wondering about the number of solutions as a function of program length. Does the number of solutions / number of possible programs increase or decrease as the length grows?

$,=2+2=>print('The result is ',$/);
[download]

#!/usr/bin/perl -w

use strict;

my $i = 3;
my $j = $i-1;
my $n = $i & $j;

print "$n + $n = ", $n + $n;
[download]

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

use strict;

{
   my $addy = "2 + 2";

   print "Adding $addy = ", eval ($addy), "\n";
}
[download]

OK, there's the challenge:

use Inline C => 'int add(int a, int b) { return a + b; }';
print add(2,2), "\n";
[download]

Hmm. Maybe I should hoist this up as a real snippet. {grin}

-- Randal L. Schwartz, Perl hacker

perl -we "$,=2+2=>print('The result is ',$/)"
perl -we "1while(2+2>++$.);print qq;The result is $.$/;"
perl -we "tie $sum,'_',4;print 'The result is ',$sum,$/;sub _::TIESCAL
+AR{bless[pop],'_'}sub _::FETCH{$_[0][0]=2+2}"
perl -we "my $two=$^W+!''; print 'The result is ',$two + $two,$/"
perl -we "print reverse $/,eval(join'+',(2)x2),'The result is '"
perl -we "$_=qq/The result is 2+2\n/=>y/2\+2/4/s,print"
[download]

Hey, it meets spec too!

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

use strict;
use Lingua::EN::Numbers qw(American);

{
   my $v++;
   my $t=new Lingua::EN::Numbers(++$v);
   my $f=new Lingua::EN::Numbers($v*$v);
   print sprintf "Adding %s + %s = %s\n",$t->get_string,$t->get_string
+,$f->get_string;
}
[download]

my $four;
my @array = split "", (2 x 2);


sub the {
my $four = shift;
return "two plus two is: $four"}

sub answer {
print shift}

sub result {
return $four}

foreach my $two (@array) {
$four += $two
}

answer the result;
[download]

/jeorgen

1. ++$_ && $_++ && print eval() + eval();
2. $_++; print eval() + eval() unless ( $_ + 1 == $_++ );
3. for (2..2){$_ = $_ + $_ and print;}
4. $a = 2; print "$a + $a = ", $$b + $$b; BEGIN{ $b = \$a }
5. my $num = 2; $num =~ s/(2)/$1 + $1/gxe; print $num;

print "Adding 2 + 2 =".(2+2)."\n";
[download]

"cRaZy is co01, but sometimes cRaZy is cRaZy".
                                                      - crazyinsomniac

sub S{ return [shift]; }
sub P{ return (shift)->[0]; }
sub add{
   my($x,$y) = @_;
   return $x unless $y;
   return add(S($x),P($y));
}
sub arabic{
  my $x = shift;
  return 0 unless $x;
  return 1+arabic(P($x));
}
$y=$x = S S;
print arabic($x),"+",arabic($y),"=",arabic(add($x,$y)),"\n";
[download]

my @stack;
my $acc = 0;

sub PUSH() { push(@stack, $acc); }
sub POP()  { pop(@stack);        }
sub INC()  { $acc++;             }
sub ADD()  { $acc += POP;        }

INC;
INC;
PUSH;
ADD;

print($acc, "\n");
[download]

The parent assumed the accumulator was initially zero. That's not likely in a real-life scenario, so this removes the assumption:

my @stack;
my $acc = rand;

sub PUSH() { push(@stack, $acc); }
sub POP()  { pop(@stack);        }
sub INC()  { $acc++;             }
sub ADD()  { $acc += POP;        }
sub SUB()  { $acc -= POP;        }

PUSH;
SUB;
INC;
INC;
PUSH;
ADD;

print("$acc\n");
[download]

unless( my $pid= open( STDOUT, "|-"))
  { while( <STDIN>)
      { chomp; s/(.*)/qq{$1}. "= " . eval($1) ."\n"/e; print; } 
    exit;
  } 
   
     
print "2+2\n";
[download]

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

use strict;

{
   my $v=2;
   print "Adding $v + $v = ", `echo $v $v + p | dc`;
}
[download]

@list=(1,2,3);

if ($list[1] eq '2' && $list[2]++ eq '3') {
    print "The answer is $list[2]\n";
    } else {
    print "Insufficiently large value of 2\n";
}
[download]

A very creative solution :)
Be sure to check out Roman if you didn't know it already. It can convert roman numbers both ways, and checks if your roman input is valid.



use Roman;
$calc = "II + II";
$calc =~ s/([MDCLXVI]+)/isroman($1) ? arabic($1) : $1/;
print eval $calc;
[download]

2;0 juerd@ouranos:~$ perl -e'undef christmas'
Segmentation fault
2;139 juerd@ouranos:~$
[download]

Thanks for the review and the suggestion.

I knew Roman was available, but it didn't feel right to use it for this. I felt it was more in the spirit of the thread to go overboard and develop the needed tools specifically for the node. I'm actually a bit surprised it took someone posting a hand-crafted Roman to Arabic numeral conversion before someone gave an example using the module. It was one of the first twists on the problem that popped into my deranged mind.

It's a bit late to ask, but did you enter this to the Fonalty Perl Golf Challenge?

I didn't know about the contest until just now. Thanks for asking, though. I'm enjoying looking at the site.


Christopher E. Stith

$lterm = 2;                      # lterm = 2
$rterm = 2;                      # rterm = 2

$#add = $lterm; pop(@add);       # add = lterm
push(@acc, @add);                # acc += add

$#add = $rterm; pop(@add);       # add = rterm
push(@acc, @add);                # acc += add

push(@acc, 1); $sum = $#acc;     # sum = acc
print("$sum\n");
[download]

It must be fast, since the addition is done by push, which is written in C! ;)

use Language::Haskell;
print Language::Haskell->new->eval('foldr (+) 0 [2,2]');
[download]

(Hey, I saw somebody do it with C, so I can do it in Haskell)

use Language::Functional qw(foldr);
print foldr { $_[0] + $_[1] } 0, [2,2];
[download]

    -Bryan

say 2+2;
[download]

P.S. I've been waiting so long to put those Monty Pythons' words on the stage, I now I finally got it :-)

my $two = sub { my($f,$x) = @_; $f->($f->($x)); };

sub add {
  my($m,$n) = @_;
  sub { my($f,$x) = @_; $m->($f, $n->($f, $x)) };
}

sub decode { my($n) = @_; $n->( sub{$_[0]+1}, 0 ); }

print decode( add($two, $two) ), $/;
[download]

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

sub add {
        my ($first, @rest) = @_;

        if (!defined $first) {
                0;
        }
        else {
                die "operand may not be negative!" unless $first >= 0;
                if ($first == 0) {
                        add(@rest);
                }
                else {
                        1 + add($first-1, @rest);
                }
        }
}

sub print_add {
        print join(" + ", @_), " = ", add(@_), "\n";
}

print_add 2,2;
print_add 2,2,2;
print_add 4,8,12;
[download]

root@swill ~/PerlMonks
$ ./adder_1.pl
2 + 2 = 4
2 + 2 + 2 = 6
4 + 8 + 12 = 24
[download]

sub add {
        my $accumulator = 0;
        for my $op (@_) {
                for my $i (1 .. $op) {
                        $accumulator = $accumulator+1;
                }
        }
        $accumulator;
}
[download]

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

use Benchmark qw(timethese cmpthese);

sub add_rec {
        my ($first, @rest) = @_;


        if (!defined $first) {
                0;
        }
        else {
                die "operand may not be negative!" unless $first >= 0;
                if ($first == 0) {
                        add_rec(@rest);
                }
                else {
                        1 + add_rec($first-1, @rest);
                }
        }
}

sub add_iter {
        my $accumulator = 0;
        for my $op (@_) {
                for my $i (1 .. $op) {
                        $accumulator = $accumulator+1;
                }
        }
        $accumulator;
}

cmpthese(100000, {
        'Recursive' => sub { 2 == add_rec(2,2); },
        'Iterative' => sub { 2 == add_iter(2,2); }
});
[download]

$ ./adder_bench.pl
              Rate Recursive Iterative
Recursive  79051/s        --      -48%
Iterative 152207/s       93%        --
[download]

The iterative version is *much* faster than the recursive one. I'm certain that this new algorithm for adding should be used in all future programs, as the iterative version is better both in speed (it's nearly twice as fast!) as well as consuming far less memory than it's recursive counterpart when adding large numbers.

--roboticus

Awaiting his Turing prize for this valuable discovery...

Look ma, no numbers:

$|++;
my $two = $| + $|;

print "$two + $two = ", $two + $two;
[download]

Prints:

2 + 2 = 4
[download]

That's really an interesting way of getting 1, not 2. Other interesting ways to get 1:

my $one = !@!;
my $one = !!$];
my $one = /.*/;                # Side-effect: Changes $1, etc
my $one = $$/$$;
my $one = ()=$$;
my $one = @{[$$]};
my $one = 'a'^'P';             # Character set specific.
my $one = ord('b')-ord('a');   # Character set specific.
[download]

And 2:

my $two = $one+$one;
my $two = $one<<$one;
my $two = ()=qw(a a);
my $two = @{[ qw(a a) ]};
my $two = ()=/(.*)(.*)/;       # Side-effect: Changes $1, etc
my $two = 'a'^'S';             # Character set specific.
my $two = ord('c')-ord('a');   # Character set specific.
[download]

None of these have side effects unless otherwise noted.
All of these run under use strict;.
All of these run silently under use warnings;.

There's also length $=.

I also have a table for all numbers: Re: Re: exactly 390 bytes. It says log hex c.

More (although not as neat):

my $one = !$|;
my $one = cos;        # Given that $_ == 0.
my $one = cos $|;
my $one = cos atan2 $|, cos;
my $one = sin atan2 sin, $|;
my $one = length $/;  # Note: possibly 2 under Windows or DOS. 
my $one = length $";
my $one = length $;;
my $one = length $^L;
my $one = $^T/$^T;
my $one = @ARGV >= 0;
my $one = grep //, ($_);
my $one = !undef;
# Note: the following may be Unix-only. Will not work if run as root,
# as root's UID and GID are (always?) zero.
my $one = $</$<;      # User ID.
my $one = $>/$>;      # Effective user ID.
my $one = $(/$(;      # (Space-separated list of) group ID(s).
my $one = $)/$);      # (Space-separated list of) effective group ID(s
+).
[download]

Ways to get 2:

my $two = length $:;
my $two = $^F;        # Note: system-dependent.
[download]

--
print "Just Another Perl Adept\n";

print "2 + 2 = ${ \(2 + 2) }\n";
[download]

print map { /....(.)/ and $++$+ } "@{[0..9]}";
[download]

my @c = ( my @a = each %ENV, my @b = each %SIG );

print @a . " + "
    . @b . " = "
    . @c . "\n";
[download]

print 2 << 1;
[download]

Yet another look at it...

#!/usr/bin/perl

use warnings;
use strict;

use LWP::Simple;
use HTML::Parser;

# 'print' URL to save a smidge of bandwidth
my $url = "http://perlmonks.org/?displaytype=print;node_id=31832";
if (my $page = get($url)) {
    my $parser = HTML::Parser->new( api_version => 3 );
    $parser->handler( start => sub {
            return if shift ne 'title';
            my $self = shift;
            $self->handler( text => sub {
                    my $title = shift;
                    # Only ready for 4-function math with integers
                    if ($title =~ m#((\d+) (\+) (\d+))#) {
                        print "$1 = ", eval("$2 $3 $4"), "\n";
                    }
                }, 'dtext'
            );
            $self->handler( end => sub {
                    shift->eof if shift eq 'title' ;
                }, 'tagname,self'
            );
        },
        'tagname,self'
    );

    $parser->parse($page);
}
else {
    print "Unable to fetch '$url' for some reason.\n";
}
[download]

I chose to leave the database layer out of it this time.

Funny, parsing out the code from the HTML. But you could just ask the code from the server directly, such as seen in Usually J.A.P.H. or Re^2: Short quines.

$result = 2 + 2;
print "the answer is $result\n";
[download]

Er.. really? global $result? You don't need that variable:

print "the answer is @{[2+2]}\n";
[download]

Works under strict and warnings.

_($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /
                              /\_¯/(q    /
----------------------------  \__(m.====·.(_("always off the crowd"))."·
");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}

It often strikes me as a little strange (or unfortunate) to use array ref/deref for this. The scalar version is only one character longer:

print "the answer is ${\(2+2)}\n";
[download]

A word spoken in Mind will reach its own level, in the objective world, by its own weight

The scalar version is only one character longer

golfer habits...

--shmem
But I might be parling heck.

_($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /
                              /\_¯/(q    /
----------------------------  \__(m.====·.(_("always off the crowd"))."·
");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}

This one appears to suffer from an off-by-one bug...

use Modern::Perl;
use List::Util qw(first);
use LWP::Simple qw(get);

say for
    first  {/^2\+2/}
    split m{\r?\n|\r},
    get   q{http://gutenberg.net.au/ebooks01/0100021.txt}
[download]

(And monks outside of the Australian branch of the monastery need to be aware of potential copyright issues.)