Chip 2003 January/Chip_2003-01_cd1.bin/zkuste/delphi/unity/d56/FNDUTL.ZIP/Utils/cRandom.pas

Pascal/Delphi Source File | 2002-10-29 | 8.7 KB | 268 lines

{$INCLUDE ..\cDefines.inc}
unit cRandom;

{                                                                              }
{ Revision history:                                                            }
{   1999/11/07  v0.01  Added RandomSeed.                                       }
{   1999/12/01  v0.02  Added RandomUniform.                                    }
{   2000/01/23  v1.03  Added RandomPseudoWord.                                 }
{   2000/07/13  v1.04  Fixed bug in RandomUniform reported by Andrew Driazgov  }
{                      <[e-mail]>                                    }
{   2000/08/22  v1.05  Added RandomHex.                                        }
{   2000/09/20  v1.06  Added more random states to RandomSeed.                 }
{   2002/06/01  v3.07  Created cRandom unit from cSysUtils and cMaths.         }
{                                                                              }

interface



{                                                                              }
{ RandomSeed                                                                   }
{   Returns a random seed value, based on the Windows counter, the CPU counter }
{   and the current date/time and other 'random' states.                       }
{                                                                              }
Function  RandomSeed : LongWord;

type
  TGUID128 = Array [0..3] of LongWord;

Function  GenerateGUID32 : LongWord;
Function  GenerateGUID64 : Int64;
Function  GenerateGUID128 : TGUID128;



{                                                                              }
{ Uniform random number generator                                              }
{   Returns a random number from a uniform density distribution (ie all number }
{   have an equal probability of being 'chosen')                               }
{   RandomFloat returns an random floating point value between 0 and 1.        }
{   RandomPseudoWord returns a random word-like string.                        }
{                                                                              }
Function  RandomUniform : LongWord; overload;
Function  RandomUniform (const N : Integer) : Integer; overload;
Function  RandomBoolean : Boolean;
Function  RandomInt64 : Int64;
Function  RandomHex (const Digits : Integer = 8) : String;
Function  RandomFloat : Extended;
Function  RandomPseudoWord (const Length : Integer) : String;



implementation

uses
  // Delphi
  Windows,
  SysUtils;



{                                                                              }
{ RandomSeed                                                                   }
{                                                                              }
Function RandomSeed : LongWord;
var I            : Int64;
    Ye, Mo, Da   : Word;
    H, Mi, S, S1 : Word;
  Begin
    Result := $A5F04182;

    // Date
    DecodeDate (Date, Ye, Mo, Da);
    Result := Result xor Ye xor (Mo shl 16) xor (Da shl 24);

    // Time
    DecodeTime (Time, H, Mi, S, S1);
    Result := Result xor H xor (Mi shl 8) xor (S1 shl 16) xor (S shl 24);

    {$IFDEF OS_WIN32}
    // Ticks since start-up
    Result := Result xor GetTickCount;

    // CPU Frequency
    if QueryPerformanceFrequency (I) then
      Result := Result xor LongWord (I) xor LongWord (I shr 32);

    // CPU Counter
    if QueryPerformanceCounter (I) then
      Result := Result xor LongWord (I) xor LongWord (I shr 32);

    // Process
    Result := Result xor GetCurrentProcess xor GetCurrentThread;
    {$ENDIF}
  End;

var
  GUIDInit : Boolean = False;
  GUIDBase : TGUID128 = (0, 0, 0, 0);

Procedure InitGUID;
var I : Integer;
  Begin
    GUIDBase [0] := RandomSeed;
    For I := 1 to 3 do
      GUIDBase [I] := RandomUniform;
    GUIDInit := True;
  End;

Function GenerateGUID32 : LongWord;
  Begin
    if not GUIDInit then
      InitGUID;
    Result := GUIDBase [3];
    GUIDBase [3] := LongWord (GUIDBase [3] + 1);
  End;

Function GenerateGUID64 : Int64;
  Begin
    if not GUIDInit then
      InitGUID;
    Int64Rec (Result).Hi := GUIDBase [2];
    Int64Rec (Result).Lo := GUIDBase [3];
    GUIDBase [3] := LongWord (GUIDBase [3] + 1);
  End;

Function GenerateGUID128 : TGUID128;
  Begin
    if not GUIDInit then
      InitGUID;
    Result := GUIDBase;
    GUIDBase [3] := LongWord (GUIDBase [3] + 1);
    if GUIDBase [3] = 0 then
      GUIDBase [2] := LongWord (GUIDBase [2] + 1);
    GUIDBase [1] := RandomUniform;
  End;



