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;