blob: c89ae962709f2a3902e3c73add3565eb04771f84 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . R A N D O M _ N U M B E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2022, 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. --
-- --
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- The implementation here is derived from a C-program for MT19937, with --
-- initialization improved 2002/1/26. As required, the following notice is --
-- copied from the original program. --
-- --
-- Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, --
-- All rights reserved. --
-- --
-- Redistribution and use in source and binary forms, with or without --
-- modification, are permitted provided that the following conditions --
-- are met: --
-- --
-- 1. Redistributions of source code must retain the above copyright --
-- notice, this list of conditions and the following disclaimer. --
-- --
-- 2. Redistributions in binary form must reproduce the above copyright --
-- notice, this list of conditions and the following disclaimer in the --
-- documentation and/or other materials provided with the distribution.--
-- --
-- 3. The names of its contributors may not be used to endorse or promote --
-- products derived from this software without specific prior written --
-- permission. --
-- --
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --
-- --
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- This is an implementation of the Mersenne Twister, twisted generalized --
-- feedback shift register of rational normal form, with state-bit --
-- reflection and tempering. This version generates 32-bit integers with a --
-- period of 2**19937 - 1 (a Mersenne prime, hence the name). For --
-- applications requiring more than 32 bits (up to 64), we concatenate two --
-- 32-bit numbers. --
-- --
-- See http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html for --
-- details. --
-- --
-- In contrast to the original code, we do not generate random numbers in --
-- batches of N. Measurement seems to show this has very little if any --
-- effect on performance, and it may be marginally better for real-time --
-- applications with hard deadlines. --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with System.Random_Seed;
with Interfaces; use Interfaces;
use Ada;
package body System.Random_Numbers with
SPARK_Mode => Off
is
Image_Numeral_Length : constant := Max_Image_Width / N;
subtype Image_String is String (1 .. Max_Image_Width);
----------------------------
-- Algorithmic Parameters --
----------------------------
Lower_Mask : constant := 2**31 - 1;
Upper_Mask : constant := 2**31;
Matrix_A : constant array (State_Val range 0 .. 1) of State_Val
:= [0, 16#9908b0df#];
-- The twist transformation is represented by a matrix of the form
--
-- [ 0 I(31) ]
-- [ _a ]
--
-- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and
-- _a is a particular bit row-vector, represented here by a 32-bit integer.
-- If integer x represents a row vector of bits (with x(0), the units bit,
-- last), then
-- x * A = [0 x(31..1)] xor Matrix_A(x(0)).
U : constant := 11;
S : constant := 7;
B_Mask : constant := 16#9d2c5680#;
T : constant := 15;
C_Mask : constant := 16#efc60000#;
L : constant := 18;
-- The tempering shifts and bit masks, in the order applied
Seed0 : constant := 5489;
-- Default seed, used to initialize the state vector when Reset not called
Seed1 : constant := 19650218;
-- Seed used to initialize the state vector when calling Reset with an
-- initialization vector.
Mult0 : constant := 1812433253;
-- Multiplier for a modified linear congruential generator used to
-- initialize the state vector when calling Reset with a single integer
-- seed.
Mult1 : constant := 1664525;
Mult2 : constant := 1566083941;
-- Multipliers for two modified linear congruential generators used to
-- initialize the state vector when calling Reset with an initialization
-- vector.
-----------------------
-- Local Subprograms --
-----------------------
procedure Init (Gen : Generator; Initiator : Unsigned_32);
-- Perform a default initialization of the state of Gen. The resulting
-- state is identical for identical values of Initiator.
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : State_Val);
-- Insert image of V into S, in the Index'th 11-character substring
function Extract_Value (S : String; Index : Integer) return State_Val;
-- Treat S as a sequence of 11-character decimal numerals and return
-- the result of converting numeral #Index (numbering from 0)
function To_Unsigned is
new Unchecked_Conversion (Integer_32, Unsigned_32);
function To_Unsigned is
new Unchecked_Conversion (Integer_64, Unsigned_64);
------------
-- Random --
------------
function Random (Gen : Generator) return Unsigned_32 is
G : Generator renames Gen.Writable.Self.all;
Y : State_Val;
I : Integer;
-- Naming exception: I is fine to use here as it is the name used in
-- the original paper describing the Mersenne Twister and in common
-- descriptions of the algorithm.
begin
I := G.I;
if I < N - M then
Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask);
Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1);
I := I + 1;
elsif I < N - 1 then
Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask);
Y := G.S (I + (M - N))
xor Shift_Right (Y, 1)
xor Matrix_A (Y and 1);
I := I + 1;
elsif I = N - 1 then
Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask);
Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1);
I := 0;
else
Init (G, Seed0);
return Random (Gen);
end if;
G.S (G.I) := Y;
G.I := I;
Y := Y xor Shift_Right (Y, U);
Y := Y xor (Shift_Left (Y, S) and B_Mask);
Y := Y xor (Shift_Left (Y, T) and C_Mask);
Y := Y xor Shift_Right (Y, L);
return Y;
end Random;
generic
type Unsigned is mod <>;
type Real is digits <>;
with function Random (G : Generator) return Unsigned is <>;
function Random_Float_Template (Gen : Generator) return Real;
pragma Inline (Random_Float_Template);
-- Template for a random-number generator implementation that delivers
-- values of type Real in the range [0 .. 1], using values from Gen,
-- assuming that Unsigned is large enough to hold the bits of a mantissa
-- for type Real.
---------------------------
-- Random_Float_Template --
---------------------------
function Random_Float_Template (Gen : Generator) return Real is
pragma Compile_Time_Error
(Unsigned'Last <= 2**(Real'Machine_Mantissa - 1),
"insufficiently large modular type used to hold mantissa");
begin
-- This code generates random floating-point numbers from unsigned
-- integers. Assuming that Real'Machine_Radix = 2, it can deliver all
-- machine values of type Real (as implied by Real'Machine_Mantissa and
-- Real'Machine_Emin), which is not true of the standard method (to
-- which we fall back for nonbinary radix): computing Real(<random
-- integer>) / (<max random integer>+1). To do so, we first extract an
-- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then
-- decide on a normalized exponent by repeated coin flips, decrementing
-- from 0 as long as we flip heads (1 bits). This process yields the
-- proper geometric distribution for the exponent: in a uniformly
-- distributed set of floating-point numbers, 1/2 of them will be in
-- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a
-- further adjustment at binade boundaries (see comments below) to give
-- the effect of selecting a uniformly distributed real deviate in
-- [0..1] and then rounding to the nearest representable floating-point
-- number. The algorithm attempts to be stingy with random integers. In
-- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit
-- integers, but this case occurs with probability around
-- 2**Machine_Emin, and the expected number of calls to integer-valued
-- Random is 1. For another discussion of the issues addressed by this
-- process, see Allen Downey's unpublished paper at
-- http://allendowney.com/research/rand/downey07randfloat.pdf.
if Real'Machine_Radix /= 2 then
return Real'Machine
(Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size));
else
declare
type Bit_Count is range 0 .. 4;
subtype T is Real'Base;
Trailing_Ones : constant array (Unsigned_32 range 0 .. 15)
of Bit_Count :=
[2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2,
2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3,
2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2,
2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4];
Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real
:= [0 => 2.0**(0 - T'Machine_Mantissa),
1 => 2.0**(-1 - T'Machine_Mantissa),
2 => 2.0**(-2 - T'Machine_Mantissa),
3 => 2.0**(-3 - T'Machine_Mantissa)];
Extra_Bits : constant Natural :=
(Unsigned'Size - T'Machine_Mantissa + 1);
-- Random bits left over after selecting mantissa
Mantissa : Unsigned;
X : Real; -- Scaled mantissa
R : Unsigned_32; -- Supply of random bits
R_Bits : Natural; -- Number of bits left in R
K : Bit_Count; -- Next decrement to exponent
begin
K := 0;
Mantissa := Random (Gen) / 2**Extra_Bits;
R := Unsigned_32 (Mantissa mod 2**Extra_Bits);
R_Bits := Extra_Bits;
X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact
if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then
-- We got lucky and got a zero in our few extra bits
K := Trailing_Ones (R);
else
Find_Zero : loop
-- R has R_Bits unprocessed random bits, a multiple of 4.
-- X needs to be halved for each trailing one bit. The
-- process stops as soon as a 0 bit is found. If R_Bits
-- becomes zero, reload R.
-- Process 4 bits at a time for speed: the two iterations
-- on average with three tests each was still too slow,
-- probably because the branches are not predictable.
-- This loop now will only execute once 94% of the cases,
-- doing more bits at a time will not help.
while R_Bits >= 4 loop
K := Trailing_Ones (R mod 16);
exit Find_Zero when K < 4; -- Exits 94% of the time
R_Bits := R_Bits - 4;
X := X / 16.0;
R := R / 16;
end loop;
-- Do not allow us to loop endlessly even in the (very
-- unlikely) case that Random (Gen) keeps yielding all ones.
exit Find_Zero when X = 0.0;
R := Random (Gen);
R_Bits := 32;
end loop Find_Zero;
end if;
-- K has the count of trailing ones not reflected yet in X. The
-- following multiplication takes care of that, as well as the
-- correction to move the radix point to the left of the mantissa.
-- Doing it at the end avoids repeated rounding errors in the
-- exceedingly unlikely case of ever having a subnormal result.
X := X * Pow_Tab (K);
-- The smallest value in each binade is rounded to by 0.75 of
-- the span of real numbers as its next larger neighbor, and
-- 1.0 is rounded to by half of the span of real numbers as its
-- next smaller neighbor. To account for this, when we encounter
-- the smallest number in a binade, we substitute the smallest
-- value in the next larger binade with probability 1/2.
if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then
X := 2.0 * X;
end if;
return X;
end;
end if;
end Random_Float_Template;
------------
-- Random --
------------
function Random (Gen : Generator) return Float is
function F is new Random_Float_Template (Unsigned_32, Float);
begin
return F (Gen);
end Random;
function Random (Gen : Generator) return Long_Float is
function F is new Random_Float_Template (Unsigned_64, Long_Float);
begin
return F (Gen);
end Random;
function Random (Gen : Generator) return Unsigned_64 is
begin
return Shift_Left (Unsigned_64 (Unsigned_32'(Random (Gen))), 32)
or Unsigned_64 (Unsigned_32'(Random (Gen)));
end Random;
function Random (Gen : Generator) return Unsigned_128 is
begin
return Shift_Left (Unsigned_128 (Unsigned_64'(Random (Gen))), 64)
or Unsigned_128 (Unsigned_64'(Random (Gen)));
end Random;
---------------------
-- Random_Discrete --
---------------------
function Random_Discrete
(Gen : Generator;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
begin
if Max = Min then
return Max;
elsif Max < Min then
raise Constraint_Error;
-- In the 128-bit case, we have to be careful since not all 128-bit
-- unsigned values are representable in GNAT's universal integer.
elsif Result_Subtype'Base'Size > 64 then
declare
-- Ignore unequal-size warnings since GNAT's handling is correct.
pragma Warnings ("Z");
function Conv_To_Unsigned is
new Unchecked_Conversion (Result_Subtype'Base, Unsigned_128);
function Conv_To_Result is
new Unchecked_Conversion (Unsigned_128, Result_Subtype'Base);
pragma Warnings ("z");
N : constant Unsigned_128 :=
Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1;
X, Slop : Unsigned_128;
begin
if N = 0 then
return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen));
else
Slop := Unsigned_128'Last rem N + 1;
loop
X := Random (Gen);
exit when Slop = N or else X <= Unsigned_128'Last - Slop;
end loop;
return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N);
end if;
end;
-- In the 64-bit case, we have to be careful since not all 64-bit
-- unsigned values are representable in GNAT's universal integer.
elsif Result_Subtype'Base'Size > 32 then
declare
-- Ignore unequal-size warnings since GNAT's handling is correct.
pragma Warnings ("Z");
function Conv_To_Unsigned is
new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64);
function Conv_To_Result is
new Unchecked_Conversion (Unsigned_64, Result_Subtype'Base);
pragma Warnings ("z");
N : constant Unsigned_64 :=
Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1;
X, Slop : Unsigned_64;
begin
if N = 0 then
return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen));
else
Slop := Unsigned_64'Last rem N + 1;
loop
X := Random (Gen);
exit when Slop = N or else X <= Unsigned_64'Last - Slop;
end loop;
return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N);
end if;
end;
-- In the 32-bit case, we need to handle both integer and enumeration
-- types and, therefore, rely on 'Pos and 'Val in the computation.
elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) = 2 ** 32 - 1
then
return Result_Subtype'Val
(Result_Subtype'Pos (Min) + Unsigned_32'Pos (Random (Gen)));
else
declare
N : constant Unsigned_32 :=
Unsigned_32 (Result_Subtype'Pos (Max) -
Result_Subtype'Pos (Min) + 1);
Slop : constant Unsigned_32 := Unsigned_32'Last rem N + 1;
X : Unsigned_32;
begin
loop
X := Random (Gen);
exit when Slop = N or else X <= Unsigned_32'Last - Slop;
end loop;
return
Result_Subtype'Val
(Result_Subtype'Pos (Min) + Unsigned_32'Pos (X rem N));
end;
end if;
end Random_Discrete;
------------------
-- Random_Float --
------------------
function Random_Float (Gen : Generator) return Result_Subtype is
begin
if Result_Subtype'Base'Digits > Float'Digits then
return Result_Subtype'Machine (Result_Subtype
(Long_Float'(Random (Gen))));
else
return Result_Subtype'Machine (Result_Subtype
(Float'(Random (Gen))));
end if;
end Random_Float;
-----------
-- Reset --
-----------
procedure Reset (Gen : Generator) is
begin
Init (Gen, Unsigned_32'Mod (Random_Seed.Get_Seed));
end Reset;
procedure Reset (Gen : Generator; Initiator : Integer_32) is
begin
Init (Gen, To_Unsigned (Initiator));
end Reset;
procedure Reset (Gen : Generator; Initiator : Unsigned_32) is
begin
Init (Gen, Initiator);
end Reset;
procedure Reset (Gen : Generator; Initiator : Integer) is
begin
-- This is probably an unnecessary precaution against future change, but
-- since the test is a static expression, no extra code is involved.
if Integer'Size <= 32 then
Init (Gen, To_Unsigned (Integer_32 (Initiator)));
else
declare
Initiator1 : constant Unsigned_64 :=
To_Unsigned (Integer_64 (Initiator));
Init0 : constant Unsigned_32 :=
Unsigned_32 (Initiator1 mod 2 ** 32);
Init1 : constant Unsigned_32 :=
Unsigned_32 (Shift_Right (Initiator1, 32));
begin
Reset (Gen, Initialization_Vector'(Init0, Init1));
end;
end if;
end Reset;
procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is
G : Generator renames Gen.Writable.Self.all;
I, J : Integer;
begin
Init (G, Seed1);
I := 1;
J := 0;
if Initiator'Length > 0 then
for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop
G.S (I) :=
(G.S (I) xor ((G.S (I - 1)
xor Shift_Right (G.S (I - 1), 30)) * Mult1))
+ Initiator (J + Initiator'First) + Unsigned_32 (J);
I := I + 1;
J := J + 1;
if I >= N then
G.S (0) := G.S (N - 1);
I := 1;
end if;
if J >= Initiator'Length then
J := 0;
end if;
end loop;
end if;
for K in reverse 1 .. N - 1 loop
G.S (I) :=
(G.S (I) xor ((G.S (I - 1)
xor Shift_Right (G.S (I - 1), 30)) * Mult2))
- Unsigned_32 (I);
I := I + 1;
if I >= N then
G.S (0) := G.S (N - 1);
I := 1;
end if;
end loop;
G.S (0) := Upper_Mask;
end Reset;
procedure Reset (Gen : Generator; From_State : Generator) is
G : Generator renames Gen.Writable.Self.all;
begin
G.S := From_State.S;
G.I := From_State.I;
end Reset;
procedure Reset (Gen : Generator; From_State : State) is
G : Generator renames Gen.Writable.Self.all;
begin
G.I := 0;
G.S := From_State;
end Reset;
procedure Reset (Gen : Generator; From_Image : String) is
G : Generator renames Gen.Writable.Self.all;
begin
G.I := 0;
for J in 0 .. N - 1 loop
G.S (J) := Extract_Value (From_Image, J);
end loop;
end Reset;
----------
-- Save --
----------
procedure Save (Gen : Generator; To_State : out State) is
Gen2 : Generator;
begin
if Gen.I = N then
Init (Gen2, 5489);
To_State := Gen2.S;
else
To_State (0 .. N - 1 - Gen.I) := Gen.S (Gen.I .. N - 1);
To_State (N - Gen.I .. N - 1) := Gen.S (0 .. Gen.I - 1);
end if;
end Save;
-----------
-- Image --
-----------
function Image (Of_State : State) return String is
Result : Image_String;
begin
Result := [others => ' '];
for J in Of_State'Range loop
Insert_Image (Result, J, Of_State (J));
end loop;
return Result;
end Image;
function Image (Gen : Generator) return String is
Result : Image_String;
begin
Result := [others => ' '];
for J in 0 .. N - 1 loop
Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N));
end loop;
return Result;
end Image;
---------------
-- Put_Image --
---------------
procedure Put_Image
(S : in out Strings.Text_Buffers.Root_Buffer_Type'Class; V : State) is
begin
Strings.Text_Buffers.Put (S, Image (V));
end Put_Image;
-----------
-- Value --
-----------
function Value (Coded_State : String) return State is
Gen : Generator;
S : State;
begin
Reset (Gen, Coded_State);
Save (Gen, S);
return S;
end Value;
----------
-- Init --
----------
procedure Init (Gen : Generator; Initiator : Unsigned_32) is
G : Generator renames Gen.Writable.Self.all;
begin
G.S (0) := Initiator;
for I in 1 .. N - 1 loop
G.S (I) :=
(G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0
+ Unsigned_32 (I);
end loop;
G.I := 0;
end Init;
------------------
-- Insert_Image --
------------------
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : State_Val)
is
Value : constant String := State_Val'Image (V);
begin
S (Index * 11 + 1 .. Index * 11 + Value'Length) := Value;
end Insert_Image;
-------------------
-- Extract_Value --
-------------------
function Extract_Value (S : String; Index : Integer) return State_Val is
Start : constant Integer := S'First + Index * Image_Numeral_Length;
begin
return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1));
end Extract_Value;
end System.Random_Numbers;