path: root/gcc/ada/g-rannum.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                  G N A T . R A N D O M _ N U M B E R S                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2007-2015, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Numerics.Long_Elementary_Functions;
use  Ada.Numerics.Long_Elementary_Functions;
with Ada.Unchecked_Conversion;

with System.Random_Numbers; use System.Random_Numbers;

package body GNAT.Random_Numbers with
  SPARK_Mode => Off
is
   Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;

   subtype Image_String is String (1 .. Max_Image_Width);

   --  Utility function declarations

   procedure Insert_Image
     (S     : in out Image_String;
      Index : Integer;
      V     : Integer_64);
   --  Insert string representation of V in S starting at position Index

   ---------------
   -- To_Signed --
   ---------------

   function To_Signed is
     new Ada.Unchecked_Conversion (Unsigned_32, Integer_32);
   function To_Signed is
     new Ada.Unchecked_Conversion (Unsigned_64, Integer_64);

   ------------------
   -- Insert_Image --
   ------------------

   procedure Insert_Image
     (S     : in out Image_String;
      Index : Integer;
      V     : Integer_64)
   is
      Image : constant String := Integer_64'Image (V);
   begin
      S (Index .. Index + Image'Length - 1) := Image;
   end Insert_Image;

   ---------------------
   -- Random_Discrete --
   ---------------------

   function Random_Discrete
     (Gen   : Generator;
      Min   : Result_Subtype := Default_Min;
      Max   : Result_Subtype := Result_Subtype'Last) return Result_Subtype
   is
      function F is
        new System.Random_Numbers.Random_Discrete
              (Result_Subtype, Default_Min);
   begin
      return F (Gen.Rep, Min, Max);
   end Random_Discrete;

   --------------------------
   -- Random_Decimal_Fixed --
   --------------------------

   function Random_Decimal_Fixed
     (Gen : Generator;
      Min : Result_Subtype := Default_Min;
      Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
   is
      subtype IntV is Integer_64 range
        Integer_64'Integer_Value (Min) ..
        Integer_64'Integer_Value (Max);
      function R is new Random_Discrete (Integer_64, IntV'First);
   begin
      return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
   end Random_Decimal_Fixed;

   ---------------------------
   -- Random_Ordinary_Fixed --
   ---------------------------

   function Random_Ordinary_Fixed
     (Gen : Generator;
      Min : Result_Subtype := Default_Min;
      Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
   is
      subtype IntV is Integer_64 range
        Integer_64'Integer_Value (Min) ..
        Integer_64'Integer_Value (Max);
      function R is new Random_Discrete (Integer_64, IntV'First);
   begin
      return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
   end Random_Ordinary_Fixed;

   ------------
   -- Random --
   ------------

   function Random (Gen : Generator) return Float is
   begin
      return Random (Gen.Rep);
   end Random;

   function Random (Gen : Generator) return Long_Float is
   begin
      return Random (Gen.Rep);
   end Random;

   function Random (Gen : Generator) return Interfaces.Unsigned_32 is
   begin
      return Random (Gen.Rep);
   end Random;

   function Random (Gen : Generator) return Interfaces.Unsigned_64 is
   begin
      return Random (Gen.Rep);
   end Random;

   function Random (Gen : Generator) return Integer_64 is
   begin
      return To_Signed (Unsigned_64'(Random (Gen)));
   end Random;

   function Random (Gen : Generator) return Integer_32 is
   begin
      return To_Signed (Unsigned_32'(Random (Gen)));
   end Random;

   function Random (Gen : Generator) return Long_Integer is
      function Random_Long_Integer is new Random_Discrete (Long_Integer);
   begin
      return Random_Long_Integer (Gen);
   end Random;

   function Random (Gen : Generator) return Integer is
      function Random_Integer is new Random_Discrete (Integer);
   begin
      return Random_Integer (Gen);
   end Random;

   ------------------
   -- Random_Float --
   ------------------

   function Random_Float (Gen : Generator) return Result_Subtype is
      function F is new System.Random_Numbers.Random_Float (Result_Subtype);
   begin
      return F (Gen.Rep);
   end Random_Float;

   ---------------------
   -- Random_Gaussian --
   ---------------------

   --  Generates pairs of normally distributed values using the polar method of
   --  G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The
   --  Art of Computer Programming, Vol 2: Seminumerical Algorithms, section
   --  3.4.1, subsection C, algorithm P. Returns half of the pair on each call,
   --  using the Next_Gaussian field of Gen to hold the second member on
   --  even-numbered calls.

   function Random_Gaussian (Gen : Generator) return Long_Float is
      G : Generator renames Gen'Unrestricted_Access.all;

      V1, V2, Rad2, Mult : Long_Float;

   begin
      if G.Have_Gaussian then
         G.Have_Gaussian := False;
         return G.Next_Gaussian;

      else
         loop
            V1 := 2.0 * Random (G) - 1.0;
            V2 := 2.0 * Random (G) - 1.0;
            Rad2 := V1 ** 2 + V2 ** 2;
            exit when Rad2 < 1.0 and then Rad2 /= 0.0;
         end loop;

         --  Now V1 and V2 are coordinates in the unit circle

         Mult := Sqrt (-2.0 * Log (Rad2) / Rad2);
         G.Next_Gaussian := V2 * Mult;
         G.Have_Gaussian := True;
         return Long_Float'Machine (V1 * Mult);
      end if;
   end Random_Gaussian;

   function Random_Gaussian (Gen : Generator) return Float is
      V : constant Long_Float := Random_Gaussian (Gen);
   begin
      return Float'Machine (Float (V));
   end Random_Gaussian;

   -----------
   -- Reset --
   -----------

   procedure Reset (Gen : out Generator) is
   begin
      Reset (Gen.Rep);
      Gen.Have_Gaussian := False;
   end Reset;

   procedure Reset
     (Gen       : out Generator;
      Initiator : Initialization_Vector)
   is
   begin
      Reset (Gen.Rep, Initiator);
      Gen.Have_Gaussian := False;
   end Reset;

   procedure Reset
     (Gen       : out Generator;
      Initiator : Interfaces.Integer_32)
   is
   begin
      Reset (Gen.Rep, Initiator);
      Gen.Have_Gaussian := False;
   end Reset;

   procedure Reset
     (Gen       : out Generator;
      Initiator : Interfaces.Unsigned_32)
   is
   begin
      Reset (Gen.Rep, Initiator);
      Gen.Have_Gaussian := False;
   end Reset;

   procedure Reset
     (Gen       : out Generator;
      Initiator : Integer)
   is
   begin
      Reset (Gen.Rep, Initiator);
      Gen.Have_Gaussian := False;
   end Reset;

   procedure Reset
     (Gen        : out Generator;
      From_State : Generator)
   is
   begin
      Reset (Gen.Rep, From_State.Rep);
      Gen.Have_Gaussian := From_State.Have_Gaussian;
      Gen.Next_Gaussian := From_State.Next_Gaussian;
   end Reset;

   Frac_Scale : constant Long_Float :=
                  Long_Float
                    (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;

   function Val64 (Image : String) return Integer_64;
   --  Renames Integer64'Value
   --  We cannot use a 'renames Integer64'Value' since for some strange
   --  reason, this requires a dependency on s-auxdec.ads which not all
   --  run-times support ???

   function Val64 (Image : String) return Integer_64 is
   begin
      return Integer_64'Value (Image);
   end Val64;

   procedure Reset
     (Gen        : out Generator;
      From_Image : String)
   is
      F0 : constant Integer := From_Image'First;
      T0 : constant Integer := From_Image'First + Sys_Max_Image_Width;

   begin
      Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width));

      if From_Image (T0 + 1) = '1' then
         Gen.Have_Gaussian := True;
         Gen.Next_Gaussian :=
           Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale
           * Long_Float (Long_Float'Machine_Radix)
           ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last)));
      else
         Gen.Have_Gaussian := False;
      end if;
   end Reset;

   -----------
   -- Image --
   -----------

   function Image (Gen : Generator) return String is
      Result : Image_String;

   begin
      Result := (others => ' ');
      Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep);

      if Gen.Have_Gaussian then
         Result (Sys_Max_Image_Width + 2) := '1';
         Insert_Image (Result, Sys_Max_Image_Width + 4,
                       Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian)
                                   * Frac_Scale));
         Insert_Image (Result, Sys_Max_Image_Width + 24,
                       Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian)));

      else
         Result (Sys_Max_Image_Width + 2) := '0';
      end if;

      return Result;
   end Image;

end GNAT.Random_Numbers;