Return to multprec_floating_numbers_io.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Numbers

Import the second public release of PHCpack.

OKed by Jan Verschelde.

with integer_io;                         use integer_io;
with Characters_and_Numbers;             use Characters_and_Numbers;
with Multprec_Natural_Numbers;           use Multprec_Natural_Numbers;
with Multprec_Natural_Numbers_io;        use Multprec_Natural_Numbers_io;
with Multprec_Integer_Numbers;           use Multprec_Integer_Numbers;
with Multprec_Integer_Numbers_io;        use Multprec_Integer_Numbers_io;

package body Multprec_Floating_Numbers_io is

-- NOTE :
--   No exceptions are raised when the input format is incorrect.

-- AUXILIARIES FOR OUTPUT :

  function Head ( i : Integer_Number ) return integer is

  -- DESCRIPTION :
  --   Returns the leading decimal number of the i, can be negative.

    res : integer;
    wrk : Integer_Number;

  begin
    if Multprec_Integer_Numbers.Positive(i)
     then Copy(i,wrk);
          while wrk > 9 loop
            Div(wrk,10);
          end loop;
          res := Create(wrk);
          Clear(wrk);
     elsif Negative(i)
         then Copy(i,wrk);
              while wrk < -9 loop
                Div(wrk,10);
              end loop;
              res := Create(wrk);
              Clear(wrk);
         else res := 0;
    end if;
    return res;
  end Head;

  function Tail ( i : Integer_Number ) return Natural_Number is

  -- DESCRIPTION :
  --   Returns the decimals after the leading decimal of i.
  --   The number on return has the same size as i.

    res : Natural_Number;
    res_rep : Array_of_Naturals(0..Size(i));
    acc,wrk,prod : Integer_Number;
    cnt : natural := 0;
    r : integer;

  begin
    if Multprec_Integer_Numbers.Positive(i)
     then Copy(i,wrk);
          while wrk > 9 loop
            cnt := cnt+1;
            Div(wrk,10,r);
            if r /= 0
             then prod := Create(r);
                  for i in 1..cnt-1 loop
                    Mul(prod,10);
                  end loop;
                  Add(acc,prod);
                  Clear(prod);
            end if;
          end loop;
          Clear(wrk);
     elsif Negative(i)
         then Copy(i,wrk);
              while wrk < -9 loop
                cnt := cnt+1;
                Div(wrk,10,r);
                if r /= 0
                 then prod := Create(r);
                      for i in 1..cnt-1 loop
                        Mul(prod,10);
                      end loop;
                      Add(acc,prod);
                      Clear(prod);
                end if;
              end loop;
              Clear(wrk);
         else acc := Create(0);
    end if;
    for i in res_rep'range loop
      res_rep(i) := Coefficient(acc,i);
    end loop;
    Clear(acc);
    res := Create(res_rep);
    return res;
  end Tail;

  procedure Write_Number ( file : in file_type; n : in natural;
                           cnt : in out natural ) is
  begin
    if n < 10
     then put(file,n,1);
          cnt := cnt - 1;
     else Write_Number(file,n/10,cnt);
          if cnt > 0
           then put(file,n mod 10,1);
                cnt := cnt - 1;
          end if;
    end if;
  end Write_Number;

  procedure Write_Block ( file : in file_type; n : in natural;
                          cnt : in out natural ) is

  -- DESCRIPTION :
  --   This procedure writes the leading zeros, not exceeding cnt.

    expo : constant natural := Multprec_Natural_Numbers.Exponent;
    nbz,acc : natural := 0;

  begin
    if n = 0
     then for i in 1..expo loop
            put(file,"0");
            cnt := cnt - 1;
            exit when (cnt = 0);
          end loop;
     else acc := 10;
          for i in 1..(expo-1) loop
            if n < acc
             then nbz := expo-i;
             else acc := acc*10;
            end if;
            exit when (nbz /= 0);
          end loop;
          for i in 1..nbz loop
            put(file,"0");
            cnt := cnt - 1;
            exit when (cnt = 0);
          end loop;
          if cnt > 0
           then Write_Number(file,n,cnt);
          end if;
    end if;
  end Write_Block;

  procedure Write_Zero_Block ( file : in file_type; cnt : in out natural ) is

  -- DESCRIPTION :
  --   Writes as many zeros as there are in one block, not exceeding cnt.

    expo : constant natural := Multprec_Natural_Numbers.Exponent;

  begin
    for i in 1..expo loop
      put(file,"0");
      cnt := cnt - 1;
      exit when (cnt = 0);
    end loop;
  end Write_Zero_Block;

  procedure put ( file : in file_type;
                  n : in Natural_Number; dp : in natural ) is

  -- DESCRIPTION :
  --   Writes the natural number n using dp decimal places.
  --   If n is too long, then the leading dp decimal places will be written,
  --   otherwise zeros will be added.

    deciplan : natural := Decimal_Places(n);
    first : boolean;
    coeff,cnt : natural;

  begin
    if deciplan <= dp
     then put(file,n);
          for i in 1..(dp-deciplan) loop
            put(file,"0");
          end loop;
     else first := true;
          cnt := dp;
          for i in reverse 0..Size(n) loop
            coeff := Coefficient(n,i);
            if coeff /= 0
             then if first
                   then Write_Number(file,coeff,cnt);
                        first := false;
                   else Write_Block(file,coeff,cnt);
                  end if;
             elsif not first
                 then Write_Zero_Block(file,cnt);
              -- else skip leading zeros in representation
            end if;
            exit when (cnt = 0);
          end loop;
    end if;
  end put;

