--                                                                    --
--  package Strings_Edit            Copyright (c)  Dmitry A. Kazakov  --
--  Implementation                                 Luebeck            --
--  Strings_Edit.Float_Edit                        Spring, 2000       --
--                                                                    --
--                                Last revision :  18:40 01 Aug 2019  --
--                                                                    --
--  This  library  is  free software; you can redistribute it and/or  --
--  modify it under the terms of the GNU General Public  License  as  --
--  published by the Free Software Foundation; either version  2  of  --
--  the License, or (at your option) any later version. This library  --
--  is distributed in the hope that it will be useful,  but  WITHOUT  --
--  ANY   WARRANTY;   without   even   the   implied   warranty   of  --
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU  --
--  General  Public  License  for  more  details.  You  should  have  --
--  received  a  copy  of  the GNU General Public License along with  --
--  this library; if not, write to  the  Free  Software  Foundation,  --
--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.    --
--                                                                    --
--  As a special exception, if other files instantiate generics from  --
--  this unit, or you link this unit with other files to produce  an  --
--  executable, this unit does not by  itself  cause  the  resulting  --
--  executable to be covered by the GNU General Public License. This  --
--  exception  does not however invalidate any other reasons why the  --
--  executable file might be covered by the GNU Public License.       --
--____________________________________________________________________--

with Ada.IO_Exceptions;
with Ada.Numerics.Elementary_Functions;
with Strings_Edit.Integers;
pragma Elaborate_All (Strings_Edit.Integers);

use Ada.IO_Exceptions;
use Ada.Numerics.Elementary_Functions;
use Strings_Edit.Integers;

