gcc/ada/a-nuflra.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --            A D A . N U M E R I C S . F L O A T _ R A N D O M             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-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.Calendar;
  35
  36 package body Ada.Numerics.Float_Random is
  37
  38    -------------------------
  39    -- Implementation Note --
  40    -------------------------
  41
  42    --  The design of this spec is very awkward, as a result of Ada 95 not
  43    --  permitting in-out parameters for function formals (most naturally
  44    --  Generator values would be passed this way). In pure Ada 95, the only
  45    --  solution is to use the heap and pointers, and, to avoid memory leaks,
  46    --  controlled types.
  47
  48    --  This is awfully heavy, so what we do is to use Unrestricted_Access to
  49    --  get a pointer to the state in the passed Generator. This works because
  50    --  Generator is a limited type and will thus always be passed by reference.
  51
  52    type Pointer is access all State;
  53
  54    -----------------------
  55    -- Local Subprograms --
  56    -----------------------
  57
  58    procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int);
  59
  60    function  Euclid (P, Q : Int) return Int;
  61
  62    function Square_Mod_N (X, N : Int) return Int;
  63
  64    ------------
  65    -- Euclid --
  66    ------------
  67
  68    procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is
  69
  70       XT : Int := 1;
  71       YT : Int := 0;
  72
  73       procedure Recur
  74         (P,  Q  : Int;                    --  a (i-1), a (i)
  75          X,  Y  : Int;                    --  x (i),   y (i)
  76          XP, YP : in out Int;             --  x (i-1), y (i-1)
  77          GCD    : out Int);
  78
  79       procedure Recur
  80         (P,  Q  : Int;
  81          X,  Y  : Int;
  82          XP, YP : in out Int;
  83          GCD    : out Int)
  84       is
  85          Quo : Int := P / Q;              --  q <-- |_ a (i-1) / a (i) _|
  86          XT  : Int := X;                  --  x (i)
  87          YT  : Int := Y;                  --  y (i)
  88
  89       begin
  90          if P rem Q = 0 then                 --  while does not divide
  91             GCD := Q;
  92             XP  := X;
  93             YP  := Y;
  94          else
  95             Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo);
  96
  97             --  a (i) <== a (i)
  98             --  a (i+1) <-- a (i-1) - q*a (i)
  99             --  x (i+1) <-- x (i-1) - q*x (i)
 100             --  y (i+1) <-- y (i-1) - q*y (i)
 101             --  x (i) <== x (i)
 102             --  y (i) <== y (i)
 103
 104             XP  := XT;
 105             YP  := YT;
 106             GCD := Quo;
 107          end if;
 108       end Recur;
 109
 110    --  Start of processing for Euclid
 111
 112    begin
 113       Recur (P, Q, 0, 1, XT, YT, GCD);
 114       X := XT;
 115       Y := YT;
 116    end Euclid;
 117
 118    function Euclid (P, Q : Int) return Int is
 119       X, Y, GCD : Int;
 120       pragma Unreferenced (Y, GCD);
 121    begin
 122       Euclid (P, Q, X, Y, GCD);
 123       return X;
 124    end Euclid;
 125
 126    -----------
 127    -- Image --
 128    -----------
 129
 130    function Image (Of_State : State) return String is
 131    begin
 132       return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2)
 133              & ',' &
 134              Int'Image (Of_State.P)  & ',' & Int'Image (Of_State.Q);
 135    end Image;
 136
 137    ------------
 138    -- Random --
 139    ------------
 140
 141    function Random  (Gen : Generator) return Uniformly_Distributed is
 142       Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
 143
 144    begin
 145       Genp.X1 := Square_Mod_N (Genp.X1,  Genp.P);
 146       Genp.X2 := Square_Mod_N (Genp.X2,  Genp.Q);
 147       return
 148         Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X)
 149                   mod Genp.Q) * Flt (Genp.P)
 150           + Flt (Genp.X1)) * Genp.Scl);
 151    end Random;
 152
 153    -----------
 154    -- Reset --
 155    -----------
 156
 157    --  Version that works from given initiator value
 158
 159    procedure Reset (Gen : Generator; Initiator : Integer) is
 160       Genp   : constant Pointer := Gen.Gen_State'Unrestricted_Access;
 161       X1, X2 : Int;
 162
 163    begin
 164       X1 := 2 + Int (Initiator) mod (K1 - 3);
 165       X2 := 2 + Int (Initiator) mod (K2 - 3);
 166
 167       --  Eliminate effects of small initiators
 168
 169       for J in 1 .. 5 loop
 170          X1 := Square_Mod_N (X1, K1);
 171          X2 := Square_Mod_N (X2, K2);
 172       end loop;
 173
 174       Genp.all :=
 175         (X1  => X1,
 176          X2  => X2,
 177          P   => K1,
 178          Q   => K2,
 179          X   => 1,
 180          Scl => Scal);
 181    end Reset;
 182
 183    --  Version that works from specific saved state
 184
 185    procedure Reset (Gen : Generator; From_State : State) is
 186       Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
 187
 188    begin
 189       Genp.all := From_State;
 190    end Reset;
 191
 192    --  Version that works from calendar
 193
 194    procedure Reset (Gen : Generator) is
 195       Genp   : constant Pointer       := Gen.Gen_State'Unrestricted_Access;
 196       Now    : constant Calendar.Time := Calendar.Clock;
 197       X1, X2 : Int;
 198
 199    begin
 200       X1 := Int (Calendar.Year  (Now)) * 12 * 31 +
 201             Int (Calendar.Month (Now)) * 31 +
 202             Int (Calendar.Day   (Now));
 203
 204       X2 := Int (Calendar.Seconds (Now) * Duration (1000.0));
 205
 206       X1 := 2 + X1 mod (K1 - 3);
 207       X2 := 2 + X2 mod (K2 - 3);
 208
 209       --  Eliminate visible effects of same day starts
 210
 211       for J in 1 .. 5 loop
 212          X1 := Square_Mod_N (X1, K1);
 213          X2 := Square_Mod_N (X2, K2);
 214       end loop;
 215
 216       Genp.all :=
 217         (X1  => X1,
 218          X2  => X2,
 219          P   => K1,
 220          Q   => K2,
 221          X   => 1,
 222          Scl => Scal);
 223
 224    end Reset;
 225
 226    ----------
 227    -- Save --
 228    ----------
 229
 230    procedure Save (Gen : Generator; To_State : out State) is
 231    begin
 232       To_State := Gen.Gen_State;
 233    end Save;
 234
 235    ------------------
 236    -- Square_Mod_N --
 237    ------------------
 238
 239    function Square_Mod_N (X, N : Int) return Int is
 240       Temp : constant Flt := Flt (X) * Flt (X);
 241       Div  : Int;
 242
 243    begin
 244       Div := Int (Temp / Flt (N));
 245       Div := Int (Temp - Flt (Div) * Flt (N));
 246
 247       if Div < 0 then
 248          return Div + N;
 249       else
 250          return Div;
 251       end if;
 252    end Square_Mod_N;
 253
 254    -----------
 255    -- Value --
 256    -----------
 257
 258    function Value (Coded_State : String) return State is
 259       Last  : constant Natural := Coded_State'Last;
 260       Start : Positive := Coded_State'First;
 261       Stop  : Positive := Coded_State'First;
 262       Outs  : State;
 263
 264    begin
 265       while Stop <= Last and then Coded_State (Stop) /= ',' loop
 266          Stop := Stop + 1;
 267       end loop;
 268
 269       if Stop > Last then
 270          raise Constraint_Error;
 271       end if;
 272
 273       Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1));
 274       Start := Stop + 1;
 275
 276       loop
 277          Stop := Stop + 1;
 278          exit when Stop > Last or else Coded_State (Stop) = ',';
 279       end loop;
 280
 281       if Stop > Last then
 282          raise Constraint_Error;
 283       end if;
 284
 285       Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1));
 286       Start := Stop + 1;
 287
 288       loop
 289          Stop := Stop + 1;
 290          exit when Stop > Last or else Coded_State (Stop) = ',';
 291       end loop;
 292
 293       if Stop > Last then
 294          raise Constraint_Error;
 295       end if;
 296
 297       Outs.P   := Int'Value (Coded_State (Start .. Stop - 1));
 298       Outs.Q   := Int'Value (Coded_State (Stop + 1 .. Last));
 299       Outs.X   := Euclid (Outs.P, Outs.Q);
 300       Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q));
 301
 302       --  Now do *some* sanity checks
 303
 304       if Outs.Q < 31 or else Outs.P < 31
 305         or else Outs.X1 not in 2 .. Outs.P - 1
 306         or else Outs.X2 not in 2 .. Outs.Q - 1
 307       then
 308          raise Constraint_Error;
 309       end if;
 310
 311       return Outs;
 312    end Value;
 313 end Ada.Numerics.Float_Random;