gcc/ada/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-2013, 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 is
  39
  40    Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;
  41
  42    subtype Image_String is String (1 .. Max_Image_Width);
  43
  44    --  Utility function declarations
  45
  46    procedure Insert_Image
  47      (S     : in out Image_String;
  48       Index : Integer;
  49       V     : Integer_64);
  50    --  Insert string representation of V in S starting at position Index
  51
  52    ---------------
  53    -- To_Signed --
  54    ---------------
  55
  56    function To_Signed is
  57      new Ada.Unchecked_Conversion (Unsigned_32, Integer_32);
  58    function To_Signed is
  59      new Ada.Unchecked_Conversion (Unsigned_64, Integer_64);
  60
  61    ------------------
  62    -- Insert_Image --
  63    ------------------
  64
  65    procedure Insert_Image
  66      (S     : in out Image_String;
  67       Index : Integer;
  68       V     : Integer_64)
  69    is
  70       Image : constant String := Integer_64'Image (V);
  71    begin
  72       S (Index .. Index + Image'Length - 1) := Image;
  73    end Insert_Image;
  74
  75    ---------------------
  76    -- Random_Discrete --
  77    ---------------------
  78
  79    function Random_Discrete
  80      (Gen   : Generator;
  81       Min   : Result_Subtype := Default_Min;
  82       Max   : Result_Subtype := Result_Subtype'Last) return Result_Subtype
  83    is
  84       function F is
  85         new System.Random_Numbers.Random_Discrete
  86               (Result_Subtype, Default_Min);
  87    begin
  88       return F (Gen.Rep, Min, Max);
  89    end Random_Discrete;
  90
  91    --------------------------
  92    -- Random_Decimal_Fixed --
  93    --------------------------
  94
  95    function Random_Decimal_Fixed
  96      (Gen : Generator;
  97       Min : Result_Subtype := Default_Min;
  98       Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
  99    is
 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);
 104    begin
 105       return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
 106    end Random_Decimal_Fixed;
 107
 108    ---------------------------
 109    -- Random_Ordinary_Fixed --
 110    ---------------------------
 111
 112    function Random_Ordinary_Fixed
 113      (Gen : Generator;
 114       Min : Result_Subtype := Default_Min;
 115       Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
 116    is
 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);
 121    begin
 122       return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last));
 123    end Random_Ordinary_Fixed;
 124
 125    ------------
 126    -- Random --
 127    ------------
 128
 129    function Random (Gen : Generator) return Float is
 130    begin
 131       return Random (Gen.Rep);
 132    end Random;
 133
 134    function Random (Gen : Generator) return Long_Float is
 135    begin
 136       return Random (Gen.Rep);
 137    end Random;
 138
 139    function Random (Gen : Generator) return Interfaces.Unsigned_32 is
 140    begin
 141       return Random (Gen.Rep);
 142    end Random;
 143
 144    function Random (Gen : Generator) return Interfaces.Unsigned_64 is
 145    begin
 146       return Random (Gen.Rep);
 147    end Random;
 148
 149    function Random (Gen : Generator) return Integer_64 is
 150    begin
 151       return To_Signed (Unsigned_64'(Random (Gen)));
 152    end Random;
 153
 154    function Random (Gen : Generator) return Integer_32 is
 155    begin
 156       return To_Signed (Unsigned_32'(Random (Gen)));
 157    end Random;
 158
 159    function Random (Gen : Generator) return Long_Integer is
 160       function Random_Long_Integer is new Random_Discrete (Long_Integer);
 161    begin
 162       return Random_Long_Integer (Gen);
 163    end Random;
 164
 165    function Random (Gen : Generator) return Integer is
 166       function Random_Integer is new Random_Discrete (Integer);
 167    begin
 168       return Random_Integer (Gen);
 169    end Random;
 170
 171    ------------------
 172    -- Random_Float --
 173    ------------------
 174
 175    function Random_Float (Gen : Generator) return Result_Subtype is
 176       function F is new System.Random_Numbers.Random_Float (Result_Subtype);
 177    begin
 178       return F (Gen.Rep);
 179    end Random_Float;
 180
 181    ---------------------
 182    -- Random_Gaussian --
 183    ---------------------
 184
 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.
 191
 192    function Random_Gaussian (Gen : Generator) return Long_Float is
 193       G : Generator renames Gen'Unrestricted_Access.all;
 194
 195       V1, V2, Rad2, Mult : Long_Float;
 196
 197    begin
 198       if G.Have_Gaussian then
 199          G.Have_Gaussian := False;
 200          return G.Next_Gaussian;
 201
 202       else
 203          loop
 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;
 208          end loop;
 209
 210          --  Now V1 and V2 are coordinates in the unit circle
 211
 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);
 216       end if;
 217    end Random_Gaussian;
 218
 219    function Random_Gaussian (Gen : Generator) return Float is
 220       V : constant Long_Float := Random_Gaussian (Gen);
 221    begin
 222       return Float'Machine (Float (V));
 223    end Random_Gaussian;
 224
 225    -----------
 226    -- Reset --
 227    -----------
 228
 229    procedure Reset (Gen : out Generator) is
 230    begin
 231       Reset (Gen.Rep);
 232       Gen.Have_Gaussian := False;
 233    end Reset;
 234
 235    procedure Reset
 236      (Gen       : out Generator;
 237       Initiator : Initialization_Vector)
 238    is
 239    begin
 240       Reset (Gen.Rep, Initiator);
 241       Gen.Have_Gaussian := False;
 242    end Reset;
 243
 244    procedure Reset
 245      (Gen       : out Generator;
 246       Initiator : Interfaces.Integer_32)
 247    is
 248    begin
 249       Reset (Gen.Rep, Initiator);
 250       Gen.Have_Gaussian := False;
 251    end Reset;
 252
 253    procedure Reset
 254      (Gen       : out Generator;
 255       Initiator : Interfaces.Unsigned_32)
 256    is
 257    begin
 258       Reset (Gen.Rep, Initiator);
 259       Gen.Have_Gaussian := False;
 260    end Reset;
 261
 262    procedure Reset
 263      (Gen       : out Generator;
 264       Initiator : Integer)
 265    is
 266    begin
 267       Reset (Gen.Rep, Initiator);
 268       Gen.Have_Gaussian := False;
 269    end Reset;
 270
 271    procedure Reset
 272      (Gen        : out Generator;
 273       From_State : Generator)
 274    is
 275    begin
 276       Reset (Gen.Rep, From_State.Rep);
 277       Gen.Have_Gaussian := From_State.Have_Gaussian;
 278       Gen.Next_Gaussian := From_State.Next_Gaussian;
 279    end Reset;
 280
 281    Frac_Scale : constant Long_Float :=
 282                   Long_Float
 283                     (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;
 284
 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 ???
 290
 291    function Val64 (Image : String) return Integer_64 is
 292    begin
 293       return Integer_64'Value (Image);
 294    end Val64;
 295
 296    procedure Reset
 297      (Gen        : out Generator;
 298       From_Image : String)
 299    is
 300       F0 : constant Integer := From_Image'First;
 301       T0 : constant Integer := From_Image'First + Sys_Max_Image_Width;
 302
 303    begin
 304       Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width));
 305
 306       if From_Image (T0 + 1) = '1' then
 307          Gen.Have_Gaussian := True;
 308          Gen.Next_Gaussian :=
 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)));
 312       else
 313          Gen.Have_Gaussian := False;
 314       end if;
 315    end Reset;
 316
 317    -----------
 318    -- Image --
 319    -----------
 320
 321    function Image (Gen : Generator) return String is
 322       Result : Image_String;
 323
 324    begin
 325       Result := (others => ' ');
 326       Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep);
 327
 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)
 332                                    * Frac_Scale));
 333          Insert_Image (Result, Sys_Max_Image_Width + 24,
 334                        Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian)));
 335
 336       else
 337          Result (Sys_Max_Image_Width + 2) := '0';
 338       end if;
 339
 340       return Result;
 341    end Image;
 342
 343 end GNAT.Random_Numbers;