DBR Delphi-Ecke

// Wenn "Random" nicht richtig funktioniert, wenn z.B. trotz
// "Randomize" immer die gleichen Zahlenreihen kommen, dann sollte
// man einen eigenen Zufallsgenerator einsetzen. Die Grundidee stammt
// leider nicht von mir. Sie wurde mir von Jemandem zugemailt, der
// das Ganze auch nur von einem Dritten hatte. Ich habe die Sache
// lediglich etwas bearbeitet.

// Man kopiert die Unit "RandomX.pas" in die Delphi Bibliothek (LIB)
// und bindet sie mit der "Uses"-Klausel in das jeweilige Projekt ein.

// Initialisiert wird der Generator für immer unterschiedliche
// Zahlenreihen mit "Randomize_", und für immer gleiche Zahlenreihen
// mit "Randseed_(aInteger)".

// Aufgerufen wird für Zahlen zwischen 0 und 1:
// var D: Double;
// ...
// D := Random_;

// Und für Zahlen von 0 bis x - 1
// var I: Integer;
// ...
// I := Random_(x); // (mit x > 1)

// Beispiel:
 
uses randomx; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  i: integer; 
begin 
  listbox1.items.clear; 
  listbox2.items.clear; 
  randomize_; 
  for i := 0 to 5 do 
    listbox1.items.add(Format('%:2d', [random_(100)])); 
  RandSeed_(1234567890); 
  for i := 0 to 5 do 
    listbox2.items.add(Format('%:2d', [random_(100)])); 
end;

// Getestet mit D4 unter XP

unit RandomX; 
 
interface 
 
procedure Randomize_; 
procedure RandSeed_(Seed: Integer); 
function Random_(Range: Integer): Integer; 
 
implementation 
 
const 
  PP = 624; 
  SS = 69069; 
  FF = 4294901760; 
  MM = 1 + PP div 2; 
  UMask = 2147483648; 
  BMask = 2636928640; 
  CMask = 4022730752; 
  MTrix = 2567483615; 
  LMask = UMask - 1; 
 
type 
  SA = array[0..PP - 1] of Int64; 
 
var 
  arr: SA; 
  PP1: integer = PP + 1; 
  Minus32: double = -32.0; 
  MG: array[0..1] of Int64 = (0, MTrix); 
 
function generieren: Integer; 
var 
  x: integer; 
  y: Int64; 
begin 
  if PP1 >= PP then begin 
    if PP1 = (PP + 1) then RandSeed_(4357); 
    for x := 0 to PP - MM - 1 do begin 
      y := (arr[x] and UMask) or (arr[x + 1] and LMask); 
      arr[x] := arr[x + MM] xor (y shr 1) xor MG[y and 1]; 
    end; 
    for x := PP - MM to PP - 2 do begin 
      y := (arr[x] and UMask) or (arr[x + 1] and LMask); 
      arr[x] := arr[x + (MM - PP)] xor (y shr 1) xor MG[y and 1]; 
    end; 
    y := (arr[PP - 1] and UMask) or (arr[0] and LMask); 
    arr[PP - 1] := arr[MM - 1] xor (y shr 1) xor MG[y and 1]; 
    PP1 := 0; 
  end; 
  y := arr[PP1]; 
  inc(PP1); 
  y := y xor (y shr 11); 
  y := y xor (y shl 7) and BMask; 
  y := y xor (y shl 15) and CMask; 
  y := y xor (y shr 18); 
  Result := y; 
end; 
 
procedure RandSeed_(seed: Integer); 
var 
  i: integer; 
  function mseed: Integer; 
  begin 
    Result := succ(seed * SS); 
  end; 
  function fseed: Integer; 
  begin 
    Result := seed and FF 
  end; 
begin 
  for i := 0 to PP - 1 do begin 
    arr[i] := fseed; 
    seed := mseed; 
    arr[i] := arr[i] or (fseed shr 16); 
    seed := mseed; 
  end; 
  PP1 := PP; 
end; 
 
procedure Randomize_; 
var 
  SIC: Integer; 
begin 
  SIC := randseed; 
  randomize; 
  RandSeed_(randSeed); 
  randseed := SIC; 
end; 
 
function Random_(Range: Integer): Integer; overload; 
asm 
  PUSH  EAX 
  CALL  generieren 
  POP   EDX 
  MUL   EDX 
  MOV   EAX,EDX 
end; 
 
function Random_: Double; overload; 
asm 
  CALL    generieren 
  PUSH    0 
  PUSH    EAX 
  FLD     Minus32 
  FILD    qword ptr [ESP] 
  ADD     ESP,8 
  FSCALE 
  FSTP    ST(1) 
end; 
 
end.