1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- A D A . N U M E R I C S . F L O A T _ R A N D O M --
10 -- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
37 package body Ada
.Numerics
.Float_Random
is
39 -------------------------
40 -- Implementation Note --
41 -------------------------
43 -- The design of this spec is very awkward, as a result of Ada 95 not
44 -- permitting in-out parameters for function formals (most naturally
45 -- Generator values would be passed this way). In pure Ada 95, the only
46 -- solution is to use the heap and pointers, and, to avoid memory leaks,
49 -- This is awfully heavy, so what we do is to use Unrestricted_Access to
50 -- get a pointer to the state in the passed Generator. This works because
51 -- Generator is a limited type and will thus always be passed by reference.
53 type Pointer
is access all State
;
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
59 procedure Euclid
(P
, Q
: in Int
; X
, Y
: out Int
; GCD
: out Int
);
61 function Euclid
(P
, Q
: Int
) return Int
;
63 function Square_Mod_N
(X
, N
: Int
) return Int
;
69 procedure Euclid
(P
, Q
: in Int
; X
, Y
: out Int
; GCD
: out Int
) is
75 (P
, Q
: in Int
; -- a (i-1), a (i)
76 X
, Y
: in Int
; -- x (i), y (i)
77 XP
, YP
: in out Int
; -- x (i-1), y (i-1)
86 Quo
: Int
:= P
/ Q
; -- q <-- |_ a (i-1) / a (i) _|
87 XT
: Int
:= X
; -- x (i)
88 YT
: Int
:= Y
; -- y (i)
91 if P
rem Q
= 0 then -- while does not divide
96 Recur
(Q
, P
- Q
* Quo
, XP
- Quo
* X
, YP
- Quo
* Y
, XT
, YT
, Quo
);
99 -- a (i+1) <-- a (i-1) - q*a (i)
100 -- x (i+1) <-- x (i-1) - q*x (i)
101 -- y (i+1) <-- y (i-1) - q*y (i)
111 -- Start of processing for Euclid
114 Recur
(P
, Q
, 0, 1, XT
, YT
, GCD
);
119 function Euclid
(P
, Q
: Int
) return Int
is
123 Euclid
(P
, Q
, X
, Y
, GCD
);
131 function Image
(Of_State
: State
) return String is
133 return Int
'Image (Of_State
.X1
) & ',' & Int
'Image (Of_State
.X2
)
135 Int
'Image (Of_State
.P
) & ',' & Int
'Image (Of_State
.Q
);
142 function Random
(Gen
: Generator
) return Uniformly_Distributed
is
143 Genp
: constant Pointer
:= Gen
.Gen_State
'Unrestricted_Access;
146 Genp
.X1
:= Square_Mod_N
(Genp
.X1
, Genp
.P
);
147 Genp
.X2
:= Square_Mod_N
(Genp
.X2
, Genp
.Q
);
149 Float ((Flt
(((Genp
.X2
- Genp
.X1
) * Genp
.X
)
150 mod Genp
.Q
) * Flt
(Genp
.P
)
151 + Flt
(Genp
.X1
)) * Genp
.Scl
);
158 -- Version that works from given initiator value
160 procedure Reset
(Gen
: in Generator
; Initiator
: in Integer) is
161 Genp
: constant Pointer
:= Gen
.Gen_State
'Unrestricted_Access;
165 X1
:= 2 + Int
(Initiator
) mod (K1
- 3);
166 X2
:= 2 + Int
(Initiator
) mod (K2
- 3);
168 -- Eliminate effects of small Initiators.
171 X1
:= Square_Mod_N
(X1
, K1
);
172 X2
:= Square_Mod_N
(X2
, K2
);
184 -- Version that works from specific saved state
186 procedure Reset
(Gen
: Generator
; From_State
: State
) is
187 Genp
: constant Pointer
:= Gen
.Gen_State
'Unrestricted_Access;
190 Genp
.all := From_State
;
193 -- Version that works from calendar
195 procedure Reset
(Gen
: Generator
) is
196 Genp
: constant Pointer
:= Gen
.Gen_State
'Unrestricted_Access;
197 Now
: constant Calendar
.Time
:= Calendar
.Clock
;
201 X1
:= Int
(Calendar
.Year
(Now
)) * 12 * 31 +
202 Int
(Calendar
.Month
(Now
)) * 31 +
203 Int
(Calendar
.Day
(Now
));
205 X2
:= Int
(Calendar
.Seconds
(Now
) * Duration (1000.0));
207 X1
:= 2 + X1
mod (K1
- 3);
208 X2
:= 2 + X2
mod (K2
- 3);
210 -- Eliminate visible effects of same day starts
213 X1
:= Square_Mod_N
(X1
, K1
);
214 X2
:= Square_Mod_N
(X2
, K2
);
232 procedure Save
(Gen
: in Generator
; To_State
: out State
) is
234 To_State
:= Gen
.Gen_State
;
241 function Square_Mod_N
(X
, N
: Int
) return Int
is
242 Temp
: Flt
:= Flt
(X
) * Flt
(X
);
243 Div
: Int
:= Int
(Temp
/ Flt
(N
));
246 Div
:= Int
(Temp
- Flt
(Div
) * Flt
(N
));
259 function Value
(Coded_State
: String) return State
is
260 Start
: Positive := Coded_State
'First;
261 Stop
: Positive := Coded_State
'First;
265 while Coded_State
(Stop
) /= ',' loop
269 Outs
.X1
:= Int
'Value (Coded_State
(Start
.. Stop
- 1));
274 exit when Coded_State
(Stop
) = ',';
277 Outs
.X2
:= Int
'Value (Coded_State
(Start
.. Stop
- 1));
282 exit when Coded_State
(Stop
) = ',';
285 Outs
.P
:= Int
'Value (Coded_State
(Start
.. Stop
- 1));
286 Outs
.Q
:= Int
'Value (Coded_State
(Stop
+ 1 .. Coded_State
'Last));
287 Outs
.X
:= Euclid
(Outs
.P
, Outs
.Q
);
288 Outs
.Scl
:= 1.0 / (Flt
(Outs
.P
) * Flt
(Outs
.Q
));
290 -- Now do *some* sanity checks.
292 if Outs
.Q
< 31 or else Outs
.P
< 31
293 or else Outs
.X1
not in 2 .. Outs
.P
- 1
294 or else Outs
.X2
not in 2 .. Outs
.Q
- 1
296 raise Constraint_Error
;
301 end Ada
.Numerics
.Float_Random
;