LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Custom Fast ThreadSafe Random Number Generator for Freepascal
6
   Implementation of XorShift algorithm for random numbers generation.
7
   (based on the "castle game engine"'s random number generator : https://castle-engine.sourceforge.io)
8
   In some cases it works 2 to 3 times faster than native FPC random function.
9

10
  Infos :
11
    - https://en.wikipedia.org/wiki/Linear_congruential_generator
12
    - https://en.wikipedia.org/wiki/Xorshift
13
    - https://en.wikipedia.org/wiki/Multiply-with-carry
14
}
15
Unit GLRandomGenerator;
16

17

18
Interface
19

20
{$I ../GLScene.inc}
21

22
Uses
23
  Classes, Sysutils;
24

25
Type
26
   { Methode aléatoire :
27
      - XorShif64 : Très rapide
28
      - rngtMWC256 : Moins rapide mais plus précis
29
   }
30
   TGLRandomNumGeneratorType = (rngtXorShift64, rngtMWC256); //rngtXorShift128, rngtXorShift1024,
31
   TGLRandomNumGenerator = class
32
    strict private
33
//      cSeed, iSeed : DWord;
34
//      QSeed : Array[0..$FF] of DWord;
35
      FRandSeed:Longint;
36
      FConstantSeed:Longint;
37
      FUseConstantSeed : Boolean;
38
      FRNGType : TGLRandomNumGeneratorType;
39

40
      function GetSeed: Longint; inline;
41
      procedure SetSeed(AValue: Longint);inline;
42
      procedure Initialize(const ASeed:Cardinal);inline;
43

44
      procedure XorShift;inline;
45
      //class function GetRandomSeed: LongInt;
46

47

48
    public
49
      constructor create;
50
      procedure Randomize;inline;
51
      function Random: extended; overload;inline;
52
      function RandomInt: LongWord; inline;
53
      function Random(range:longint):longint;overload;inline;
54
      function Random(range:int64):int64;overload;inline;
55
      procedure ResetSeed;
56
      property RandSeed:Longint Read GetSeed write SetSeed;
57
      //property UseConstantSeed : Boolean read FUseConstantSeed write FUseConstantSeed;
58
    end;
59

60
Var
61
    GLS_RNG : TGLRandomNumGenerator;
62

63
Implementation
64
Const
65
  //CONVERT_MWC256_TO_FLOAT =  2.32830643653869E-10; //1/MaxInt; // Extended (1.0/int64(1 shl 32)); //  0..1
66
  CONVERT_TO_FLOAT = 1/MaxInt;
67

68
//  CONVERT_SIGNED   = Extended (2.0/int64(1 shl 32)); // -1..1
69

70

71
//Threadvar
72
//  GLRNG_RandSeed:Longint;
73
 // GLRNG_OldRandSeed:Cardinal;
74
var
75
   store_64bit_seed: QWord = 0; //this variable stores 64 bit seed for reusing
76
   wait_for_seed: boolean = false;
77

78
function TGLRandomNumGenerator.GetSeed: Longint;
79
begin
80
  Result := FConstantSeed; //GLRNG_RandSeed;
81
end;
82

83
procedure TGLRandomNumGenerator.SetSeed(AValue: Longint);
84
begin
85
  FConstantSeed := AValue;
86
  FRandseed := AValue;
87
  //Initialize(GLRNG_Randseed);
88
end;
89

90
procedure TGLRandomNumGenerator.Initialize(const ASeed: Cardinal);
91
Var I:Integer;
92
begin
93
  if ASeed = 0 then
94
  begin
95
    //For I:=0 to $FF do
96
    //begin
97
      Randomize;
98
      //QSeed[i]:=GLRNG_randseed; //RandSeed;
99
    //End;
100
   // GLRNG_RandSeed := GetRandomSeed;
101
   // Randomize;
102
  end
103
  else
104
  begin
105
    FRandSeed := LongInt(ASeed);
106
    FConstantSeed := FRandSeed;
107
  end;
108
end;
109

110
procedure TGLRandomNumGenerator.ResetSeed;
111
begin
112
  FRandSeed := FConstantSeed;
113
End;
114

115
constructor TGLRandomNumGenerator.create;
116
begin
117
  initialize(0);
118
//  iSeed := 0;
119
//  cSeed:=0;
120
  //GLRNG_OldRandSeed := 0;
121
end;
122

123
(*RandSeed := ((RandSeed shl 8) or GetCurrentProcessID) xor
124
     GetTickCount; *)
