]>
Commit | Line | Data |
---|---|---|
6812b99b PH |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT RUN-TIME COMPONENTS -- | |
4 | -- -- | |
5 | -- G N A T . R A N D O M _ N U M B E R S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2007-2020, Free Software Foundation, Inc. -- |
6812b99b PH |
10 | -- -- |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
6812b99b PH |
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 -- | |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
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. -- | |
21 | -- -- | |
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/>. -- | |
6812b99b PH |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 | -- -- | |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | with Ada.Numerics.Long_Elementary_Functions; | |
c51f5910 | 33 | use Ada.Numerics.Long_Elementary_Functions; |
6812b99b | 34 | with Ada.Unchecked_Conversion; |
c51f5910 | 35 | |
6812b99b PH |
36 | with System.Random_Numbers; use System.Random_Numbers; |
37 | ||
71140fc6 YM |
38 | package body GNAT.Random_Numbers with |
39 | SPARK_Mode => Off | |
40 | is | |
6812b99b PH |
41 | Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; |
42 | ||
43 | subtype Image_String is String (1 .. Max_Image_Width); | |
44 | ||
45 | -- Utility function declarations | |
46 | ||
47 | procedure Insert_Image | |
48 | (S : in out Image_String; | |
49 | Index : Integer; | |
50 | V : Integer_64); | |
51 | -- Insert string representation of V in S starting at position Index | |
52 | ||
53 | --------------- | |
54 | -- To_Signed -- | |
55 | --------------- | |
56 | ||
57 | function To_Signed is | |
58 | new Ada.Unchecked_Conversion (Unsigned_32, Integer_32); | |
59 | function To_Signed is | |
60 | new Ada.Unchecked_Conversion (Unsigned_64, Integer_64); | |
61 | ||
62 | ------------------ | |
63 | -- Insert_Image -- | |
64 | ------------------ | |
65 | ||
66 | procedure Insert_Image | |
67 | (S : in out Image_String; | |
68 | Index : Integer; | |
69 | V : Integer_64) | |
70 | is | |
71 | Image : constant String := Integer_64'Image (V); | |
72 | begin | |
73 | S (Index .. Index + Image'Length - 1) := Image; | |
74 | end Insert_Image; | |
75 | ||
76 | --------------------- | |
77 | -- Random_Discrete -- | |
78 | --------------------- | |
79 | ||
80 | function Random_Discrete | |
81 | (Gen : Generator; | |
82 | Min : Result_Subtype := Default_Min; | |
83 | Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype | |
84 | is | |
85 | function F is | |
86 | new System.Random_Numbers.Random_Discrete | |
87 | (Result_Subtype, Default_Min); | |
88 | begin | |
89 | return F (Gen.Rep, Min, Max); | |
90 | end Random_Discrete; | |
91 | ||
c51f5910 AC |
92 | -------------------------- |
93 | -- Random_Decimal_Fixed -- | |
94 | -------------------------- | |
95 | ||
96 | function Random_Decimal_Fixed | |
97 | (Gen : Generator; | |
98 | Min : Result_Subtype := Default_Min; | |
99 | Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype | |
100 | is | |
101 | subtype IntV is Integer_64 range | |
102 | Integer_64'Integer_Value (Min) .. | |
103 | Integer_64'Integer_Value (Max); | |
104 | function R is new Random_Discrete (Integer_64, IntV'First); | |
105 | begin | |
106 | return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); | |
107 | end Random_Decimal_Fixed; | |
108 | ||
109 | --------------------------- | |
110 | -- Random_Ordinary_Fixed -- | |
111 | --------------------------- | |
112 | ||
113 | function Random_Ordinary_Fixed | |
114 | (Gen : Generator; | |
115 | Min : Result_Subtype := Default_Min; | |
116 | Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype | |
117 | is | |
118 | subtype IntV is Integer_64 range | |
119 | Integer_64'Integer_Value (Min) .. | |
120 | Integer_64'Integer_Value (Max); | |
121 | function R is new Random_Discrete (Integer_64, IntV'First); | |
122 | begin | |
123 | return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); | |
124 | end Random_Ordinary_Fixed; | |
125 | ||
6812b99b PH |
126 | ------------ |
127 | -- Random -- | |
128 | ------------ | |
129 | ||
130 | function Random (Gen : Generator) return Float is | |
131 | begin | |
132 | return Random (Gen.Rep); | |
133 | end Random; | |
134 | ||
135 | function Random (Gen : Generator) return Long_Float is | |
136 | begin | |
137 | return Random (Gen.Rep); | |
138 | end Random; | |
139 | ||
140 | function Random (Gen : Generator) return Interfaces.Unsigned_32 is | |
141 | begin | |
142 | return Random (Gen.Rep); | |
143 | end Random; | |
144 | ||
145 | function Random (Gen : Generator) return Interfaces.Unsigned_64 is | |
146 | begin | |
147 | return Random (Gen.Rep); | |
148 | end Random; | |
149 | ||
150 | function Random (Gen : Generator) return Integer_64 is | |
151 | begin | |
152 | return To_Signed (Unsigned_64'(Random (Gen))); | |
153 | end Random; | |
154 | ||
155 | function Random (Gen : Generator) return Integer_32 is | |
156 | begin | |
157 | return To_Signed (Unsigned_32'(Random (Gen))); | |
158 | end Random; | |
159 | ||
160 | function Random (Gen : Generator) return Long_Integer is | |
161 | function Random_Long_Integer is new Random_Discrete (Long_Integer); | |
162 | begin | |
163 | return Random_Long_Integer (Gen); | |
164 | end Random; | |
165 | ||
166 | function Random (Gen : Generator) return Integer is | |
167 | function Random_Integer is new Random_Discrete (Integer); | |
168 | begin | |
169 | return Random_Integer (Gen); | |
170 | end Random; | |
171 | ||
172 | ------------------ | |
173 | -- Random_Float -- | |
174 | ------------------ | |
175 | ||
c51f5910 | 176 | function Random_Float (Gen : Generator) return Result_Subtype is |
6812b99b PH |
177 | function F is new System.Random_Numbers.Random_Float (Result_Subtype); |
178 | begin | |
179 | return F (Gen.Rep); | |
180 | end Random_Float; | |
181 | ||
182 | --------------------- | |
183 | -- Random_Gaussian -- | |
184 | --------------------- | |
185 | ||
186 | -- Generates pairs of normally distributed values using the polar method of | |
187 | -- G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The | |
188 | -- Art of Computer Programming, Vol 2: Seminumerical Algorithms, section | |
189 | -- 3.4.1, subsection C, algorithm P. Returns half of the pair on each call, | |
190 | -- using the Next_Gaussian field of Gen to hold the second member on | |
191 | -- even-numbered calls. | |
192 | ||
193 | function Random_Gaussian (Gen : Generator) return Long_Float is | |
194 | G : Generator renames Gen'Unrestricted_Access.all; | |
195 | ||
196 | V1, V2, Rad2, Mult : Long_Float; | |
197 | ||
198 | begin | |
199 | if G.Have_Gaussian then | |
200 | G.Have_Gaussian := False; | |
201 | return G.Next_Gaussian; | |
202 | ||
203 | else | |
204 | loop | |
205 | V1 := 2.0 * Random (G) - 1.0; | |
206 | V2 := 2.0 * Random (G) - 1.0; | |
207 | Rad2 := V1 ** 2 + V2 ** 2; | |
208 | exit when Rad2 < 1.0 and then Rad2 /= 0.0; | |
209 | end loop; | |
210 | ||
211 | -- Now V1 and V2 are coordinates in the unit circle | |
212 | ||
213 | Mult := Sqrt (-2.0 * Log (Rad2) / Rad2); | |
214 | G.Next_Gaussian := V2 * Mult; | |
215 | G.Have_Gaussian := True; | |
216 | return Long_Float'Machine (V1 * Mult); | |
217 | end if; | |
218 | end Random_Gaussian; | |
219 | ||
220 | function Random_Gaussian (Gen : Generator) return Float is | |
221 | V : constant Long_Float := Random_Gaussian (Gen); | |
222 | begin | |
223 | return Float'Machine (Float (V)); | |
224 | end Random_Gaussian; | |
225 | ||
226 | ----------- | |
227 | -- Reset -- | |
228 | ----------- | |
229 | ||
230 | procedure Reset (Gen : out Generator) is | |
231 | begin | |
232 | Reset (Gen.Rep); | |
233 | Gen.Have_Gaussian := False; | |
234 | end Reset; | |
235 | ||
236 | procedure Reset | |
237 | (Gen : out Generator; | |
238 | Initiator : Initialization_Vector) | |
239 | is | |
240 | begin | |
241 | Reset (Gen.Rep, Initiator); | |
242 | Gen.Have_Gaussian := False; | |
243 | end Reset; | |
244 | ||
245 | procedure Reset | |
246 | (Gen : out Generator; | |
247 | Initiator : Interfaces.Integer_32) | |
248 | is | |
249 | begin | |
250 | Reset (Gen.Rep, Initiator); | |
251 | Gen.Have_Gaussian := False; | |
252 | end Reset; | |
253 | ||
254 | procedure Reset | |
255 | (Gen : out Generator; | |
256 | Initiator : Interfaces.Unsigned_32) | |
257 | is | |
258 | begin | |
259 | Reset (Gen.Rep, Initiator); | |
260 | Gen.Have_Gaussian := False; | |
261 | end Reset; | |
262 | ||
263 | procedure Reset | |
264 | (Gen : out Generator; | |
265 | Initiator : Integer) | |
266 | is | |
267 | begin | |
268 | Reset (Gen.Rep, Initiator); | |
269 | Gen.Have_Gaussian := False; | |
270 | end Reset; | |
271 | ||
272 | procedure Reset | |
273 | (Gen : out Generator; | |
274 | From_State : Generator) | |
275 | is | |
276 | begin | |
277 | Reset (Gen.Rep, From_State.Rep); | |
278 | Gen.Have_Gaussian := From_State.Have_Gaussian; | |
279 | Gen.Next_Gaussian := From_State.Next_Gaussian; | |
280 | end Reset; | |
281 | ||
282 | Frac_Scale : constant Long_Float := | |
283 | Long_Float | |
284 | (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa; | |
285 | ||
286 | function Val64 (Image : String) return Integer_64; | |
287 | -- Renames Integer64'Value | |
288 | -- We cannot use a 'renames Integer64'Value' since for some strange | |
289 | -- reason, this requires a dependency on s-auxdec.ads which not all | |
290 | -- run-times support ??? | |
291 | ||
292 | function Val64 (Image : String) return Integer_64 is | |
293 | begin | |
294 | return Integer_64'Value (Image); | |
295 | end Val64; | |
296 | ||
297 | procedure Reset | |
298 | (Gen : out Generator; | |
299 | From_Image : String) | |
300 | is | |
301 | F0 : constant Integer := From_Image'First; | |
302 | T0 : constant Integer := From_Image'First + Sys_Max_Image_Width; | |
303 | ||
304 | begin | |
305 | Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width)); | |
306 | ||
307 | if From_Image (T0 + 1) = '1' then | |
308 | Gen.Have_Gaussian := True; | |
309 | Gen.Next_Gaussian := | |
310 | Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale | |
311 | * Long_Float (Long_Float'Machine_Radix) | |
312 | ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last))); | |
313 | else | |
314 | Gen.Have_Gaussian := False; | |
315 | end if; | |
316 | end Reset; | |
317 | ||
318 | ----------- | |
319 | -- Image -- | |
320 | ----------- | |
321 | ||
322 | function Image (Gen : Generator) return String is | |
323 | Result : Image_String; | |
324 | ||
325 | begin | |
326 | Result := (others => ' '); | |
327 | Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep); | |
328 | ||
329 | if Gen.Have_Gaussian then | |
330 | Result (Sys_Max_Image_Width + 2) := '1'; | |
331 | Insert_Image (Result, Sys_Max_Image_Width + 4, | |
332 | Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian) | |
333 | * Frac_Scale)); | |
334 | Insert_Image (Result, Sys_Max_Image_Width + 24, | |
335 | Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian))); | |
336 | ||
337 | else | |
338 | Result (Sys_Max_Image_Width + 2) := '0'; | |
339 | end if; | |
340 | ||
341 | return Result; | |
342 | end Image; | |
343 | ||
344 | end GNAT.Random_Numbers; |