package Rational;
use Carp qw(croak);
use overload('+' => \&op_add,
            '+=' => \&op_addeq,
            '++' => \&op_inc,
             '*' => \&op_mul,
            '*=' => \&op_muleq,
             '-' => \&op_sutr,
            '-=' => \&op_sutreq,
            '--' => \&op_dec,
             '/' => \&op_div,
            '/=' => \&op_diveq,
             '>' => \&op_gt,
             '<' => \&op_lt,
            '>=' => \&op_ge,
            '<=' => \&op_le,
            '==' => \&op_eq,
            '!=' => \&op_ne,
           'neg' => \&op_neg,
             '=' => \&op_assign,
           q("") => \&stringify,
           q(0+) => \&numify,
          'bool' => \&boolify);

my $r_1 = Rational->new(1,1);
my $r_0 = Rational->new(0,1);

sub new
{
    my $invocant = shift;
    my $class    = ref($invocant) || $invocant;
    my $self     = [];
    if(ref($invocant))
    {
        $self->[0] = $invocant->num();
        $self->[1] = $invocant->den();
    }
    else
    {
        $self->[0] = shift || 0;
        $self->[1] = shift || 1;
    }
    normalize($self);
    bless ($self, $class);
    return $self;
}

sub num
{
    my $self = shift;
    $self->[0];
}

sub den
{
    my $self = shift;
    $self->[1];
}

sub set_num
{
    my $self = shift;
    $self->[0] = shift;
    normalize($self);
}

sub set_den
{
    my $self = shift;
    $self->[1] = shift;
    normalize($self);
}

sub negate
{
    my $self = shift;
    $self->[0] = -$self->[0];
    return $self;
}

sub invert
{
    my $self = shift;
    ($self->[1],$self->[0]) = ($self->[0],$self->[1]);
    if($self->[1] == 0)
    {
        croak "Zero denominator";
    }
    elsif($self->[1] < 0)
    {
        $self->[0] = - $self->[0];
        $self->[1] = - $self->[1];
    }
}

sub normalize
{
    my $self = shift;
    if ($self->[1] == 0)
    {
        croak("Zero denominator");
    }
    elsif($self->[1] < 0)
    {
        $self->[0] = -$self->[0];
        $self->[1] = -$self->[1];
    }

    {
        use integer;
        my($a,$b) = ($self->[0],$self->[1]); 
        while($b)
        {
            my $r = $a % $b;
            $r += $b if $r < 0;
            $a = $b;
            $b = $r;
        }
    }

    if($r)
    {
        $self->[0] /= $r;
        $self->[1] /= $r;
    }
}

sub op_add
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    add($x,$y,$r);
    return $r;
}

sub op_addeq
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    add($x,$y,$r);
    return $r;
}

sub op_inc
{
    my $x = shift;
    add($x,$r_1,$x);
}

sub op_mul
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    mul($x,$y,$r);
    return $r;
}

sub op_muleq
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    mul($x,$y,$r);
    return $r;
}

sub op_sutr
{
    my($x,$y,$swap) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    sutr($x,$y,$r);
    $r = -$r if $swap;
    return $r;
}

sub op_sutreq
{
    my($x,$y,$swap) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    sutr($x,$y,$r);
    $r = -$r if $swap;
    return $r;
}

sub op_dec
{
    my $x = shift;
    sutr($x,$r_1,$x);
}

sub op_div
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    div($x,$y,$r);
    return $r;
}

sub op_diveq
{
    my($x,$y) = @_;
    unless(ref($y))
    {
        $y = Rational->new($y);
    }
    my $r = Rational->new();
    div($x,$y,$r);
    return $r;
}

sub op_neg
{
    my $self = shift;
    return $self->negate();
}

sub op_assign
{
    my $self = shift;
    return $self->new();
}

sub op_gt
{
    my($x,$y) = @_;
    return compare($x,$y) > 0;
}

sub op_lt
{
    my($x,$y) = @_;
    return compare($x,$y) < 0;
}

sub op_ge
{
    my($x,$y) = @_;
    return compare($x,$y) >= 0;
}

sub op_le
{
    my($x,$y) = @_;
    return compare($x,$y) <= 0;
}

sub op_eq
{
    my($x,$y) = @_;
    return compare($x,$y) == 0;
}

sub op_ne
{
    my($x,$y) = @_;
    return compare($x,$y) != 0;
}

sub stringify
{
    my $self = shift;
    return "$self->[0]/$self->[1]";
}

sub numify
{
    my $self = shift;
    return $self->[0]/$self->[1];
}

sub boolify
{
    my $self = shift;
    return $self->[0];
}

#   takes three args
#   Arg0: Rational X
#   Arg1: Rational Y
#   Arg2: Return Rational
sub add
{
    my($x,$y,$r) = @_;

    $r->[0] = $x->[0] * $y->[1];
    $r->[1] = $x->[1] * $y->[0];
    $r->[0] = $r->[0] + $r->[1];
    $r->[1] = $x->[1] * $y->[1];
    $r->normalize();
}

#   takes three args
#   Arg0: Rational X
#   Arg1: Rational Y
#   Arg2: Return Rational
sub mul
{
    my($x,$y,$r) = @_;

    $r->[0] = $x->[0] * $y->[0];
    $r->[1] = $x->[1] * $y->[1];
    $r->normalize();
}

#   takes three args
#   Arg0: Rational X
#   Arg1: Rational Y
#   Arg2: Return Rational
sub sutr
{
    my($x,$y,$r) = @_;

    $r->[0] = $x->[0] * $y->[1];
    $r->[1] = $x->[1] * $y->[0];
    $r->[0] = $r->[0] - $r->[1];
    $r->[1] = $x->[1] * $y->[1];
    $r->normalize();
}

#   takes three args
#   Arg0: Rational X
#   Arg1: Rational Y
#   Arg2: Return Rational
sub div
{
    my($x,$y,$r) = @_;

    $r->[0] = $x->[0] * $y->[1];
    $r->[1] = $x->[1] * $y->[0];
    $r->normalize();
}

#   Takes 2 Rationals
#   returns 1 if $x > $y
#   returns 0 if $x == $y
#   returns -1 if $x < $y
sub compare
{
   my $x = shift;
   my $y = shift;
   return(($x->[0] * $y->[1]) <=> ($y->[0] * $x->[1]));
}

1;
[download]

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.