gcc/ada/libgnat/g-rannum.adb

   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-2017, 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
  32 with Ada.Numerics.Long_Elementary_Functions;
  33 use  Ada.Numerics.Long_Elementary_Functions;
  34 with Ada.Unchecked_Conversion;
  35
  36 with System.Random_Numbers; use System.Random_Numbers;
  37
  38 package body GNAT.Random_Numbers with
  39   SPARK_Mode => Off
  40 is
  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
 344 end GNAT.Random_Numbers;