------------------------------------------------------------------------------ | |

-- -- | |

-- 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-2021, 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; |