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, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Numerics.Long_Elementary_Functions;
  35 use Ada.Numerics.Long_Elementary_Functions;
  36 with Ada.Unchecked_Conversion;
  37 with System.Random_Numbers; use System.Random_Numbers;
  38
  39 package body GNAT.Random_Numbers is
  40
  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 --
  94    ------------
  95
  96    function Random (Gen : Generator) return Float is
  97    begin
  98       return Random (Gen.Rep);
  99    end Random;
 100
 101    function Random (Gen : Generator) return Long_Float is
 102    begin
 103       return Random (Gen.Rep);
 104    end Random;
 105
 106    function Random (Gen : Generator) return Interfaces.Unsigned_32 is
 107    begin
 108       return Random (Gen.Rep);
 109    end Random;
 110
 111    function Random (Gen : Generator) return Interfaces.Unsigned_64 is
 112    begin
 113       return Random (Gen.Rep);
 114    end Random;
 115
 116    function Random (Gen : Generator) return Integer_64 is
 117    begin
 118       return To_Signed (Unsigned_64'(Random (Gen)));
 119    end Random;
 120
 121    function Random (Gen : Generator) return Integer_32 is
 122    begin
 123       return To_Signed (Unsigned_32'(Random (Gen)));
 124    end Random;
 125
 126    function Random (Gen : Generator) return Long_Integer is
 127       function Random_Long_Integer is new Random_Discrete (Long_Integer);
 128    begin
 129       return Random_Long_Integer (Gen);
 130    end Random;
 131
 132    function Random (Gen : Generator) return Integer is
 133       function Random_Integer is new Random_Discrete (Integer);
 134    begin
 135       return Random_Integer (Gen);
 136    end Random;
 137
 138    ------------------
 139    -- Random_Float --
 140    ------------------
 141
 142    function Random_Float (Gen   : Generator) return Result_Subtype is
 143       function F is new System.Random_Numbers.Random_Float (Result_Subtype);
 144    begin
 145       return F (Gen.Rep);
 146    end Random_Float;
 147
 148    ---------------------
 149    -- Random_Gaussian --
 150    ---------------------
 151
 152    --  Generates pairs of normally distributed values using the polar method of
 153    --  G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The
 154    --  Art of Computer Programming, Vol 2: Seminumerical Algorithms, section
 155    --  3.4.1, subsection C, algorithm P. Returns half of the pair on each call,
 156    --  using the Next_Gaussian field of Gen to hold the second member on
 157    --  even-numbered calls.
 158
 159    function Random_Gaussian (Gen : Generator) return Long_Float is
 160       G : Generator renames Gen'Unrestricted_Access.all;
 161
 162       V1, V2, Rad2, Mult : Long_Float;
 163
 164    begin
 165       if G.Have_Gaussian then
 166          G.Have_Gaussian := False;
 167          return G.Next_Gaussian;
 168
 169       else
 170          loop
 171             V1 := 2.0 * Random (G) - 1.0;
 172             V2 := 2.0 * Random (G) - 1.0;
 173             Rad2 := V1 ** 2 + V2 ** 2;
 174             exit when Rad2 < 1.0 and then Rad2 /= 0.0;
 175          end loop;
 176
 177          --  Now V1 and V2 are coordinates in the unit circle
 178
 179          Mult := Sqrt (-2.0 * Log (Rad2) / Rad2);
 180          G.Next_Gaussian := V2 * Mult;
 181          G.Have_Gaussian := True;
 182          return Long_Float'Machine (V1 * Mult);
 183       end if;
 184    end Random_Gaussian;
 185
 186    function Random_Gaussian (Gen : Generator) return Float is
 187       V : constant Long_Float := Random_Gaussian (Gen);
 188    begin
 189       return Float'Machine (Float (V));
 190    end Random_Gaussian;
 191
 192    -----------
 193    -- Reset --
 194    -----------
 195
 196    procedure Reset (Gen : out Generator) is
 197    begin
 198       Reset (Gen.Rep);
 199       Gen.Have_Gaussian := False;
 200    end Reset;
 201
 202    procedure Reset
 203      (Gen       : out Generator;
 204       Initiator : Initialization_Vector)
 205    is
 206    begin
 207       Reset (Gen.Rep, Initiator);
 208       Gen.Have_Gaussian := False;
 209    end Reset;
 210
 211    procedure Reset
 212      (Gen       : out Generator;
 213       Initiator : Interfaces.Integer_32)
 214    is
 215    begin
 216       Reset (Gen.Rep, Initiator);
 217       Gen.Have_Gaussian := False;
 218    end Reset;
 219
 220    procedure Reset
 221      (Gen       : out Generator;
 222       Initiator : Interfaces.Unsigned_32)
 223    is
 224    begin
 225       Reset (Gen.Rep, Initiator);
 226       Gen.Have_Gaussian := False;
 227    end Reset;
 228
 229    procedure Reset
 230      (Gen       : out Generator;
 231       Initiator : Integer)
 232    is
 233    begin
 234       Reset (Gen.Rep, Initiator);
 235       Gen.Have_Gaussian := False;
 236    end Reset;
 237
 238    procedure Reset
 239      (Gen        : out Generator;
 240       From_State : Generator)
 241    is
 242    begin
 243       Reset (Gen.Rep, From_State.Rep);
 244       Gen.Have_Gaussian := From_State.Have_Gaussian;
 245       Gen.Next_Gaussian := From_State.Next_Gaussian;
 246    end Reset;
 247
 248    Frac_Scale : constant Long_Float :=
 249                   Long_Float
 250                     (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;
 251
 252    function Val64 (Image : String) return Integer_64;
 253    --  Renames Integer64'Value
 254    --  We cannot use a 'renames Integer64'Value' since for some strange
 255    --  reason, this requires a dependency on s-auxdec.ads which not all
 256    --  run-times support ???
 257
 258    function Val64 (Image : String) return Integer_64 is
 259    begin
 260       return Integer_64'Value (Image);
 261    end Val64;
 262
 263    procedure Reset
 264      (Gen        : out Generator;
 265       From_Image : String)
 266    is
 267       F0 : constant Integer := From_Image'First;
 268       T0 : constant Integer := From_Image'First + Sys_Max_Image_Width;
 269
 270    begin
 271       Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width));
 272
 273       if From_Image (T0 + 1) = '1' then
 274          Gen.Have_Gaussian := True;
 275          Gen.Next_Gaussian :=
 276            Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale
 277            * Long_Float (Long_Float'Machine_Radix)
 278            ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last)));
 279       else
 280          Gen.Have_Gaussian := False;
 281       end if;
 282    end Reset;
 283
 284    -----------
 285    -- Image --
 286    -----------
 287
 288    function Image (Gen : Generator) return String is
 289       Result : Image_String;
 290
 291    begin
 292       Result := (others => ' ');
 293       Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep);
 294
 295       if Gen.Have_Gaussian then
 296          Result (Sys_Max_Image_Width + 2) := '1';
 297          Insert_Image (Result, Sys_Max_Image_Width + 4,
 298                        Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian)
 299                                    * Frac_Scale));
 300          Insert_Image (Result, Sys_Max_Image_Width + 24,
 301                        Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian)));
 302
 303       else
 304          Result (Sys_Max_Image_Width + 2) := '0';
 305       end if;
 306
 307       return Result;
 308    end Image;
 309
 310 end GNAT.Random_Numbers;