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-2009  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 with System.Random_Numbers; use System.Random_Numbers;
  36
  37 package body GNAT.Random_Numbers is
  38
  39    Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;
  40
  41    subtype Image_String is String (1 .. Max_Image_Width);
  42
  43    --  Utility function declarations
  44
  45    procedure Insert_Image
  46      (S     : in out Image_String;
  47       Index : Integer;
  48       V     : Integer_64);
  49    --  Insert string representation of V in S starting at position Index
  50
  51    ---------------
  52    -- To_Signed --
  53    ---------------
  54
  55    function To_Signed is
  56      new Ada.Unchecked_Conversion (Unsigned_32, Integer_32);
  57    function To_Signed is
  58      new Ada.Unchecked_Conversion (Unsigned_64, Integer_64);
  59
  60    ------------------
  61    -- Insert_Image --
  62    ------------------
  63
  64    procedure Insert_Image
  65      (S     : in out Image_String;
  66       Index : Integer;
  67       V     : Integer_64)
  68    is
  69       Image : constant String := Integer_64'Image (V);
  70    begin
  71       S (Index .. Index + Image'Length - 1) := Image;
  72    end Insert_Image;
  73
  74    ---------------------
  75    -- Random_Discrete --
  76    ---------------------
  77
  78    function Random_Discrete
  79      (Gen   : Generator;
  80       Min   : Result_Subtype := Default_Min;
  81       Max   : Result_Subtype := Result_Subtype'Last) return Result_Subtype
  82    is
  83       function F is
  84         new System.Random_Numbers.Random_Discrete
  85               (Result_Subtype, Default_Min);
  86    begin
  87       return F (Gen.Rep, Min, Max);
  88    end Random_Discrete;
  89
  90    ------------
  91    -- Random --
  92    ------------
  93
  94    function Random (Gen : Generator) return Float is
  95    begin
  96       return Random (Gen.Rep);
  97    end Random;
  98
  99    function Random (Gen : Generator) return Long_Float is
 100    begin
 101       return Random (Gen.Rep);
 102    end Random;
 103
 104    function Random (Gen : Generator) return Interfaces.Unsigned_32 is
 105    begin
 106       return Random (Gen.Rep);
 107    end Random;
 108
 109    function Random (Gen : Generator) return Interfaces.Unsigned_64 is
 110    begin
 111       return Random (Gen.Rep);
 112    end Random;
 113
 114    function Random (Gen : Generator) return Integer_64 is
 115    begin
 116       return To_Signed (Unsigned_64'(Random (Gen)));
 117    end Random;
 118
 119    function Random (Gen : Generator) return Integer_32 is
 120    begin
 121       return To_Signed (Unsigned_32'(Random (Gen)));
 122    end Random;
 123
 124    function Random (Gen : Generator) return Long_Integer is
 125       function Random_Long_Integer is new Random_Discrete (Long_Integer);
 126    begin
 127       return Random_Long_Integer (Gen);
 128    end Random;
 129
 130    function Random (Gen : Generator) return Integer is
 131       function Random_Integer is new Random_Discrete (Integer);
 132    begin
 133       return Random_Integer (Gen);
 134    end Random;
 135
 136    ------------------
 137    -- Random_Float --
 138    ------------------
 139
 140    function Random_Float (Gen   : Generator) return Result_Subtype is
 141       function F is new System.Random_Numbers.Random_Float (Result_Subtype);
 142    begin
 143       return F (Gen.Rep);
 144    end Random_Float;
 145
 146    ---------------------
 147    -- Random_Gaussian --
 148    ---------------------
 149
 150    --  Generates pairs of normally distributed values using the polar method of
 151    --  G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The
 152    --  Art of Computer Programming, Vol 2: Seminumerical Algorithms, section
 153    --  3.4.1, subsection C, algorithm P. Returns half of the pair on each call,
 154    --  using the Next_Gaussian field of Gen to hold the second member on
 155    --  even-numbered calls.
 156
 157    function Random_Gaussian (Gen : Generator) return Long_Float is
 158       G : Generator renames Gen'Unrestricted_Access.all;
 159
 160       V1, V2, Rad2, Mult : Long_Float;
 161
 162    begin
 163       if G.Have_Gaussian then
 164          G.Have_Gaussian := False;
 165          return G.Next_Gaussian;
 166
 167       else
 168          loop
 169             V1 := 2.0 * Random (G) - 1.0;
 170             V2 := 2.0 * Random (G) - 1.0;
 171             Rad2 := V1 ** 2 + V2 ** 2;
 172             exit when Rad2 < 1.0 and then Rad2 /= 0.0;
 173          end loop;
 174
 175          --  Now V1 and V2 are coordinates in the unit circle
 176
 177          Mult := Sqrt (-2.0 * Log (Rad2) / Rad2);
 178          G.Next_Gaussian := V2 * Mult;
 179          G.Have_Gaussian := True;
 180          return Long_Float'Machine (V1 * Mult);
 181       end if;
 182    end Random_Gaussian;
 183
 184    function Random_Gaussian (Gen : Generator) return Float is
 185       V : constant Long_Float := Random_Gaussian (Gen);
 186    begin
 187       return Float'Machine (Float (V));
 188    end Random_Gaussian;
 189
 190    -----------
 191    -- Reset --
 192    -----------
 193
 194    procedure Reset (Gen : out Generator) is
 195    begin
 196       Reset (Gen.Rep);
 197       Gen.Have_Gaussian := False;
 198    end Reset;
 199
 200    procedure Reset
 201      (Gen       : out Generator;
 202       Initiator : Initialization_Vector)
 203    is
 204    begin
 205       Reset (Gen.Rep, Initiator);
 206       Gen.Have_Gaussian := False;
 207    end Reset;
 208
 209    procedure Reset
 210      (Gen       : out Generator;
 211       Initiator : Interfaces.Integer_32)
 212    is
 213    begin
 214       Reset (Gen.Rep, Initiator);
 215       Gen.Have_Gaussian := False;
 216    end Reset;
 217
 218    procedure Reset
 219      (Gen       : out Generator;
 220       Initiator : Interfaces.Unsigned_32)
 221    is
 222    begin
 223       Reset (Gen.Rep, Initiator);
 224       Gen.Have_Gaussian := False;
 225    end Reset;
 226
 227    procedure Reset
 228      (Gen       : out Generator;
 229       Initiator : Integer)
 230    is
 231    begin
 232       Reset (Gen.Rep, Initiator);
 233       Gen.Have_Gaussian := False;
 234    end Reset;
 235
 236    procedure Reset
 237      (Gen        : out Generator;
 238       From_State : Generator)
 239    is
 240    begin
 241       Reset (Gen.Rep, From_State.Rep);
 242       Gen.Have_Gaussian := From_State.Have_Gaussian;
 243       Gen.Next_Gaussian := From_State.Next_Gaussian;
 244    end Reset;
 245
 246    Frac_Scale : constant Long_Float :=
 247                   Long_Float
 248                     (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;
 249
 250    function Val64 (Image : String) return Integer_64;
 251    --  Renames Integer64'Value
 252    --  We cannot use a 'renames Integer64'Value' since for some strange
 253    --  reason, this requires a dependency on s-auxdec.ads which not all
 254    --  run-times support ???
 255
 256    function Val64 (Image : String) return Integer_64 is
 257    begin
 258       return Integer_64'Value (Image);
 259    end Val64;
 260
 261    procedure Reset
 262      (Gen        : out Generator;
 263       From_Image : String)
 264    is
 265       F0 : constant Integer := From_Image'First;
 266       T0 : constant Integer := From_Image'First + Sys_Max_Image_Width;
 267
 268    begin
 269       Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width));
 270
 271       if From_Image (T0 + 1) = '1' then
 272          Gen.Have_Gaussian := True;
 273          Gen.Next_Gaussian :=
 274            Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale
 275            * Long_Float (Long_Float'Machine_Radix)
 276            ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last)));
 277       else
 278          Gen.Have_Gaussian := False;
 279       end if;
 280    end Reset;
 281
 282    -----------
 283    -- Image --
 284    -----------
 285
 286    function Image (Gen : Generator) return String is
 287       Result : Image_String;
 288
 289    begin
 290       Result := (others => ' ');
 291       Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep);
 292
 293       if Gen.Have_Gaussian then
 294          Result (Sys_Max_Image_Width + 2) := '1';
 295          Insert_Image (Result, Sys_Max_Image_Width + 4,
 296                        Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian)
 297                                    * Frac_Scale));
 298          Insert_Image (Result, Sys_Max_Image_Width + 24,
 299                        Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian)));
 300
 301       else
 302          Result (Sys_Max_Image_Width + 2) := '0';
 303       end if;
 304
 305       return Result;
 306    end Image;
 307
 308 end GNAT.Random_Numbers;