125
procedure TGLRandomNumGenerator.Randomize;
126
const
127
  date_multiplier: QWord = 30000000;   //  approximative de la date
128
  date_order: QWord = 80000 * 30000000; // ordre : "now*date_multiplier" variable
129
  {p.s. date_order sera juste jusqu'à l'année ~ 2119}
130

131
var c64: QWord; // graine actuelle;
132
    b64: QWord; // graine supplémentaire pour la sécurité multi-threading
133
    a64: QWord; // une autre graine supplémentaire
134

135
    hours, mins, secs, msecs : Word;
136
  procedure xorshift64;
137
  begin
138
    c64:=c64 xor (c64 shl 12);
139
    c64:=c64 xor (c64 shr 25);
140
    c64:=c64 xor (c64 shl 27);
141
  end;
142
begin
143
  {Nous ajoutons une variable semi-aléatoire supplémentaire basée sur la variable locale c64 :
144
   son adresse 64 bits. Le seul bénéfice que nous avons ici est que cette adresse sera
145
   différent pour les différents threads, donc  2 threads ne peuvent être initialisés
146
   avec des graines égales, même si elles sont absolument simultanées }
147

148
  c64 := QWORD(@(c64));
149
  DecodeTime(Now,Hours,mins,Secs,msecs);
150
  {$R-}
151
  Secs := Secs * 100;
152
  mins := mins * 60;
153
  Hours := Hours * 3600;
154
  {$R+}
155
  a64:=Hours+ Mins + Secs + msecs;
156

157

158
  while wait_for_seed do
159
  begin
160
    //DecodeTime(Now,Hour,mins,Secs,msecs);
161
    //Secs := Secs * 100;
162
    //mins := mins * 60;
163
   // Hour := Hour * 3600;
164
    a64:=a64+QWord(now);
165
    xorshift64; //En attendant, on fait quelque chose
166
  End;
167

168
  wait_for_seed := true;     // Empêche une autre randomisation de commencer jusqu'à ce que celui-ci est fini
169

170
  c64 := (c64 + a64) shr 1;
171
  c64 :=  ((c64 shl 8) or a64) xor GetTickCount64;
172

173
  b64 := c64;   // notre autre graine aléatoire basée sur l'allocation de la mémoire de thread en cours
174

