1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . R A N D O M _ N U M B E R S --
9 -- Copyright (C) 2007-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Numerics
.Long_Elementary_Functions
;
33 use Ada
.Numerics
.Long_Elementary_Functions
;
34 with Ada
.Unchecked_Conversion
;
36 with System
.Random_Numbers
; use System
.Random_Numbers
;
38 package body GNAT
.Random_Numbers
is
40 Sys_Max_Image_Width
: constant := System
.Random_Numbers
.Max_Image_Width
;
42 subtype Image_String
is String (1 .. Max_Image_Width
);
44 -- Utility function declarations
46 procedure Insert_Image
47 (S
: in out Image_String
;
50 -- Insert string representation of V in S starting at position Index
57 new Ada
.Unchecked_Conversion
(Unsigned_32
, Integer_32
);
59 new Ada
.Unchecked_Conversion
(Unsigned_64
, Integer_64
);
65 procedure Insert_Image
66 (S
: in out Image_String
;
70 Image
: constant String := Integer_64
'Image (V
);
72 S
(Index
.. Index
+ Image
'Length - 1) := Image
;
79 function Random_Discrete
81 Min
: Result_Subtype
:= Default_Min
;
82 Max
: Result_Subtype
:= Result_Subtype
'Last) return Result_Subtype
85 new System
.Random_Numbers
.Random_Discrete
86 (Result_Subtype
, Default_Min
);
88 return F
(Gen
.Rep
, Min
, Max
);
91 --------------------------
92 -- Random_Decimal_Fixed --
93 --------------------------
95 function Random_Decimal_Fixed
97 Min
: Result_Subtype
:= Default_Min
;
98 Max
: Result_Subtype
:= Result_Subtype
'Last) return Result_Subtype
100 subtype IntV
is Integer_64
range
101 Integer_64
'Integer_Value (Min
) ..
102 Integer_64
'Integer_Value (Max
);
103 function R
is new Random_Discrete
(Integer_64
, IntV
'First);
105 return Result_Subtype
'Fixed_Value (R
(Gen
, IntV
'First, IntV
'Last));
106 end Random_Decimal_Fixed
;
108 ---------------------------
109 -- Random_Ordinary_Fixed --
110 ---------------------------
112 function Random_Ordinary_Fixed
114 Min
: Result_Subtype
:= Default_Min
;
115 Max
: Result_Subtype
:= Result_Subtype
'Last) return Result_Subtype
117 subtype IntV
is Integer_64
range
118 Integer_64
'Integer_Value (Min
) ..
119 Integer_64
'Integer_Value (Max
);
120 function R
is new Random_Discrete
(Integer_64
, IntV
'First);
122 return Result_Subtype
'Fixed_Value (R
(Gen
, IntV
'First, IntV
'Last));
123 end Random_Ordinary_Fixed
;
129 function Random
(Gen
: Generator
) return Float is
131 return Random
(Gen
.Rep
);
134 function Random
(Gen
: Generator
) return Long_Float is
136 return Random
(Gen
.Rep
);
139 function Random
(Gen
: Generator
) return Interfaces
.Unsigned_32
is
141 return Random
(Gen
.Rep
);
144 function Random
(Gen
: Generator
) return Interfaces
.Unsigned_64
is
146 return Random
(Gen
.Rep
);
149 function Random
(Gen
: Generator
) return Integer_64
is
151 return To_Signed
(Unsigned_64
'(Random (Gen)));
154 function Random (Gen : Generator) return Integer_32 is
156 return To_Signed (Unsigned_32'(Random
(Gen
)));
159 function Random
(Gen
: Generator
) return Long_Integer is
160 function Random_Long_Integer
is new Random_Discrete
(Long_Integer);
162 return Random_Long_Integer
(Gen
);
165 function Random
(Gen
: Generator
) return Integer is
166 function Random_Integer
is new Random_Discrete
(Integer);
168 return Random_Integer
(Gen
);
175 function Random_Float
(Gen
: Generator
) return Result_Subtype
is
176 function F
is new System
.Random_Numbers
.Random_Float
(Result_Subtype
);
181 ---------------------
182 -- Random_Gaussian --
183 ---------------------
185 -- Generates pairs of normally distributed values using the polar method of
186 -- G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The
187 -- Art of Computer Programming, Vol 2: Seminumerical Algorithms, section
188 -- 3.4.1, subsection C, algorithm P. Returns half of the pair on each call,
189 -- using the Next_Gaussian field of Gen to hold the second member on
190 -- even-numbered calls.
192 function Random_Gaussian
(Gen
: Generator
) return Long_Float is
193 G
: Generator
renames Gen
'Unrestricted_Access.all;
195 V1
, V2
, Rad2
, Mult
: Long_Float;
198 if G
.Have_Gaussian
then
199 G
.Have_Gaussian
:= False;
200 return G
.Next_Gaussian
;
204 V1
:= 2.0 * Random
(G
) - 1.0;
205 V2
:= 2.0 * Random
(G
) - 1.0;
206 Rad2
:= V1
** 2 + V2
** 2;
207 exit when Rad2
< 1.0 and then Rad2
/= 0.0;
210 -- Now V1 and V2 are coordinates in the unit circle
212 Mult
:= Sqrt
(-2.0 * Log
(Rad2
) / Rad2
);
213 G
.Next_Gaussian
:= V2
* Mult
;
214 G
.Have_Gaussian
:= True;
215 return Long_Float'Machine (V1
* Mult
);
219 function Random_Gaussian
(Gen
: Generator
) return Float is
220 V
: constant Long_Float := Random_Gaussian
(Gen
);
222 return Float'Machine (Float (V
));
229 procedure Reset
(Gen
: out Generator
) is
232 Gen
.Have_Gaussian
:= False;
236 (Gen
: out Generator
;
237 Initiator
: Initialization_Vector
)
240 Reset
(Gen
.Rep
, Initiator
);
241 Gen
.Have_Gaussian
:= False;
245 (Gen
: out Generator
;
246 Initiator
: Interfaces
.Integer_32
)
249 Reset
(Gen
.Rep
, Initiator
);
250 Gen
.Have_Gaussian
:= False;
254 (Gen
: out Generator
;
255 Initiator
: Interfaces
.Unsigned_32
)
258 Reset
(Gen
.Rep
, Initiator
);
259 Gen
.Have_Gaussian
:= False;
263 (Gen
: out Generator
;
267 Reset
(Gen
.Rep
, Initiator
);
268 Gen
.Have_Gaussian
:= False;
272 (Gen
: out Generator
;
273 From_State
: Generator
)
276 Reset
(Gen
.Rep
, From_State
.Rep
);
277 Gen
.Have_Gaussian
:= From_State
.Have_Gaussian
;
278 Gen
.Next_Gaussian
:= From_State
.Next_Gaussian
;
281 Frac_Scale
: constant Long_Float :=
283 (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;
285 function Val64
(Image
: String) return Integer_64
;
286 -- Renames Integer64'Value
287 -- We cannot use a 'renames Integer64'Value' since for some strange
288 -- reason, this requires a dependency on s-auxdec.ads which not all
289 -- run-times support ???
291 function Val64
(Image
: String) return Integer_64
is
293 return Integer_64
'Value (Image
);
297 (Gen
: out Generator
;
300 F0
: constant Integer := From_Image
'First;
301 T0
: constant Integer := From_Image
'First + Sys_Max_Image_Width
;
304 Reset
(Gen
.Rep
, From_Image
(F0
.. F0
+ Sys_Max_Image_Width
));
306 if From_Image
(T0
+ 1) = '1' then
307 Gen
.Have_Gaussian
:= True;
309 Long_Float (Val64
(From_Image
(T0
+ 3 .. T0
+ 23))) / Frac_Scale
310 * Long_Float (Long_Float'Machine_Radix)
311 ** Integer (Val64
(From_Image
(T0
+ 25 .. From_Image
'Last)));
313 Gen
.Have_Gaussian
:= False;
321 function Image
(Gen
: Generator
) return String is
322 Result
: Image_String
;
325 Result
:= (others => ' ');
326 Result
(1 .. Sys_Max_Image_Width
) := Image
(Gen
.Rep
);
328 if Gen
.Have_Gaussian
then
329 Result
(Sys_Max_Image_Width
+ 2) := '1';
330 Insert_Image
(Result
, Sys_Max_Image_Width
+ 4,
331 Integer_64
(Long_Float'Fraction (Gen
.Next_Gaussian
)
333 Insert_Image
(Result
, Sys_Max_Image_Width
+ 24,
334 Integer_64
(Long_Float'Exponent (Gen
.Next_Gaussian
)));
337 Result
(Sys_Max_Image_Width
+ 2) := '0';
343 end GNAT
.Random_Numbers
;