{ Random number generator from ACM Transactions on Modeling and Computer       }
{ Simulation 8(1) 3-30, 1990.  Supposedly it has a period of -1 + 2^19937.     }
{ The original was in C; this translation returns the same values as the       }
{ original.  It is called the Mersenne Twister.                                }
{ The following code was written by Toby Ewing <[e-mail]>, slightly   }
{ modified by Frank Heckenbach <[e-mail]>, again slightly modified  }
{ by David Butler <[e-mail]> for use in Delphi. Bug fixes with reference  }
{ to the original code http://www.math.keio.ac.jp/~matumoto/emt.html, by       }
{ Andrew Driazgov <[e-mail]>.                                        }
{ It was inspired by C code, released under the GNU Library General Public     }
{ License, written by Makoto Matsumoto <[e-mail]> and          }
{ Takuji Nishimura, considering the suggestions by Topher Cooper and           }
{ Marc Rieffel in July-Aug 97.                                                 }
const
  N = 624; // Period parameters
  M = 397;

var
  mti : Integer;
  mt  : Array [0..N - 1] of LongWord; // the array for the state vector
  RandomUniformInitialized : Boolean = False;

{ Set initial seeds to mt [N] using the generator Line 25 of Table 1 in        }
{ [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp 102].      }
Procedure RandomUniformInit (const Seed : LongWord);
var I : Integer;
  Begin
    mt [0] := Seed;
    For I := 1 to N - 1 do
      mt [I] := LongWord (Int64 (69069) * mt [I - 1]);
    mti := N;
    RandomUniformInitialized := True
  End;

Function RandomUniform : LongWord;
const
  Matrix_A = $9908B0DF; // constant vector a
  T_Mask_B = $9D2C5680; // Tempering parameters
  T_Mask_C = $EFC60000;
  Up_Mask  = $80000000; // most significant w-r bits
  Low_Mask = $7FFFFFFF; // least significant r bits
  mag01    : Array [0..1] of LongWord = (0, Matrix_A);

var
  y  : LongWord;
  kk : Integer;

  Begin
    if not RandomUniformInitialized then
      RandomUniformInit (RandomSeed);
    if mti >= N then { generate N words at one time }
      begin
        For kk := 0 to N - M - 1 do
          begin
            y := (mt [kk] and Up_Mask) or (mt [kk + 1] and Low_Mask);
            mt [kk] := mt [kk + M] xor (y shr 1) xor mag01 [y and 1]
          end;
        For kk := N - M to N - 2 do
          begin
            y := (mt [kk] and Up_Mask) or (mt [kk + 1] and Low_Mask);
            mt [kk] := mt [kk + M - N] xor (y shr 1) xor mag01 [y and 1]
          end;
        y := (mt [N - 1] and Up_Mask) or (mt [0] and Low_Mask);
        mt [N - 1] := mt [M - 1] xor (y shr 1) xor mag01 [y and 1];
        mti := 0
      end;
    y := mt [mti];
    Inc (mti);
    y := y xor (y shr 11);
    y := y xor ((y shl 7) and T_Mask_B);
    y := y xor ((y shl 15) and T_Mask_C);
    y := y xor (y shr 18);
    Result := y;
  End;

Function RandomUniform (const N : Integer) : Integer;
  Begin
    if N = 0 then
      Result := 0 else
      Result := Integer (Int64 (RandomUniform) mod N);
  End;

Function RandomBoolean : Boolean;
  Begin
    Result := RandomUniform and 1 = 1;
  End;

Function RandomFloat : Extended;
  Begin
    Result := RandomUniform / High (LongWord);
  End;

Function RandomInt64 : Int64;
  Begin
    Int64Rec (Result).Lo := RandomUniform;
    Int64Rec (Result).Hi := RandomUniform;
  End;

Function RandomHex (const Digits : Integer) : String;
var I : Integer;
  Begin
    Result := '';
    Repeat
      I := Digits - Length (Result);
      if I > 0 then
        Result := Result + IntToHex (RandomUniform, 8);
    Until I <= 0;
    SetLength (Result, Digits);
  End;

Function RandomPseudoWord (const Length : Integer) : String;
const Vowels = 'AEIOUY';
      Consonants = 'BCDFGHJKLMNPQRSTVWXZ';
var I : Integer;
  Begin
    Assert (Length >= 0, 'RandomPseudoWord: Invalid Length parameter');
    SetLength (Result, Length);
    For I := 1 to Length do
      Case RandomUniform (2) of
        0 : Result [I] := Vowels [RandomUniform (6) + 1];
        1 : Result [I] := Consonants [RandomUniform (20) + 1];
      end;
  End;



end.