--    GMPAda, binding to the Ada Language for the GNU MultiPrecision library.
--    Copyright (C) 2007-2022 Nicolas Boulenguez <nicolas.boulenguez@free.fr>
--
--    This program 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 3 of the License, or
--    (at your option) any later version.
--
--    This program 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 program.  If not, see <http://www.gnu.org/licenses/>.

with Ada.Characters.Conversions;
with Interfaces.C; use Interfaces.C;
with GMP.Binding; use GMP.Binding;
with GNU_Multiple_Precision.Aux;

package body GNU_Multiple_Precision.Big_Floats is

   function "<"  (Left, Right : Big_Float) return Boolean
   is
   begin
      return Mpf_Cmp (Left.Value, Right.Value) < 0;
   end "<";

   function "<=" (Left, Right : Big_Float) return Boolean
   is
   begin
      return Mpf_Cmp (Left.Value, Right.Value) <= 0;
   end "<=";

   function ">"  (Left, Right : Big_Float) return Boolean
   is
   begin
      return Mpf_Cmp (Left.Value, Right.Value) > 0;
   end ">";

   function ">=" (Left, Right : Big_Float) return Boolean
   is
   begin
      return Mpf_Cmp (Left.Value, Right.Value) >= 0;
   end ">=";

   function "+" (Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Set (Result, Right);
      end return;
   end "+";

   function "-" (Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Negate (Result, Right);
      end return;
   end "-";

   function "abs" (Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Absolute_Value (Result, Right);
      end return;
   end "abs";

   function "+" (Left, Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Add (Result, Left, Right);
      end return;
   end "+";

   function "-" (Left, Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Subtract (Result, Left, Right);
      end return;
   end "-";

   function "*" (Left, Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Multiply (Result, Left, Right);
      end return;
   end "*";

   function "/" (Left, Right : in Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Divide (Result, Left, Right);
      end return;
   end "/";

   function "**"  (Left  : in Big_Float;
                   Right : in Integer)
                  return Big_Float
   is
   begin
      return Result : Big_Float do
         Exponentiate (Result, Left, Right);
      end return;
   end "**";

   function Ceiling (X : Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Ceiling (Result, X);
      end return;
   end Ceiling;

   function Floor (X : Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Floor (Result, X);
      end return;
   end Floor;

   function Rounding (X : Big_Float) return Big_Float
   is
      Decimal_Part : Mpf_T;
      Cmp          : int;
   begin
      return Result : Big_Float do
         Mpf_Floor (Result.Value, X.Value);
         Mpf_Init_Set (Decimal_Part, X.Value);
         pragma Warnings (Off,
            "writable actual for * overlaps with actual for *");
         Mpf_Sub (Decimal_Part, Decimal_Part, Result.Value);
         pragma Warnings (On,
            "writable actual for * overlaps with actual for *");
         Cmp := Mpf_Cmp_D (Decimal_Part, 0.5);
         if Cmp = 1 or (Cmp = 0 and Mpf_Sgn (X.Value) > 0) then
            pragma Warnings (Off,
               "writable actual for * overlaps with actual for *");
            Mpf_Add_Ui (Result.Value, Result.Value, 1);
            pragma Warnings (On,
               "writable actual for * overlaps with actual for *");
         end if;
      end return;
   end Rounding;

   function Truncation (X : Big_Float) return Big_Float
   is
   begin
      return Result : Big_Float do
         Truncation (Result, X);
      end return;
   end Truncation;

   function Exponent (X : Big_Float) return Integer
   is
      D : double;
      E : long;
   begin
      Mpf_Get_D_2exp (D, E, X.Value);
      return Integer (E);
   end Exponent;

   function Fraction (X : Big_Float) return Big_Float
   is
      D : double;
      E : long;
   begin
      Mpf_Get_D_2exp (D, E, X.Value);
      return Result : Big_Float do
         if E > 0 then
            Mpf_Div_2exp (Result.Value, X.Value, unsigned_long (E));
         else
            Mpf_Mul_2exp (Result.Value, X.Value, unsigned_long (-E));
         end if;
      end return;
   end Fraction;

   function Compose (Fraction : Big_Float;
                     Exponent : Integer) return Big_Float
   is
      D : double;
      E : long;
   begin
      Mpf_Get_D_2exp (D, E, Fraction.Value);
      E := E - long (Exponent);
      return Result : Big_Float do
         if E > 9 then
            Mpf_Mul_2exp (Result.Value, Fraction.Value, unsigned_long (E));
         else
            Mpf_Div_2exp (Result.Value, Fraction.Value, unsigned_long (-E));
         end if;
      end return;
   end Compose;

   function Image (Arg : Big_Float) return String
   is
      N_Digits : constant unsigned_long
        := unsigned_long'Max (1, Mpf_Get_Prec (Arg.Value) / 3);
      --  We want to be sure to ask at least one digit, no C allocated-string.

      Result : String (1 .. Positive (N_Digits) + 5 + Mp_Exp_T'Width);
      --  Sign dot E
      Last   : Natural := Result'First - 1;
      procedure Put_Character (C : in Character);
      procedure Put_Character (C : in Character) is
      begin
         Last := Last + 1;
         Result (Last) := C;
      end Put_Character;
   begin
      if Mpf_Sgn (Arg.Value) >= 0 then
         Put_Character (' ');
      end if;
      GNU_Multiple_Precision.Aux.Put (Put_Character'Access, Item => Arg.Value,
                                      Fore => 2, Aft => Natural (N_Digits - 1),
                                      Exp => 3);
      return Result (Result'First .. Last);
   end Image;

   function Wide_Image (Arg : Big_Float) return Wide_String
   is
   begin
      return Ada.Characters.Conversions.To_Wide_String (Image (Arg));
   end Wide_Image;

   function Wide_Wide_Image (Arg : Big_Float) return Wide_Wide_String
   is
   begin
      return Ada.Characters.Conversions.To_Wide_Wide_String (Image (Arg));
   end Wide_Wide_Image;

   function Value (Item : String) return Big_Float
   is
      --  We need to detect Ada-style base and exponents, so
      --  impossible to call mpf_get_str directly.
      use GNU_Multiple_Precision.Aux;
      Last : Natural := Item'First;
      Next : Character;          --  = Item (Last - 1) in normal cases
      procedure Consume;
      procedure Consume is
      begin
         if Last <= Item'Last then
            Next := Item (Last);
         else
            pragma Assert (Last = Item'Last + 1);
            Next := Unused_Character;
         end if;
         Last := Last + 1;
      end Consume;
      package Scan is new Generic_Scan (Next, Consume);
   begin
      Consume;
      return Result : Big_Float do
         Scan.Get_Mpf_T (Result.Value, Item'Length);
         for I in Last - 1 .. Item'Last loop
            if Item (I) /= ' ' and Item (I) /= ASCII.HT then
               raise Constraint_Error;
            end if;
         end loop;
      end return;
   exception
      when others => raise Constraint_Error;
   end Value;

   function Wide_Value (Item : Wide_String) return Big_Float
   is
      --  This replacement character will cause an error in Value.
   begin
      return Value (Ada.Characters.Conversions.To_String (Item, 'z'));
   end Wide_Value;

   function Wide_Wide_Value (Item : Wide_Wide_String) return Big_Float
   is
      --  This replacement character will cause an error in Value.
   begin
      return Value (Ada.Characters.Conversions.To_String (Item, 'z'));
   end Wide_Wide_Value;

   function Max (Left, Right : Big_Float) return Big_Float
   is
   begin
      if Mpf_Cmp (Left.Value, Right.Value) <= 0 then
         return Right;
      else
         return Left;
      end if;
   end Max;

   function Min (Left, Right : Big_Float) return Big_Float
   is
   begin
      if Mpf_Cmp (Left.Value, Right.Value) >= 0 then
         return Right;
      else
         return Left;
      end if;
   end Min;

   package body Integer_Conversions is

      procedure Set (Rop : in out Big_Float;
                     Op  : in     Num)
      is
      begin
         Mpf_Set_Si (Rop.Value, long (Op));
      end Set;

      function To_Big_Float (Item : Num) return Big_Float
      is
      begin
         return Result : Big_Float do
            Mpf_Set_Si (Result.Value, long (Item));
         end return;
      end To_Big_Float;

      function Fits_In_Num (Item : Big_Float) return Boolean
      is
      begin
         return Mpf_Cmp_Si (Item.Value, long (Num'First)) >= 0
           and Mpf_Cmp_Si (Item.Value, long (Num'Last)) <= 0;
      end Fits_In_Num;

      function To_Num (Item : Big_Float) return Num
      is
      begin
         if Mpf_Fits_Slong_P (Item.Value) = 0 then
            raise Constraint_Error;
         end if;
         return Num (Mpf_Get_Si (Item.Value));
      end To_Num;

   end Integer_Conversions;

   package body Modular_Conversions is

      procedure Set (Rop : in out Big_Float;
                     Op  : in     Num)
      is
      begin
         Mpf_Set_Ui (Rop.Value, unsigned_long (Op));
      end Set;

      function To_Big_Float (Item : Num) return Big_Float
      is
      begin
         return Result : Big_Float do
            Mpf_Set_Ui (Result.Value, unsigned_long (Item));
         end return;
      end To_Big_Float;

      function Fits_In_Num (Item : Big_Float) return Boolean
      is
      begin
         return Mpf_Cmp_Ui (Item.Value, unsigned_long (Num'First)) >= 0
           and Mpf_Cmp_Ui (Item.Value, unsigned_long (Num'Last)) <= 0;
      end Fits_In_Num;

      function To_Num (Item : Big_Float) return Num
      is
      begin
         if Mpf_Fits_Ulong_P (Item.Value) = 0 then
            raise Constraint_Error;
         end if;
         return Num (Mpf_Get_Ui (Item.Value));
      end To_Num;

   end Modular_Conversions;

   package body Float_Conversions is

      procedure Set (Rop : in out Big_Float;
                     Op  : in     Num)
      is
      begin
         Mpf_Set_D (Rop.Value, double (Op));
      end Set;

      function To_Big_Float (Item : Num) return Big_Float
      is
      begin
         return Result : Big_Float do
            Mpf_Set_D (Result.Value, double (Item));
         end return;
      end To_Big_Float;

      function To_Num (Item : Big_Float) return Num
      is
      begin
         return Num (Mpf_Get_D (Item.Value));
      end To_Num;

      procedure Split_Mantissa_Exponent
        (Mantissa :    out Num;
         Exponent :    out Integer;
         Op       : in     Big_Float)
      is
         Temp_M : double;
         Temp_E : long;
      begin
         Mpf_Get_D_2exp (Temp_M, Temp_E, Op.Value);
         Mantissa := Num (Temp_M);
         Exponent := Integer (Temp_E);
      end Split_Mantissa_Exponent;

   end Float_Conversions;

   procedure Set_Default_Precision (New_Value : Bit_Count)
   is
   begin
      Mpf_Set_Default_Prec (New_Value);
   end Set_Default_Precision;

   function Default_Precision return Bit_Count
   is
   begin
      return Mpf_Get_Default_Prec;
   end Default_Precision;

   function Precision (Op : Big_Float) return Bit_Count
   is
   begin
      return Mpf_Get_Prec (Op.Value);
   end Precision;

   procedure Set_Precision (Rop       : in out Big_Float;
                            New_Value : in     Bit_Count)
   is
   begin
      Mpf_Set_Prec (Rop.Value, New_Value);
   end Set_Precision;

   procedure Set_Precision_Raw (Rop       : in out Big_Float;
                                New_Value : in     Bit_Count)
   is
   begin
      Mpf_Set_Prec_Raw (Rop.Value, New_Value);
   end Set_Precision_Raw;

   procedure Set
     (Rop : in out Big_Float;
      Op  : in     Big_Float)
   is
   begin
      Mpf_Set (Rop.Value, Op.Value);
   end Set;

   procedure Swap (Rop1, Rop2 : in out Big_Float)
   is
   begin
      Mpf_Swap (Rop1.Value, Rop2.Value);
   end Swap;


   procedure Add (Sum              : in out Big_Float;
                  Addend1, Addend2 : in     Big_Float)
   is
   begin
      Mpf_Add (Sum.Value, Addend1.Value, Addend2.Value);
   end Add;

   procedure Subtract (Difference          : in out Big_Float;
                       Minuend, Subtrahend : in     Big_Float)
   is
   begin
      Mpf_Sub (Difference.Value, Minuend.Value, Subtrahend.Value);
   end Subtract;

   procedure Multiply (Product                  : in out Big_Float;
                       Multiplier, Multiplicand : in     Big_Float)
   is
   begin
      Mpf_Mul (Product.Value, Multiplier.Value, Multiplicand.Value);
   end Multiply;

   procedure Negate (Negated_Operand : in out Big_Float;
                     Operand         : in     Big_Float)
   is
   begin
      Mpf_Neg (Negated_Operand.Value, Operand.Value);
   end Negate;

   procedure Absolute_Value (Rop : in out Big_Float;
                             Op  : in     Big_Float)
   is
   begin
      Mpf_Abs (Rop.Value, Op.Value);
   end Absolute_Value;

   procedure Divide (Q     : in out Big_Float;
                     N, D  : in     Big_Float)
   is
   begin
      if Mpf_Cmp_Ui (D.Value, 0) = 0 then
         raise Constraint_Error;
      end if;
      Mpf_Div (Q.Value, N.Value, D.Value);
   end Divide;

   procedure Square_Root
     (Root : in out Big_Float;
      U    : in     Big_Float)
   is
   begin
      if Mpf_Cmp_Ui (U.Value, 0) < 0 then
         raise Constraint_Error;
      end if;
      Mpf_Sqrt (Root.Value, U.Value);
   end Square_Root;

   procedure Exponentiate (Rop      : in out Big_Float;
                           Base     : in     Big_Float;
                           Exponent : in     Integer)
   is
   begin
      if Exponent >= 0 then
         Mpf_Pow_Ui (Rop.Value, Base.Value, unsigned_long (Exponent));
      else
         Mpf_Ui_Div (Rop.Value, 1, Base.Value);
         pragma Warnings (Off,
            "writable actual for * overlaps with actual for *");
         Mpf_Pow_Ui (Rop.Value, Rop.Value, unsigned_long (-Exponent));
         pragma Warnings (On,
            "writable actual for * overlaps with actual for *");
      end if;
   end Exponentiate;

   procedure Multiply_2_Exp (Rop : in out Big_Float;
                             Op1 : in     Big_Float;
                             Op2 : in     Bit_Count)
   is
   begin
      Mpf_Mul_2exp (Rop.Value, Op1.Value, Op2);
   end Multiply_2_Exp;

   procedure Divide_2_Exp
     (Q : in out Big_Float;
      N : in     Big_Float;
      B : in     Bit_Count)
   is
   begin
      Mpf_Div_2exp (Q.Value, N.Value, B);
   end Divide_2_Exp;

   function Equals (Op1, Op2 : Big_Float;
                    Op3      : Bit_Count) return Boolean
   is
   begin
      return Mpf_Eq (Op1.Value, Op2.Value, Op3) /= 0;
   end Equals;

   procedure Relative_Difference (Rop      : in out Big_Float;
                                  Op1, Op2 : in     Big_Float)
   is
   begin
      Mpf_Reldiff (Rop.Value, Op1.Value, Op2.Value);
   end Relative_Difference;

   function Sign (Item : in Big_Float) return A_Sign
   is
   begin
      return A_Sign (Mpf_Sgn (Item.Value));
   end Sign;

   procedure Ceiling (Rop : in out Big_Float;
                      Op  : in     Big_Float)
   is
   begin
      Mpf_Ceil (Rop.Value, Op.Value);
   end Ceiling;

   procedure Floor (Rop : in out Big_Float;
                    Op  : in     Big_Float)
   is
   begin
      Mpf_Floor (Rop.Value, Op.Value);
   end Floor;

   procedure Truncation (Rop : in out Big_Float;
                         Op  : in     Big_Float)
   is
   begin
      Mpf_Trunc (Rop.Value, Op.Value);
   end Truncation;

   function Is_Integer (Op : Big_Float) return Boolean
   is
   begin
      return Mpf_Integer_P (Op.Value) /= 0;
   end Is_Integer;

   procedure Set (Rop : in out Big_Integer;
                  Op  : in     Big_Float)
   is
   begin
      Mpz_Set_F (Rop.Value, Op.Value);
   end Set;

   procedure Set (Rop : in out Big_Float;
                  Op  : in     Big_Integer)
   is
   begin
      Mpf_Set_Z (Rop.Value, Op.Value);
   end Set;

end GNU_Multiple_Precision.Big_Floats;