175
  {fondamentalement, nous ne nous soucions pas si les threads passeront accidentellement
176
  'wait_for_seed' le verrouille.
177
   Grâce à b64 nous aurons des valeurs aléatoires différentes, mais ce n'est peut être pas optimal }
178

179
  if store_64bit_seed = 0 then
180
  begin //1ere randomization
181

182

183
   (* DecodeTime(Now,Hour,mins,Secs,msecs);
184
    Secs := Secs * 100;
185
    mins := mins * 60;
186
    Hour := Hour * 3600;
187
    a64:=Hour + Mins + Secs + msecs;
188
    c64 := (c64 + a64) shr 1; *)
189

190
    { Maintenant, nous devons nous assurer que l'ajout de 'a64' ne débordera pas
191
      Nous ajoutons quelques xorshift64 juste pour le plaisir au cas où}
192
    while (c64 > high(QWord)-date_order) do xorshift64;
193

194
    { Pour tuer la valeur discrette aléatoire introduit par gettickcount64 nous ajoutons 'Now'.
195
      'now' et 'gettickcount64' ne sont pas indépendants mais changent synchroniquement.
196
      Après plusieurs xorshift64, c64 n'a plus aucune information
197
      laissé par gettickcount64 et nous introduisons un changement semi-indépendant dans la graine aléatoire}
198
    c64 := c64+ QWord(round(now*date_multiplier));
199

200
    { Un autre cycle xorshift de 64 bits pour tuer tout ce qui reste 'Now' }
201
    xorshift64;
202
    { Maintenant nous sommes sûrs d'obtenir une graine aléatoire différente même
203
      dans le cas où nous lancons la procédure  exactement à la même milliseconde depuis
204
      le démarrage de l'OS.
205
      Une date et heure différentes donneront une autre graine aléatoire ...
206
      A moins de fixer délibérément la date et l'heure }
207

208

209
  end
210
  else
211
    c64 := store_64bit_seed; //On reprend juste la graine déja générer
212

213
 // c64 := c64 shr 1;  // note: nous jetons 1 bit de précision pour gagner de la vitesse
214
  { Maintenant, nous faisons juste un autre xorshift64, car nous avons une variable c64 aléatoire correcte }
215
  xorshift64;
216
  {On fusionne une autre variable aléatoire basée sur le thread en cours }
217
  c64 := c64 xor b64;
218

219
  {et pour finir, afin d"éviter d'avoir une graine à ZERO}
220
  repeat
221
    {Quelques xorshift64 de plus}
222
    xorshift64;
223
    {On garde les 32-bits haut de c64 pour avoir une veribale graine 64bits}
224
    FConstantSeed := longint(c64 shr 32);
225
  until FConstantSeed<>0;
226
 // FConstantSeed := FConstantSeed shr 1;
227
  FRandSeed := FConstantSeed;
228
  { On sauvegarde notre graine pour une réutilisation ultérieur au cas ou }
229
  store_64bit_seed := c64;
230
  {On passe la main au prochain thread}
231
  wait_for_seed := false;
232
end;
233

234
procedure  TGLRandomNumGenerator.XorShift;  inline;
235
begin
236
 // FRandSeed := FRandSeed shr 1;
237
  { Ffonctionne un peu plus vite (+ 4%) en raison d'une meilleure optimisation
238
    par compilateur (utilise des registres de CPU au lieu d'une variable) }
239
  FRandSeed := ((FRandSeed xor (FRandSeed shl 1)) xor ((FRandSeed xor (FRandSeed shl 1)) shr 15)) xor
240
         (((FRandSeed xor (FRandSeed shl 1)) xor ((FRandSeed xor (FRandSeed shl 1)) shr 15)) shl 4);
241

242
  (* FRandSeed:= FRandSeed xor (FRandSeed shl 1);
243
    FRandSeed:= FRandSeed xor (FRandSeed shr 15);
244
    FRandSeed :=FRandSeed xor (FRandSeed shl 4); *)
245

246
end;
247

248

249

250
function TGLRandomNumGenerator.Random: extended;  Inline;
251
//var tSeed : qword;
252
begin
253
  // MWC256 from Usenet posting by G. Marsaglia - Period 2^8222
254
 (* iSeed := (iSeed+1) AND $FF;
255
  tSeed := qword (809430660) * QSeed[iSeed] + cSeed;
256
  cSeed        :=  hi (tSeed);
257
  QSeed[iSeed] := lo (tSeed);
258
  result := CONVERT_TO_FLOAT*(QSeed[iSeed] shr 1); *)
259

260
  XorShift;
261
  result := CONVERT_TO_FLOAT*Longint(FRandSeed shr 1);  // note: nous jetons 1 bit de précision pour gagner de la vitesse
262
end;
263

264
function TGLRandomNumGenerator.Random(range: longint): longint;
265
begin
266
  XorShift;
267
  if range>1 then
268
    result := LongInt((int64(LongWord(FRandSeed))*range) shr 32) // Plus rapide que FRandSeed Mod Range
269
  else
270
    result := 0
271
end;
272

273
function TGLRandomNumGenerator.RandomInt: LongWord;
274
begin
275
  XorShift;
276
  result := LongWord(FRandSeed);
277
end;
278

279
function TGLRandomNumGenerator.Random(range: int64): int64;
280
var c64: QWord;
281
  procedure xorshift64; inline;
282
  begin
283
    c64:=c64 xor (c64 shl 12);
284
    c64:=c64 xor (c64 shr 25);
285
    c64:=c64 xor (c64 shl 27);
286
  end;
287
begin
288
  {Même si N = 0..1 pour faire un cycle de semences aléatoires de 32 bits nous devons le faire deux fois}
289
  c64 := qword(RandomInt) or (qword(RandomInt) shl 32);
290
  if range > 1 then
291
  begin
292
    {l'ajout d'un cycle xorshift64 nous garantit que c64 est vraiment aléatoire
293
     dans la plage 1..high (QWORD) mais ralentit l'exécution de ~ 10%}
294
    xorshift64;
295
    {Contrairement à SysUtils nous en faisons un vrai nombre aléatoire de 64-bit et non pas un faux de 63 bits :)
296
     Il ne peut pas y avoir de débordement ici, parce que N est int64 et il ne peut pas être
297
     plus grand que (Hi(QWORD) div 2)
298
     C'est-à-dire que nous ne pourrons jamais obtenir un résultat 'négatif' car le premier bit du résultat sera toujours zéro }
299
    result := int64(qword(c64) mod qword(Range))
300
  end
301
  else
302
    result := 0;
303
end;
304

305
initialization
306
  GLS_RNG := TGLRandomNumGenerator.create;
307
finalization
308
  FreeAndNil(GLS_RNG);
309
End.
310

311