Ada 95 :: x35_rat.ada

with Text_io; use  Text_io;
package Pack_types is
  type Integer is range -2_000_000_000 .. 2_000_000_000;
  procedure put( i:in Integer );
end Pack_types;

with Text_io; use  Text_io;
package body Pack_types is
  package Class_integer_io is new Text_io.Integer_io( Integer );
  procedure put( i:in Integer ) is
  begin
    put("[Overloaded]");
    Class_integer_io.put( i );
  end put;
end Pack_types;

package Class_rational is
  type Rational is private;

  function "+" ( f:in Rational; s:in Rational ) return Rational;
  function "-" ( f:in Rational; s:in Rational ) return Rational;
  function "*" ( f:in Rational; s:in Rational ) return Rational;
  function "/" ( f:in Rational; s:in Rational ) return Rational;

  function rat_const( f:in Integer;
                      s:in Integer:=1 ) return Rational;
  procedure put( the:in Rational );
private
  function sign( the:in Rational ) return Rational;
  function simplify( the:in Rational ) return Rational;
  type Rational is record
    above : Integer := 0;      -- Numerator
    below : Integer := 1;      -- Denominator
  end record;
end Class_rational;

with Simple_io; use Simple_io;
package body Class_rational is


  function "+" (f:in Rational; s:in Rational) return Rational is
    res : Rational;
  begin
    res.below := f.below * s.below;
    res.above := f.above * s.below + s.above * f.below;
    return simplify(res);
  end "+";

  function "-" (f:in Rational; s:in Rational) return Rational is
    res : Rational;
  begin
    res.below := f.below * s.below;
    res.above := f.above * s.below - s.above * f.below;
    return simplify(res);
  end "-";

  function "*" (f:in Rational; s:in Rational) return Rational is
    res : Rational;
  begin
    res.above := f.above * s.above;
    res.below := f.below * s.below;
    return simplify(res);
  end "*";

  function "/" (f:in Rational; s:in Rational) return Rational is
    res : Rational;
  begin
    res.above := f.above * s.below;
    res.below := f.below * s.above;
    return simplify(res);
  end "/";

  function rat_const( f:in Integer; s:in Integer:=1 ) return Rational is
  begin
    if f = 0 then
      return Rational'(0,1);
    else
      return simplify( sign( Rational'( f, s ) ) );
    end if;
  end rat_const;

  procedure put( the:in Rational ) is
    above : Integer := the.above;
    below : Integer := the.below;
  begin
    if above = 0 then                           -- Rational 0
      put( "0" );
    else
      if above < 0 then
        put("-"); above := -above;              --  make +ve
      end if;
      if above >= below then                    -- Whole number
        put( above/below, width=>1 ); put(" ");
        above := above rem below;               -- Fraction
      end if;
      if above /= 0 then
        put( above, width=>1 ); put( "/" );
        put( below, width=>1 );                 -- Fraction
      end if;
    end if;
  end put;

  function sign( the:in Rational ) return Rational is
  begin
    if the.below >= 0 then            --   -a/b or a/b
      return the;
    else                              --   a/-b or -a/-b
      return Rational'( -the.above, -the.below );
    end if;
  end sign;

  function simplify( the:in Rational ) return Rational is
    res: Rational := the;
    d  : Positive;                    -- Divisor to reduce with
  begin
    if res.below = 0 then             -- Invalid treat as 0
      res.above := 0; res.below := 1;
    end if;
    d := 2;                           -- Divide by 2, 3, 4 ...
    while d < res.below loop
      while res.below rem d = 0 and then res.above rem d = 0 loop
        res.above := res.above / d;
        res.below := res.below / d;
      end loop;
      d := d + 1;
    end loop;
    return res;
  end simplify;

end Class_rational;

package Pack_procedures is
  procedure main1;
  procedure main2;
  procedure main3;
  procedure main4;
  procedure main5;
end Pack_procedures;

with Simple_io, Class_rational;
use  Simple_io, Class_rational;
package body Pack_procedures is

procedure main1 is
  a,b : Rational;
begin
  a := rat_const( 1, 2 );
  b := rat_const( 1, 3 );

  put( "a     = " ); put( a );   new_line;
  put( "b     = " ); put( b );   new_line;
  put( "a + b = " ); put( a+b ); new_line;
  put( "a - b = " ); put( a-b ); new_line;
  put( "b - a = " ); put( b-a ); new_line;
  put( "a * b = " ); put( a*b ); new_line;
  put( "a / b = " ); put( a/b ); new_line;
end main1;

procedure main2 is
  a,b : Rational;
begin
  a := rat_const(1, 2);
  b := rat_const(1, 3);

  put( "a     = " ); put( a ); put(" <1/2> "); new_line;
  put( "b     = " ); put( b ); put("  <1/3> "); new_line;
  put( "a + b = " ); put( a+b ); put(" <5/6> "); new_line;
  put( "a - b = " ); put( a-b ); put(" <1/6> "); new_line;
  put( "b - a = " ); put( b-a ); put(" <-1/6> "); new_line;
  put( "a * b = " ); put( a*b ); put(" <1/6> "); new_line;
  put( "a / b = " ); put( a/b ); put(" <1 1/2> "); new_line;

  new_line;
  a := rat_const(3, 2);
  b := rat_const(4, 5);
  put( "a     = " ); put( a ); put(" <3/2> "); new_line;
  put( "b     = " ); put( b ); put(" <4/5> "); new_line;
  put( "a + b = " ); put( a+b ); put(" <2 3/10> "); new_line;
  put( "a - b = " ); put( a-b ); put(" <7/10> "); new_line;
  put( "b - a = " ); put( b-a ); put(" <-7/10> "); new_line;
  put( "a * b = " ); put( a*b ); put(" <1 1/5> "); new_line;
  put( "a / b = " ); put( a/b ); put(" <1 7/8> "); new_line;
end main2;

procedure main3 is
  a : Rational;
begin
  -- put( 8/16 ) is ambiguous;
  new_line;
  put( " 0, 0      = " ); a := rat_const(0, 0);   put( a ); new_line;
  put( " 0, 5      = " ); a := rat_const(0, 5);   put( a ); new_line;
  put( " 5, 0      = " ); a := rat_const(5, 0);   put( a ); new_line;
  put( " 8, 16     = " ); a := rat_const(8, 16);  put( a ); new_line;
  put( " 8, 8      = " ); a := rat_const(8, 8);   put( a ); new_line;
  put( " -17, 8    = " ); a := rat_const(-17, 8); put( a ); new_line;
  put( " -17, -8   = " ); a := rat_const(-17, -8);put( a ); new_line;
  put( " 17, -8    = " ); a := rat_const(17, -8); put( a ); new_line;
  put( " 7, 97     = " ); a := rat_const(7, 97);  put( a ); new_line;
  put( " 40, 20    = " ); a := rat_const(40, 20); put( a ); new_line;
  put( " 20, 40    = " ); a := rat_const(20, 40); put( a ); new_line;
  put( " 648, 972  = " ); a := rat_const(648,972);put( a ); new_line;
end main3;

procedure main4 is
  a : Rational;
begin
  a := rat_const(0, 0);
  for i in 1 .. 5 loop
    a := a + rat_const(1,i);
  end loop;
  put("Sum of 1/1 + 1/2 + ... 1/5 is "); put( a ); new_line;
end main4;

procedure main5 is
  a : Rational;
  UP_TO : CONSTANT := 7;
begin
  a := rat_const(1, 1);
  for i in 1 .. UP_TO loop
    a := a + rat_const(1, i);
  end loop;
  for i in reverse 1 .. UP_TO loop
    a := a - rat_const(1, i);
  end loop;
  put("Sum  check answer should be 1 <=> "); put( a ); new_line;
  a := rat_const(1);
  for i in 1 .. UP_TO loop
    a := a * rat_const(1, i);
  end loop;
  for i in reverse 1 .. UP_TO loop
    a := a / rat_const(1,i);
  end loop;
  put("Mult check answer should be 1 <=> "); put( a ); new_line;
end main5;

end Pack_procedures;

with Simple_io, Class_rational;
use  type Class_rational.Rational;
procedure main6 is
  a,b : Class_rational.Rational;
begin
  a := Class_rational.rat_const( 1, 2 );
  b := Class_rational.rat_const( 1, 3 );

  Simple_io.put( "a + b = " ); Class_rational.put( a+b );
  Simple_io.new_line;
end main6;

with Text_io, Pack_procedures, main6; 
use  Text_io, Pack_procedures;
procedure main is
begin
   put("Example 1"); new_line; main1;
   put("Example 2"); new_line; main2;
   put("Example 3"); new_line; main3;
   put("Example 4"); new_line; main4;
   put("Example 5"); new_line; main5;
   put("Example 6"); new_line; main6;
end main;



© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]