package body Strings_Edit.Float_Edit is
   --
   -- Base-radix logarithms of the number of  valid  digits  in  machine
   -- radix, i.e. how many base-radix digits  one  machine  radix  digit
   -- represents.
   --
   Logs : constant array (NumberBase) of Float :=
            (  2 => Log (Float (Number'Machine_Radix), 2.0),
               3 => Log (Float (Number'Machine_Radix), 3.0),
               4 => Log (Float (Number'Machine_Radix), 4.0),
               5 => Log (Float (Number'Machine_Radix), 5.0),
               6 => Log (Float (Number'Machine_Radix), 6.0),
               7 => Log (Float (Number'Machine_Radix), 7.0),
               8 => Log (Float (Number'Machine_Radix), 8.0),
               9 => Log (Float (Number'Machine_Radix), 9.0),
              10 => Log (Float (Number'Machine_Radix), 10.0),
              11 => Log (Float (Number'Machine_Radix), 11.0),
              12 => Log (Float (Number'Machine_Radix), 12.0),
              13 => Log (Float (Number'Machine_Radix), 13.0),
              14 => Log (Float (Number'Machine_Radix), 14.0),
              15 => Log (Float (Number'Machine_Radix), 15.0),
              16 => Log (Float (Number'Machine_Radix), 16.0)
            );
   --
   -- GetExponentField -- Calculate the length of the exponent
   --
   --	 Base	- Of the number
   --
   -- This  function  calculates  how  many  digits  are  necessary   to
   -- represent any Base-radix exponent in decimal the format.
   --
   -- Returns :
   --
   --	 The exponent length
   --
   function GetExponentField (Base : NumberBase) return Natural is
   begin
      if Number'Machine_Emax > -Number'Machine_Emin then
         return
            Natural
            (  Log (Float (Number'Machine_Emax) * Logs (Base), 10.0)
            +  0.5
            );
      else
         return
            Natural
            (  Log (Float (-Number'Machine_Emin) * Logs (Base), 10.0)
            +  0.5
            );
      end if;
   end GetExponentField;
   --
   -- The exponent lengths for different Bases
   --
   ExponentField : constant array (NumberBase) of Natural :=
                      (  GetExponentField (2),  GetExponentField (3),
                         GetExponentField (4),  GetExponentField (5),
                         GetExponentField (6),  GetExponentField (7),
                         GetExponentField (8),  GetExponentField (9),
                         GetExponentField (10), GetExponentField (11),
                         GetExponentField (12), GetExponentField (13),
                         GetExponentField (14), GetExponentField (15),
                         GetExponentField (16)
                      );
   --
   -- GetExponent -- Get the exponent part from the string
   --
   --	    Source  - The string
   --	    Pointer - Within the string
   --	    Value   - Of the exponent (output)
   --
   -- This procedure scans the Source string starting from  the  Pointer
   -- position  for  the  exponent  part of a number. Spaces are skipped
   -- first. The exponent can be introduced by either E or e. Its  value
   -- is  a decimal number returned via Value. If no valid exponent part
   -- present Value is set to zero (the Pointer remains intact).
   --
   procedure GetExponent
             (  Source   : in String;
                Pointer  : in out Integer;
                Value    : out Integer
             )  is
      Index : Integer := Pointer;
   begin
      Get (Source, Index);
      if (  Index > Source'Last
         or else
            (  Source (Index) /= 'E'
            and
               Source (Index) /= 'e'
         )  )
      then
         Value := 0;
      else
         Index := Index + 1;
         Get (Source, Index);
         Get (Source, Index, Value, 10, -1000, +1000, True, True);
         Pointer := Index;
      end if;
   exception
      when End_Error | Data_Error | Layout_Error | Constraint_Error =>
         Value := 0;
   end GetExponent;

   procedure Get
             (  Source   : in String;
                Pointer  : in out Integer;
                Value    : out Number'Base;
                Base     : in NumberBase := 10;
                First    : in Number'Base := Number'Base'First;
                Last     : in Number'Base := Number'Base'Last;
                ToFirst  : in Boolean := False;
                ToLast   : in Boolean := False
             )  is
      Radix        : constant Number'Base := Number'Base (Base);
      Digit        : Natural;
      Exponent     : Integer;
      ExponentPart : Integer;
      Mantissa     : Number'Base := 0.0;
      Multiplicand : Number'Base := 1.0;
      Sign         : Integer := 0;
      Index        : Integer := Pointer;
   begin
      if (  Pointer < Source'First
         or else
            (  Pointer > Source'Last
            and then
               Pointer - 1 > Source'Last
         )  )
      then
         raise Layout_Error;
      end if;
      if Pointer <= Source'Last then
         case Source (Index) is
            when '-' =>
               Index := Index + 1;
               Sign := -1;
               Get (Source, Index);
            when '+' =>
               Index := Index + 1;
               Sign := 1;
               Get (Source, Index);
            when others =>
               null;
         end case;
      end if;
      ExponentPart := Index;
      Exponent := Index;
      while Index <= Source'Last loop
         Digit := GetDigit (Source (Index));
         exit when Digit >= Base;
         Mantissa := Mantissa + Number'Base (Digit) * Multiplicand;
         Multiplicand := Multiplicand / Radix;
         Index := Index + 1;
      end loop;
      Exponent := Index - Exponent - 1;
      if Index + 1 <= Source'Last and then Source (Index) = '.' then
         Index := Index + 1;
         Digit := GetDigit (Source (Index));
         if Digit < Base then
            loop
               Mantissa :=
                  Mantissa + Number'Base (Digit) * Multiplicand;
               Multiplicand := Multiplicand / Radix;
               Index := Index + 1;
               exit when Index > Source'Last;
               Digit := GetDigit (Source (Index));
               exit when Digit >= Base;
            end loop;
         else
            Index := Index - 1;
         end if;
      end if;
      if 0 = Sign then
         if Pointer = Index then
            raise End_Error; -- No fraction part - no number
         end if;
         Sign := 1;
      else
         if Pointer = Index - 1 then
            raise Data_Error; -- Only a sign
         end if;
      end if;
      if (  ExponentPart = Index - 1
         and then
            Source (ExponentPart) = '.'
         )
      then
         raise Data_Error; -- Only decimal point is present
      end if;
      GetExponent (Source, Index, ExponentPart);
      if Mantissa > 0.0 then
         begin
            Mantissa := Number'Base (Sign) * Mantissa;
            Exponent := ExponentPart + Exponent;
            ExponentPart :=
               Integer (Float (Number'Machine_Emax) * Logs (Base) * 0.7);
            if Exponent >= ExponentPart then
               Multiplicand := Radix ** ExponentPart;
               loop
                  Mantissa := Mantissa * Multiplicand;
                  Exponent := Exponent - ExponentPart;
                  exit when Exponent < ExponentPart;
               end loop;
            elsif Exponent <= -ExponentPart then
               ExponentPart := -ExponentPart;
               Multiplicand := Radix ** ExponentPart;
               loop
                  Mantissa := Mantissa * Multiplicand;
                  Exponent := Exponent - ExponentPart;
                  exit when Exponent > ExponentPart;
               end loop;
            end if;
            Mantissa := Mantissa * Radix ** Exponent;
            if not Mantissa'Valid then
               if Sign > 0 and ToLast then
                  Value   := Last;
                  Pointer := Index;
                  return;
               elsif Sign < 0 and ToFirst then
                  Value   := First;
                  Pointer := Index;
                  return;
               end if;
               raise Constraint_Error;
            end if;
         exception
            when Numeric_Error | Constraint_Error =>
               if Sign > 0 and ToLast then
                  Value   := Last;
                  Pointer := Index;
                  return;
               elsif Sign < 0 and ToFirst then
                  Value   := First;
                  Pointer := Index;
                  return;
               end if;
               raise Constraint_Error;
         end;
      end if;
      if Mantissa < First then
         if ToFirst then
            Mantissa := First;
         else
            raise Constraint_Error;
         end if;
      elsif Mantissa > Last then
         if ToLast then
            Mantissa := Last;
         else
            raise Constraint_Error;
         end if;
      end if;
      Value := Mantissa;
      Pointer := Index;
   end Get;

   function Value
            (  Source  : in String;
               Base    : in NumberBase := 10;
               First   : in Number'Base := Number'First;
               Last    : in Number'Base := Number'Last;
               ToFirst : in Boolean := False;
               ToLast  : in Boolean := False
            )  return Number'Base is
      Result  : Number'Base;
      Pointer : Integer := Source'First;
   begin
      Get (Source, Pointer, SpaceAndTab);
      Get (Source, Pointer, Result, Base, First, Last, ToFirst, ToLast);
      Get (Source, Pointer, SpaceAndTab);
      if Pointer /= Source'Last + 1 then
         raise Data_Error;
      end if;
      return Result;
   end Value;

   procedure Put
             (  Destination : in out String;
                Pointer     : in out Integer;
                Value       : in Number'Base;
                Base        : in NumberBase := 10;
                PutPlus     : in Boolean := False;
                RelSmall    : in Positive := MaxSmall;
                AbsSmall    : in Integer := -MaxSmall;
                Field       : in Natural := 0;
                Justify     : in Alignment := Left;
                Fill        : in Character := ' '
             )  is
      --
      -- Sign -- Make the sign of a number
      --
      --    Value   - Of the number
      --    PutPlus - Always put sign, if true
      --
      -- Returns :
      --
      --    The string to be used as the sign
      --
      function Sign
               (  Value   : Number'Base;
                  PutPlus : Boolean
               )  return String is
      begin
         if Value < 0.0 then
            return "-";
         elsif PutPlus then
            return "+";
         else
            return "";
         end if;
      end Sign;
      --
      -- PutExponent -- Make the exponent part
      --
      --    Value  - Of the exponent part
      --    Base   - Of the mantissa
      --
      -- The  exponent  part  is  written in the fixed length format. It
      -- always  has  sign.  Leading  zeros are added to make the length
      -- fixed. The space is added in front of  the  exponent  part  for
      -- bases 15 and 16.
      --
      -- Returns :
      --
      --    The string containing the exponent part
      --
      function PutExponent
               (  Value : Integer;
                  Base  : NumberBase
               )  return String is
         Result   : String (1..32);
         Exponent : Integer := Value;
         Pointer  : Integer := Result'First;
         Sign     : Character := '+';
      begin
         if Exponent < 0 then
            Sign := '-';
            Exponent := -Value;
         end if;
         Put
         (  Result,
            Pointer,
            Exponent,
            Field   => ExponentField (Base),
            PutPlus => False,
            Justify => Right,
            Fill    => '0'
         );
         if Base >= 15 then
            return " e" & Sign & Result (Result'First..Pointer - 1);
         else
            return 'E' & Sign & Result (Result'First..Pointer - 1);
         end if;
      end PutExponent;

      Precision : Integer :=   -- The maximal available precision
                     Integer
                     (  Float (Number'Machine_Mantissa)
                     *  Logs (Base)
                     );
      Mantissa  : Number'Base := abs Value;
      Exponent  : Integer := 0;
      Increment : Integer := 0;
      Radix     : constant Number'Base := Number'Base (Base);
   begin
      if Mantissa <= 0.0 then
         Put (Destination, Pointer, "0", Field, Justify, Fill);
         return;
      end if;
      if RelSmall < Precision then
         Precision := RelSmall;
      end if;
      --
      -- Normalization. The goal is to bring the mantissa into the range
      -- ]1..1/Base]
      --
      while Mantissa < 1.0 / Radix loop
         Mantissa := Mantissa * Radix;
         Exponent := Exponent - 1;
      end loop;
      while Mantissa >= 1.0 loop
         Mantissa := Mantissa / Radix;
         Exponent := Exponent + 1;
      end loop;
      if Exponent - AbsSmall < Precision then
         Precision := Exponent - AbsSmall;
         Increment := 1;
      end if;
      --
      -- Rounding
      --
      Mantissa := Mantissa + 0.5 / Radix ** Precision;
      if Mantissa >= 1.0 then
         Mantissa  := Mantissa / Radix;
         Exponent  := Exponent + 1;
	 Precision := Precision + Increment;
      end if;
      if Precision > 0 then
         declare
            ExponentPart : constant String :=
                           PutExponent (Exponent - 1, Base);
            MantissaPart : String (1..Precision);
            Digit        : Natural;
         begin
            --
            -- Convert the Mantissa to character string
            --
            for Index in MantissaPart'range loop
               Mantissa := Mantissa * Radix;
               Digit := Integer (Mantissa);
               if Number'Base (Digit) > Mantissa then
                  Digit := Digit - 1;
               end if;
               Mantissa := Mantissa - Number'Base (Digit);
               MantissaPart (Index) := Figures (Digit + Figures'First);
            end loop;
            if (  Exponent < - ExponentPart'Length
               or Exponent > Precision
               )
            then
               --
               -- Format X.XXXXXeYYY
               --
               Put
               (  Destination,
	            Pointer,
                  (  Sign (Value, PutPlus)
                  &  MantissaPart (MantissaPart'First)
                  &  '.'
                  &  MantissaPart
                     (  MantissaPart'First + 1
                     .. MantissaPart'Last
                     )
                  &  ExponentPart
                  ),
                  Field,
                  Justify,
                  Fill
               );
            elsif Exponent = Precision then
               --
               -- Format: XXXXXXX
               --
               Put
               (  Destination,
                  Pointer,
                  Sign (Value, PutPlus) & MantissaPart,
                  Field,
                  Justify,
                  Fill
	         );
            elsif Exponent > 0 then
               --
               -- Format: XXXX.XXX
               --
               Put
               (  Destination,
                  Pointer,
                  (  Sign (Value, PutPlus)
                  &  MantissaPart
                     (  MantissaPart'First
                     .. MantissaPart'First + Exponent - 1
                     )
                  &  '.'
                  &  MantissaPart
                     (  MantissaPart'First + Exponent
                     .. MantissaPart'Last
                  )  ),
                  Field,
                  Justify,
                  Fill
               );
            else
               --
               -- Format: 0.000XXXXX
               --
               Put
               (  Destination,
                  Pointer,
                  (  Sign (Value, PutPlus)
                  &  "0."
                  &  String'(1..-Exponent => '0')
                  &  MantissaPart
                  ),
                  Field,
                  Justify,
                  Fill
               );
            end if;
         end;
      else
         --
         -- Zero
         --
         Put (Destination, Pointer, "0", Field, Justify, Fill);
      end if;
   end Put;

   function Image
            (  Value    : in Number'Base;
               Base     : in NumberBase := 10;
               PutPlus  : in Boolean    := False;
               RelSmall : in Positive   := MaxSmall;
               AbsSmall : in Integer    := -MaxSmall
            )  return String is
      Text    : String (1..80);
      Pointer : Integer := Text'First;
   begin
      Put (Text, Pointer, Value, Base, PutPlus, RelSmall, AbsSmall);
      return Text (Text'First..Pointer - 1);
   end Image;

end Strings_Edit.Float_Edit;
