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--                                                                          --
9--          Copyright (C) 2007-2018, Free Software Foundation, Inc.         --
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- --
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.                                     --
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/>.                                          --
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
32with Ada.Numerics.Long_Elementary_Functions;
33use  Ada.Numerics.Long_Elementary_Functions;
34with Ada.Unchecked_Conversion;
35
36with System.Random_Numbers; use System.Random_Numbers;
37
38package body GNAT.Random_Numbers with
39  SPARK_Mode => Off
40is
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
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
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
176   function Random_Float (Gen : Generator) return Result_Subtype is
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
344end GNAT.Random_Numbers;
345