------------------------------------------------------------------------------ -- -- -- 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-2024, 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 -- -- . -- -- -- -- 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); function To_Signed is new Ada.Unchecked_Conversion (Unsigned_128, Integer_128); ------------------ -- 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 begin if Result_Subtype'Base'Size > 64 then declare subtype IntV is Integer_128 range Integer_128'Integer_Value (Min) .. Integer_128'Integer_Value (Max); function R is new Random_Discrete (Integer_128, IntV'First); begin return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); end; elsif Result_Subtype'Base'Size > 32 then declare 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; else declare subtype IntV is Integer_32 range Integer_32'Integer_Value (Min) .. Integer_32'Integer_Value (Max); function R is new Random_Discrete (Integer_32, IntV'First); begin return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); end; end if; 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 begin if Result_Subtype'Base'Size > 64 then declare subtype IntV is Integer_128 range Integer_128'Integer_Value (Min) .. Integer_128'Integer_Value (Max); function R is new Random_Discrete (Integer_128, IntV'First); begin return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); end; elsif Result_Subtype'Base'Size > 32 then declare 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; else declare subtype IntV is Integer_32 range Integer_32'Integer_Value (Min) .. Integer_32'Integer_Value (Max); function R is new Random_Discrete (Integer_32, IntV'First); begin return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); end; end if; 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 Interfaces.Unsigned_128 is begin return Random (Gen.Rep); 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 Integer_64 is begin return To_Signed (Unsigned_64'(Random (Gen))); end Random; function Random (Gen : Generator) return Integer_128 is begin return To_Signed (Unsigned_128'(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;