-- INPUT ROUTINES :

  procedure get ( f : in out Floating_Number ) is
  begin
    get(Standard_Input,f);
  end get;

  procedure get ( file : in file_type; f : in out Floating_Number ) is

    fraction,decifrac,exponent : Integer_Number;
    shifexpo : integer := 0;
    deciplac : natural;
    c : character := ' ';

  begin
    get(file,c,fraction);
    if c = '.'
     then get(file,c);
          while c = '0' loop
            Mul(fraction,10);
            shifexpo := shifexpo - 1;
            exit when End_of_Line(file);
            get(file,c);
          end loop;
          if Convert(c) < 10
           then get(file,c,decifrac);
                deciplac := Decimal_Places(decifrac);
                shifexpo := shifexpo - deciplac;
                for i in 1..deciplac loop
                  Mul(fraction,10);
                end loop;
                if Negative(fraction)
                 then Sub(fraction,decifrac);
                 else Add(fraction,decifrac);
                end if;
          end if;
    end if;
    if c = 'E'
     then get(file,exponent);
          if Equal(fraction,0)
           then Clear(exponent);
                exponent := Create(0);
           elsif shifexpo /= 0
               then Add(exponent,shifexpo);
          end if;
     else if Equal(fraction,0)
           then exponent := Create(0);
           else exponent := Create(shifexpo);
          end if;
    end if;
    f := Create(fraction,exponent);
  end get;

-- OUTPUT ROUTINES :

  procedure put ( f : in Floating_Number ) is
  begin
    put(Standard_Output,f);
  end put;

  procedure put ( file : in file_type; f : in Floating_Number ) is

    frac,expo : Integer_Number;
    tafr : Natural_Number;
    decifrac,decitafr : natural;
    hd : integer;

  begin
    Copy(Fraction(f),frac);  
    if Equal(frac,0)
     then put(file,"0");
     else hd := Head(frac);
          put(file,hd,1); put(file,".");
          tafr := Tail(Fraction(f));
          decifrac := Decimal_Places(frac);
          decitafr := Decimal_Places(tafr);
          if not Equal(tafr,0)
           then for i in 1..decifrac-decitafr-1 loop
                  put(file,"0");
                end loop;
                put(file,tafr);
           else put(file,"0");
          end if;
          expo := Exponent(f) + (decifrac - 1);
          if not Equal(expo,0)
           then put(file,"E");
                if expo > 0
                 then put(file,"+");
                end if;
                put(file,expo);
          end if;
          Clear(tafr);
          Clear(expo);
    end if;
    Clear(frac);
  end put;

  procedure put ( f : in Floating_Number; fore,aft,exp : in natural ) is
  begin
    put(Standard_Output,f,fore,aft,exp);
  end put;

  procedure put ( file : in file_type;
                  f : in Floating_Number; fore,aft,exp : in natural ) is

    frac,expo : Integer_Number;
    tafr : Natural_Number;
    decifrac,decitafr,deciexpo,cnt : natural;
    hd : integer;

  begin
    Copy(Fraction(f),frac);
    if Equal(frac,0)
     then for i in 1..(fore-1) loop
            put(file," ");
          end loop;
          put(file,"0.");
          for i in 1..aft loop
            put(file,"0");
          end loop;
          put(file,"E+");
          for i in 1..(exp-1) loop
            put(file,"0");
          end loop;
     else hd := Head(frac);
          if hd > 0
           then for i in 1..(fore-1) loop
                  put(file," ");
                end loop;
           else for i in 1..(fore-2) loop
                  put(file," ");
                end loop;
          end if;
          put(file,hd,1); put(file,".");
          tafr := Tail(Fraction(f));
          decifrac := Decimal_Places(frac);
          decitafr := Decimal_Places(tafr);
          if Equal(tafr,0)
           then for i in 1..aft loop
                  put(file,"0");
                end loop;
           else cnt := aft;
                for i in 1..decifrac-decitafr-1 loop
                  put(file,"0");
                  cnt := cnt-1;
                  exit when (cnt = 0);
                end loop;
                if cnt /= 0
                 then put(file,tafr,cnt);
                end if;
          end if;
          expo := Exponent(f) + (decifrac - 1);
          deciexpo := Decimal_Places(expo);
          put(file,"E");
          if Equal(expo,0)
           then put(file,"+");
                for i in 1..(exp-1) loop
                  put(file,"0");
                end loop;
           else if expo > 0
                 then put(file,"+");
                 else put(file,"-");
                end if;
                for i in 1..(exp-deciexpo-1) loop
                  put(file,"0");
                end loop;
                put(file,Unsigned(expo));
          end if;
          Clear(tafr);
          Clear(expo);
    end if;
    Clear(frac);
  end put;

  procedure put ( f : in Floating_Number; dp : in natural ) is
  begin
    put(f,dp,dp,dp);
  end put;

  procedure put ( file : in file_type;
                  f : in Floating_Number; dp : in natural ) is
  begin
    put(file,f,dp,dp,dp);
  end put;

end Multprec_Floating_Numbers_io;