with Ada.Command_Line, Globals, Strings;
use Globals;

pragma Elaborate_All (Ada.Command_Line,Globals,Strings);
pragma Optimize (Off);

package body FltStr is

  package Txt_IO renames Ada.Text_IO;

  procedure ValHex(N: in String; R: in out Flt; Rounded: out Boolean) is
    use Strings;
    NHex: constant Integer := 1+Flt'Machine_Mantissa/4;
    L,D,D1,DL,E1,E2,Ed1,Es2,Ms: Integer := 0;
  begin
    R := Flt(0);
    for K in N'Range loop
      if N(K)=' ' then
        null;
      elsif N(K)='+' then
        if Ms=0 then Ms := 1; else Es2 := 1; end if;
      elsif N(K)='-' then
        if Ms=0 then Ms := -1; else Es2 := -1; end if;
      elsif Es2=0 then
        if Ms=0 then Ms := 1; end if;
        if N(K)='.' then
          Ed1 := -1;
        else
          L := L+1;
          D := Val(N(K),15);
          if L <= NHex then
            if L=1 then D1 := D; elsif L=NHex then DL := D; end if;
            R := Flt(16)*R+Flt(D);
            E1 := E1+Ed1;
          elsif D>0 then
            DL := 31;
          end if;
        end if;
      else
        E2 := 16*E2+Val(N(K),15);
      end if;
    end loop;
    R := Flt(Ms)*Flt'Scaling(R,4*(E1+Es2*E2));
    Rounded := (Strip0(16*D1+DL,2) >= 16);
    if Rounded and then R=0.0 then
      Show0(N);
      raise Sorry with "FltStr.ValHex: should not happen";
    end if;
  end ValHex;

  function ValHex(N: String) return Flt is
    R: Flt := Flt(0);
  begin
    ValHex(N,R,Rounded_Last);
    return R;
  end ValHex;

  function FltCompose(R: in Flt; E: in Integer) return Flt is
    --- workaround for a bug in Aonix ObjectAda 8.2
  begin
    return Flt'Compose(Flt'Fraction(R),E);
  end FltCompose;

  function HexStr(R: Flt; Digs: Natural := 0) return String is
    use Strings;
    NHex: constant Integer := 1+Flt'Machine_Mantissa/4;
    NMax: Integer;
  begin
    Rounded_Last := False;
    if R=0.0 then return " 0.0+0"; end if;
    if Digs >= 2 then
      NMax := Integer'Min(Digs,NHex)-1;
    elsif Digs=0 then
      NMax := NHex-1;
    else
      NMax := 1;
    end if;
    declare
      E:    constant Integer := Flt'Exponent(R)-1;
      F:    constant Integer := E mod 4;
      M:    constant Flt     := FltCompose(Abs(R),F+1);
      D: Integer;
      L: Flt;
      S: String(1 .. NMax+3);
    begin
      if R<0.0 then S(1) := '-'; else S(1) := '+'; end if;
      L := Flt'Leading_Part(M,F+1);
      S(2) := UpDig(Integer(Flt'Floor(L)));
      S(3) := '.';
      for N in 1 .. NHex-1 loop
        L := Flt'Scaling(M-Flt'Leading_Part(M,F-3+4*N),4*N);
        D := Integer(Flt'Floor(L));
        if N <= NMax then
          S(N+3) := UpDig(D);
        elsif D>0 then
          Rounded_Last := True;
          exit;
        end if;
      end loop;
      return S & Image((E-F)/4,16,True);
    end;
  end HexStr;

  function DecStr(R: Flt; Digs: Natural := 0) return String is
    Fore: constant Field := 2; -- default
    Exp:  constant Field := 4; -- default
    Aft: Field := Flt'Digits;  -- default
  begin
    if Digs>1 then Aft := Digs-1;
    elsif Digs=1 then Aft := 1; end if;
    declare
      S: String(1 .. Fore+1+Aft+1+Exp);
    begin
      Flt_IO.Put(S,R,Aft,Exp);
      Rounded_Last := True;
      return S;
    end;
  end DecStr;

  -----------------------------------

  procedure Put(P: in File_Access; R: in Flt; F: in Field := Flt_IO.Default_Fore;
                                              A: in Field := Flt_IO.Default_Aft; E: in Field := Flt_IO.Default_Exp) is
  begin
    if P=null then
      Flt_IO.Put(R,F,A,E);
    else
      Flt_IO.Put(P.all,R,F,A,E);
    end if;
  end Put;

  procedure Put(F: in File_Type; R: in Flt; Decimal: in Boolean := False) is
    Digs: constant Integer := 17; --- gnat will not show more
  begin
    if Decimal then
      Flt_IO.Put(F,R,2,Digs,4);
    else
      Txt_IO.Put(F,HexStr(R));
    end if;
    New_Line(F);
  end Put;

  procedure Get(F: in File_Type; R: in out Flt; Decimal: in Boolean := False) is
    I: Integer := 0;
    S: String(1..1024);
  begin
    if Decimal then
      Flt_IO.Get(F,R);
      return;
    end if;
    while I=0 loop
      Txt_IO.Get_Line(File=>F, Item=>S, Last=>I);
    end loop;
    R := ValHex(S(1..I));
  end Get;

  procedure Write(FileName: in String; R: in Flt; Decimal: in Boolean := False) is
    use Strings;
    F: File_Type;
  begin
    if Verbosity>0 then Show0("Writing " & FileName); end if;
    Create(F,Out_File,FileName);
    Put(F,R,Decimal);
    Close(F);
  end Write;

  procedure Read(FileName: in String; R: in out Flt; Decimal: in Boolean := False) is
    use Strings;
    F: File_Type;
  begin
    if Verbosity>0 then Show0("Reading " & FileName); end if;
    Open(F,In_File,FileName);
    Get(F,R,Decimal);
    Close(F);
  end Read;

  function Prompt(N: String) return Flt is
    use Strings;
    R: Flt;
  begin
    Put(N);
    Flt_IO.Get(R);
    return R;
  end Prompt;

  function GetArg return Flt is
    use Ada.Command_Line;
    L: Integer;
    R: Flt;
  begin
    Flt_IO.Get(Argument(ArgIndex),R,L);
    ArgIndex := ArgIndex+1;
    return R;
  end GetArg;


  procedure Show1(N: in String; R: in Flt; NewLine: in Boolean := True) is
    use Strings;
    Digs: constant Integer := 17; --- gnat will not show more
    P: constant File_Access := Default_Output.all;
  begin
    Put(P,N);
    Put(P,R,3,Digs,4);
    if NewLine then New_Line(P); end if;
  end Show1;

  procedure Show2(N: in String; R1,R2: in Flt; NewLine: in Boolean := True) is
    use Strings;
    Digs: constant Integer := 17; --- gnat will not show more
    P: constant File_Access := Default_Output.all;
  begin
    Put(P,N);
    Put(P,R1,3,Digs,4);
    Put(P,R2,3,Digs,4);
    if NewLine then New_Line(P); end if;
  end Show2;

  procedure Show3(N: in String; R1,R2,R3: in Flt; NewLine: in Boolean := True) is
    use Strings;
    Digs: constant Integer := 10;
    P: constant File_Access := Default_Output.all;
  begin
    Put(P,N);
    Put(P,R1,3,Digs,0);
    Put(P,R2,3,Digs,0);
    Put(P,R3,3,Digs,0);
    if NewLine then New_Line(P); end if;
  end Show3;

end FltStr;
