path: root/lowlevelunit.pas

unit lowlevelunit;

{$mode objfpc}{$H+}

interface

uses
  math, Classes, SysUtils, gmp, RegExpr, process, FPimage;

type
  generic tArray<T> = array of T;
  tLongintArray = specialize tArray<longint>;
  pTLongintArray = ^tLongintArray;
  tSingleArray = specialize tArray<single>;
  pTSingleArray = ^tSingleArray;
  tIntPoint = array['x'..'y'] of longint;
  tExtPoint = array['x'..'y'] of extended;
  t2x2Longint = array['x'..'y','x'..'y'] of longint;
  t2x2Extended = array['x'..'y','x'..'y'] of extended;
  tExtPointArray = specialize tArray<tExtPoint>;
  pTExtPointArray = ^tExtPointArray;
  tExtendedArray = specialize tArray<extended>;
  pTExtendedArray = ^tExtendedArray;
  tDoubleArray = specialize tArray<single>;
  tInt32Array = specialize tArray<int32>;
  tByteArray = specialize tArray<byte>;
  tStringArray = specialize tArray<string>;
  tIntPointArray = specialize tArray<tIntPoint>;
  tBooleanArray = specialize tArray<boolean>;
  tRGB = record
    rgbBlue : byte;
    rgbGreen: byte;
    rgbRed  : byte;
  end;
  tRgbArray = specialize tArray<tRGB>;
  tKodierung = (kUnbekannt,k32BitSignedInteger);
  tWarnstufe = (wsStreng,wsLasch);
  tGenauigkeit = (gSingle,gDouble,gExtended);

operator = (x1,x2: t2x2Extended): boolean;
operator = (x1,x2: tIntPoint): boolean;
operator = (x1,x2: tExtPoint): boolean;

function signSqr(x: extended): extended; inline;
function mpfToStr(f: mpf_t): string;
function myTimeToStr(t: extended): string;
function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended;
function cmpStr(s1,s2: string): longint;
function mitte(s1,s2: string): string;
function myFloatToStr(x: extended): string; overload;
function myFloatToStr(x: extended; ex: string): string; overload;
function myStrToFloat(s: string): extended;
function myIntToStr(i,dg: longint): string; overload;
function myIntToStr(i,dg: longint; fill: string): string; overload;
function max(g1,g2: tGenauigkeit): tGenauigkeit; inline; overload;
function wertGroesze(g: tGenauigkeit): longint;

function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string;
function binOpPos(op: char; s: string): integer;
function fktPos(fkt,s: string): integer;
procedure gibAus(s: string; ausgaben: byte);
function strToGen(out gen: tGenauigkeit; s: string): boolean;
function mischeFarben(a,b: tRGB; x: extended): tRGB;
function orFarben(a,b: tRGB): tRGB;
function andFarben(a,b: tRGB): tRGB;
function wertZuFarbe(x: extended; p: tRGBArray): tRGB;
function tFPColor2tRgb(c: tFPColor): tRGB;
function tRgb2tFPColor(c: tRGB): tFPColor;
function rgb(r,g,b: byte): tRGB; inline;
function strToTRGB(s: string; out rgb: tRGB): boolean;
procedure myDebugLnThreadLog(s: string);
procedure cleanupLogs;
procedure cleanupLog(tid: PtrUInt);
procedure raiseAndDumpExceptionCallStack(msg: string);
procedure dumpExceptionCallStack(E: Exception);
function startetMit(start: string; var s: string): boolean;
function endetMit(ende: string; var s: string): boolean;
function trimAll(s: string): string;
function erstesArgument(var s: string; Trenner: string = ' '; trimmen: boolean = true): string; inline;
function unEscape(s: string): string;
function mydatetimetostr(t: tDateTime): string;
function t2x2ExtendedToStr(p: t2x2Extended): string;
function tExtPointToStr(p: tExtPoint): string;
function tIntPointToStr(p: tIntPoint): string;
procedure fehler(s: string);

function hexDump(p: pointer; cnt: longint): string;
function base64ToBin(var s: string): boolean;
function base64Decode(const s: string; out i: qword): boolean; overload;
function base64Decode(const s: string; out i: longword): boolean; overload;
function base64Encode(i: longword): string; overload;
function base64Encode(i,siz: longword): string; overload;
function mirrorBits(qw: qword): qword; overload;
function mirrorBits(lw: longword): longword; overload;
function mirrorBits(w: word): word; overload;
function mirrorBits(b: byte): byte; overload;

function zusammenfassen(s1,s2: string): string;
function intervallAusrollen(s: string): string;
function myUtf8Encode(s: string): string;
function permutation(len: longint): tLongintArray; overload;
function permutation(len,rest,maxBasis: longint; basen: tLongintArray): tLongintArray; overload;
procedure llPermutation(len,offset: longint; var ar: tLongintArray); inline;
procedure fuegeSortiertHinzu(x: extended; var xa: tExtendedArray);

var
  base64Chars: array[0..63] of char;
  base64CharsInvers: array[char] of byte;

const
  __ausgabenMaske: byte = 0;

implementation

uses matheunit, systemunit;

// überladene operatoren *******************************************************

operator = (x1,x2: t2x2Extended): boolean;
var
  c,d: char;
begin
  result:=true;
  for c:='x' to 'y' do
    for d:='x' to 'y' do
      result:=result and (x1[c,d]=x2[c,d]);
end;

operator = (x1,x2: tIntPoint): boolean;
var
  c: char;
begin
  result:=true;
  for c:='x' to 'y' do
    result:=result and (x1[c]=x2[c]);
end;

operator = (x1,x2: tExtPoint): boolean;
var
  c: char;
begin
  result:=true;
  for c:='x' to 'y' do
    result:=result and (x1[c]=x2[c]);
end;

// allgemeine Funktionen *******************************************************

function signSqr(x: extended): extended;
begin
  result:=sign(x)*sqr(x);
end;

function mpfToStr(f: mpf_t): string;
var
  ex:  mp_exp_t;
  off: byte;
begin
  result:=mpf_get_str(nil,ex,10,0,f);
  off:=1+byte(pos('-',result)=1);
  if result='' then
    result:='0'
  else if ex=1 then
    result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off)
  else
    result:=copy(result,1,off)+','+copy(result,off+1,length(result)-off)+' * 10^'+inttostr(ex-1);
end;

function myTimeToStr(t: extended): string;
var
  tim: int64;
begin
  tim:=floor(t*24*60*60);
  result:=inttostr(tim mod 10)+'s';
  tim:=tim div 10;
  if tim=0 then exit;
  result:=inttostr(tim mod 6)+result;
  tim:=tim div 6;
  if tim=0 then exit;
  result:=inttostr(tim mod 10)+'min '+result;
  tim:=tim div 10;
  if tim=0 then exit;
  result:=inttostr(tim mod 6)+result;
  tim:=tim div 6;
  if tim=0 then exit;
  result:=inttostr(tim mod 24)+'h '+result;
  tim:=tim div 24;
  if tim=0 then exit;
  result:=' '+result;
  if (tim mod 7)<>1 then
    result:='e'+result;
  result:=inttostr(tim mod 7)+'Tag'+result;
  tim:=tim div 7;
  if tim=0 then exit;
  result:=' '+result;
  if tim<>1 then
    result:='n'+result;
  result:=inttostr(tim)+'Woche'+result;
end;

function mpfMyRoot(rad: mpf_t; wzlExp: int64): extended;
var
  ex: mp_exp_t;
begin
  result:=power(mpf_get_d_2exp(ex,rad),1/wzlExp);
  result:=result*power(2,ex/wzlExp);
end;

function cmpStr(s1,s2: string): longint;
var
  i: longint;
begin
  for i:=1 to min(length(s1),length(s2)) do
    if s1[i]<>s2[i] then begin
      result:=2*byte(s1[i]>s2[i])-1;
      exit;
    end;
  if length(s1)<>length(s2) then begin
    result:=2*byte(length(s1)>length(s2))-1;
    exit;
  end;
  result:=0;
end;

function mitte(s1,s2: string): string;
var
  i:    longint;
  w,nw: word;
begin
  setlength(result,max(length(s1),length(s2)));
  w:=0;
  for i:=length(result) downto 1 do begin // result:= "s1+s2";
    if i<=length(s1) then
      w:=w+byte(s1[i]);
    if i<=length(s2) then
      w:=w+byte(s2[i]);
    result[i]:=char(w and $ff);
    w:=w shr 8;
  end;
  result:=char(w)+result;
  w:=0;
  for i:=1 to length(result) do begin
    nw:=byte(odd(byte(result[i])+w));
    result[i]:=char((byte(result[i])+w) div 2);
    w:=nw shl 8;
  end;
  if w<>0 then
    result:=result+char(w div 2);
  if result[1]<>#0 then begin
    writeln('Fehler bei der Mittenfindeung!');
    halt;
  end;
  delete(result,1,1);
end;

function myFloatToStr(x: extended): string;
begin
  result:=myFloatToStr(x,'E');
end;

function myFloatToStr(x: extended; ex: string): string;
var
  i,e: longint;
begin
  e:=0;
  if x<0 then begin
    result:='-';
    x:=-x;
  end
  else
    result:='';
  if x=0 then begin
    result:='0';
    exit;
  end;
  while x<1 do begin
    dec(e);
    x:=x*10;
  end;
  while x>=10 do begin
    inc(e);
    x:=x/10;
  end;
  result:=result+char(ord('0')+floor(x))+'.';
  for i:=0 to 20 do begin
    x:=(x-floor(x))*10;
    result:=result+char(ord('0')+floor(x));
  end;
  if e<>0 then
    result:=result+ex+inttostr(e);
end;

function myStrToFloat(s: string): extended;
var
  i,e: longint;
  neg: boolean;
begin
  if pos('E',s)>0 then begin
    e:=strtoint(rightStr(s,length(s)-pos('E',s)));
    delete(s,pos('E',s),length(s));
  end
  else e:=0;
  if pos('.',s)=0 then begin
    result:=strtoint(s)*power(10,e);
    exit;
  end;
  neg:=leftStr(s,1)='-';
  if neg then
    delete(s,1,1);
  if pos('.',s)=2 then begin
    result:=0;
    for i:=length(s) downto 3 do
      result:=result/10 + ord(s[i])-ord('0');
    result:=result/10 + ord(s[1])-ord('0');
  end
  else result:=strtofloat(s);
  result:=result*power(10,e);
  if neg then
    result:=-result;
end;

function myIntToStr(i,dg: longint): string;
begin
  result:=myIntToStr(i,dg,' ');
end;

function myIntToStr(i,dg: longint; fill: string): string;
begin
  result:=inttostr(i);
  while length(result)<dg do
    result:=fill+result;
end;

function max(g1,g2: tGenauigkeit): tGenauigkeit;
begin
  if g1>g2 then result:=g1
  else result:=g2;
end;

function wertGroesze(g: tGenauigkeit): longint;
begin
  case g of
    gSingle: result:=sizeof(single);
    gDouble: result:=sizeof(double);
    gExtended: result:=sizeof(extended);
    else
      fehler('Unbekannter Genauigkeitstyp!');
  end;
end;

// allgemeine Funktionen *******************************************************

function floattostrtrunc(f: extended; dig: longint; laessig: boolean): string;
begin
  result:=inttostr(round(f*power(10,dig)));
  result:=copy(result,1,length(result)-dig)+'.'+copy(result,length(result)-dig+1,dig);
  if laessig then
    while result[length(result)]='0' do
      delete(result,length(result),1);
  if result[length(result)]='.' then
    delete(result,length(result),1);
end;

function ZeitDarstellen(t: extended): string;
var
  schreibe: boolean;
begin
  result:='(';
  schreibe:=t>=1;
  if schreibe then begin
    result:=result+inttostr(floor(t))+' Tage ';
    t:=t-floor(t);
  end;
  t:=t*24;
  schreibe:=schreibe or (t>=1);
  if schreibe then begin
    result:=inttostr(floor(t))+':';
    t:=t-floor(t);
  end;
  t:=t*60;
  schreibe:=schreibe or (t>=1);
  if schreibe then begin
    result:=inttostr(floor(t))+':';
    t:=t-floor(t);
  end;
  t:=t*60;
  result:=result+inttostr(round(t))+' s)';
end;

function binOpPos(op: char; s: string): integer;
begin
  result:=0;
  repeat
    result:=result+max(1,pos(op,copy(s,result+1,length(s)-result)));
  until ((result>1) and not (s[result-1] in ['+','-','*','/','(','E','e','^'])) or (result>length(s)) or (s[result]<>op);
  if (result>length(s)) or (s[result]<>op) then result:=0;
end;

function fktPos(fkt,s: string): integer;
var
  tmp: longint;
begin
  result:=pos(fkt,s);
  while (result<>0) and ((result+length(fkt)>length(s)) or not (s[result+length(fkt)] in [' ','('])) do begin
    tmp:=pos(fkt,copy(s,result+1,length(s)));
    if tmp=0 then result:=0
    else result:=result + tmp;
  end;
end;

procedure gibAus(s: string; ausgaben: byte);
begin
  if odd(ausgaben) and not odd(__ausgabenMaske) then myDebugLnThreadLog(s);
  if odd(ausgaben div 2) and not odd(__ausgabenMaske div 2) then writeln(s);
end;

function strToGen(out gen: tGenauigkeit; s: string): boolean;
begin
  result:=true;
  if (s='float') or (s='single') then
    begin
    gen:=gSingle;
    exit;
    end;
  if s='double' then
    begin
    gen:=gDouble;
    exit;
    end;
  if s='extended' then
    begin
    gen:=gExtended;
    exit;
    end;
  gibAus('Kenne Genauigkeitstyp '''+s+''' nicht!',3);
  result:=false;
end;

function mischeFarben(a,b: tRGB; x: extended): tRGB;
begin
  result.rgbRed:=min(255,max(0,round(a.rgbRed*(1-x)+b.rgbRed*x)));
  result.rgbGreen:=min(255,max(0,round(a.rgbGreen*(1-x)+b.rgbGreen*x)));
  result.rgbBlue:=min(255,max(0,round(a.rgbBlue*(1-x)+b.rgbBlue*x)));
end;

function orFarben(a,b: tRGB): tRGB;
begin
  result.rgbRed:=a.rgbRed or b.rgbRed;
  result.rgbGreen:=a.rgbGreen or b.rgbGreen;
  result.rgbBlue:=a.rgbBlue or b.rgbBlue;
end;

function andFarben(a,b: tRGB): tRGB;
begin
  result.rgbRed:=a.rgbRed and b.rgbRed;
  result.rgbGreen:=a.rgbGreen and b.rgbGreen;
  result.rgbBlue:=a.rgbBlue and b.rgbBlue;
end;

function wertZuFarbe(x: extended; p: tRGBArray): tRGB;
var
  i: longint;
begin
  x:=min(1,max(0,x))*(length(p)-1);
  i:=floor(x);
  if i>=(length(p)-1) then begin
    result.rgbRed:=p[length(p)-1].rgbRed;
    result.rgbGreen:=p[length(p)-1].rgbGreen;
    result.rgbBlue:=p[length(p)-1].rgbBlue;
    exit;
  end;
  if i<0 then begin
    result.rgbRed:=p[0].rgbRed;
    result.rgbGreen:=p[0].rgbGreen;
    result.rgbBlue:=p[0].rgbBlue;
    exit;
  end;
  x:=x-i;
  result:=mischeFarben(p[i],p[i+1],x);
end;

function tFPColor2tRgb(c: tFPColor): tRGB;
begin
  result.rgbRed:=c.red;
  result.rgbGreen:=c.green;
  result.rgbBlue:=c.blue;
end;

function tRgb2tFPColor(c: tRGB): tFPColor;
begin
  result.red:=c.rgbRed;
  result.green:=c.rgbGreen;
  result.blue:=c.rgbBlue;
end;

function rgb(r,g,b: byte): tRGB;
begin
  result.rgbRed:=r;
  result.rgbGreen:=g;
  result.rgbBlue:=b;
end;

function strToTRGB(s: string; out rgb: tRGB): boolean;
var
  i: longint;
begin
  result:=false;
  if length(s)=6 then begin
    result:=true;
    for i:=1 to 6 do
      result:=result and (s[i] in ['0'..'9','a'..'f','A'..'F']);
    if result then begin
      i:=strToInt('$'+s);
      rgb.rgbRed:=  (i and $ff0000) shr 16;
      rgb.rgbGreen:=(i and $00ff00) shr 8;
      rgb.rgbBlue:=  i and $0000ff;
      exit;
    end;
  end;
end;

procedure myDebugLnThreadLog(s: string);
var
  f:  textfile;
  id: PtrUInt;
begin
  id:=getThreadID;
  assignfile(f,'Log'+inttostr(id));
  try
    if fileexists('Log'+inttostr(id)) then append(f)
    else rewrite(f);
  except
    exit;
  end;
  writeln(f,inttostr(id)+': '+s);
  closefile(f);
end;

procedure cleanupLogs;
var
  sr:  tSearchRec;
  err: longint;
begin
  err:=findfirst('Log*',$3f,sr);
  while err=0 do begin
    deletefile(sr.name);
    err:=findnext(sr);
  end;
  findclose(sr);
end;

procedure cleanupLog(tid: PtrUInt);
var
  s:    string;
  Zeit: extended;
begin
  s:='Log'+inttostr(tid);
  Zeit:=now+1/24/60/60;
  while (not fileexists(s)) and (Zeit>now) do
    sleep(100);
  if fileexists(s) then
    deletefile(s)
  else
    fehler('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!');
end;

procedure raiseAndDumpExceptionCallStack(msg: string);
var
  e: exception;
begin
  e:=exception.create(msg);
  dumpExceptionCallStack(e);
  raise e;
end;

procedure dumpExceptionCallStack(e: exception);
var
  I:      integer;
  Frames: pPointer;
  Report: string;
begin
  Report := 'Program exception! ' + LineEnding +
    'Stacktrace:' + LineEnding + LineEnding;
  if E <> nil then begin
    Report := Report + 'Exception class: ' + E.ClassName + LineEnding +
    'Message: ' + E.Message + LineEnding;
  end;
  Report := Report + BackTraceStrFunc(ExceptAddr);
  Frames := ExceptFrames;
  for I := 0 to ExceptFrameCount - 1 do
    Report := Report + LineEnding + BackTraceStrFunc(Frames[I]);
  gibAus(Report,3);
end;

function startetMit(start: string; var s: string): boolean;
begin
  result:=leftStr(s,length(start))=start;
  if result then
    s:=trim(rightStr(s,length(s)-length(start)));
end;

function endetMit(ende: string; var s: string): boolean;
begin
  result:=rightStr(s,length(ende))=ende;
  if result then
    s:=trim(leftStr(s,length(s)-length(ende)));
end;

function trimAll(s: string): string;
begin
  result:=s;
  while pos(' ',result)>0 do
    delete(result,pos(' ',result),1);
end;

function erstesArgument(var s: string; Trenner: string; trimmen: boolean): string;
begin
  result:=copy(s,1,pos(Trenner,s+Trenner)-1);
  delete(s,1,length(result)+length(Trenner));
  if not trimmen then exit;
  s:=trim(s);
  result:=trim(result);
end;

function unEscape(s: string): string;
var
  i:     longint;
  ec,qt: boolean;
begin
  result:='';
  ec:=false;
  qt:=false;
  for i:=1 to length(s) do
    if ec then begin
      result:=result+s[i];
      ec:=false;
    end else
    case s[i] of
      '"','''': qt:=not qt;
      '\': ec:=true;
      else result:=result+s[i];
    end{of case};
  if qt then
    fehler('Anführungszeichen sind nicht ausgeglichen in '''+s+'''!');
  if ec then
    fehler(''''+s+''' endet auf einen aktiven Deaktivierer!');
end;

function mydatetimetostr(t: tDateTime): string;
begin
  result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t);
end;

function t2x2ExtendedToStr(p: t2x2Extended): string;
begin
  result:=
    floattostr(p['x','x'])+' .. '+floattostr(p['x','y'])+' x '+
    floattostr(p['y','x'])+' .. '+floattostr(p['y','y']);
end;

function tExtPointToStr(p: tExtPoint): string;
begin
  result:=floattostr(p['x'])+';'+floattostr(p['y']);
end;

function tIntPointToStr(p: tIntPoint): string;
begin
  result:=inttostr(p['x'])+';'+inttostr(p['y']);
end;

procedure fehler(s: string);
begin
  gibAus(s,1);
  raise exception.create(s);
end;

function hexDump(p: pointer; cnt: longint): string;
var
  i: longint;
begin
  result:='';
  for i:=cnt-1 downto 0 do
    result:=result+inttohex((pByte(p)+i)^,2);
end;

function base64ToBin(var s: string): boolean;
var
  i,j: longint;
  t:   string;
  b:   byte;
begin
  t:='';
  result:=false;
  for i:=1 to length(s) do begin
    b:=base64CharsInvers[s[i]];
    if b=255 then exit;
    for j:=5 downto 0 do
      t:=t+char(ord('0')+byte(odd(b shr j)));
  end;
  s:=t;
  result:=true;
end;

function base64Decode(const s: string; out i: qword): boolean;
var
  j: longint;
  b: byte;
begin
  i:=0;
  result:=false;
  for j:=1 to length(s) do begin
    b:=base64CharsInvers[s[j]];
    if b=255 then exit;
    i:=(i shl 6) or b;
  end;
  result:=true;
end;

function base64Decode(const s: string; out i: longword): boolean;
var
  j: qword;
begin
  result:=base64Decode(s,j);
  if result then
    i:=j
  else
    i:=0;
end;

function base64Encode(i: longword): string;
begin
  result:=base64Encode(i,(8*sizeof(i)+7) div 6);
end;

function base64Encode(i,siz: longword): string;
var
  j: longint;
begin
  result:='';
  for j:=0 to siz-1 do begin
    result:=base64Chars[i and $3f]+result;
    i:=i shr 6;
  end;
end;

function mirrorBits(qw: qword): qword;
begin
  result:=
    (mirrorBits(longword(qw and $ffffffff)) shl 32) or
      mirrorBits(longword(qw shr 32));
end;

function mirrorBits(lw: longword): longword;
begin
  result:=
    (mirrorBits(word(lw and $ffff)) shl 16) or
      mirrorBits(word(lw shr 16));
end;

function mirrorBits(w: word): word;
begin
  result:=
    (mirrorBits(byte(w and $ff)) shl 8) or
      mirrorBits(byte(w shr 8));
end;

function mirrorBits(b: byte): byte;
begin
  result:=
      byte(odd(b shr 7)) or
    (byte(odd(b shr 6)) shl 1) or
    (byte(odd(b shr 5)) shl 2) or
    (byte(odd(b shr 4)) shl 3) or
    (byte(odd(b shr 3)) shl 4) or
    (byte(odd(b shr 2)) shl 5) or
    (byte(odd(b shr 1)) shl 6) or
    (byte(odd(b)) shl 7);
end;

function zusammenfassen(s1,s2: string): string;
var
  i: longint;
begin
  if istGanzZahl(s1) and istGanzZahl(s2) then begin
    i:=strtoint(s1)+strtoint(s2);
    result:=inttostr(i);
    if (startetMit('+',s1) or startetMit('+',s2)) and (i>=0) then
      result:='+'+result;
  end
  else if s1=s2 then result:=s1
  else fehler('Ich kann '''+s1+''' und '''+s2+''' nicht zusammenfassen!');
end;

function intervallAusrollen(s: string): string;
var
  i: longint;
begin
  i:=strtoint(erstesArgument(s,'..'));
  result:='';
  while i<=strtoint(s) do begin
    result:=result+' '+myinttostr(i,length(s),'0');
    inc(i);
  end;
  result:=trim(result);
end;

function myUtf8Encode(s: string): string;
const
  falsch:  string = #$c4#$d6#$dc#$df#$e4#$f6#$fc;
  richtig: array[1..7] of string = ('Ä','Ö','Ü','ß','ä','ö','ü');
var
  i: longint;
begin
  result:=s;
  for i:=1 to length(richtig) do
    while pos(falsch[i],result)>0 do
      result:=leftStr(result,pos(falsch[i],result)-1)+richtig[i]+rightStr(result,length(result)-pos(falsch[i],result));
end;

function permutation(len: longint): tLongintArray;
var
  basen:                tLongintArray;
  rest,i,ilen,best,off: longint;
const
  maxBasis = 8;
begin
  rest:=len;
  ilen:=len;
  setlength(basen,0);

  repeat
    for i:=maxBasis downto 2 do
      while ((rest mod i) = 0) and (rest>maxBasis) do begin
        setlength(basen,length(basen)+1);
        basen[length(basen)-1]:=i;
        rest:=rest div i;
      end;
    if rest>maxBasis then begin
      best:=maxBasis;
      for i:=maxBasis-1 downto 2 do
        if i*((rest+i-1) div i)-rest < best*((rest+best-1) div best)-rest then
          best:=i;
      off:=best*((rest+best-1) div best)-rest;  // Bedeutung von off: rest -> rest + off
      ilen:=(ilen div rest)*(rest+off);
      rest:=rest+off;
    end;
  until rest<=maxBasis;

  // len = rest * \prod_i basis[i]
  result:=permutation(ilen,rest,maxBasis,basen);

  if ilen>len then begin
    off:=0;
    i:=0;
    while i+off<ilen do
      if result[i+off]>=len then
        inc(off)
      else begin
        result[i]:=result[i+off];
        inc(i);
      end;
    setlength(result,len);
  end;
end;

function permutation(len,rest,maxBasis: longint; basen: tLongintArray): tLongintArray;
var
  i,block,position,element: longint;
  mergePerm:                tLongintArray;
  werte:                    array[boolean] of tLongintArray;
  aWerte:                   boolean;
begin
  for aWerte:=false to true do
    setlength(werte[aWerte],len);

  aWerte:=false;

  for block:=0 to (len div rest)-1 do          // Initialisierung der $\prod_i basis[i]$ Blöcke zu je $rest$ permutierten Zahlen
    llPermutation(rest,block*rest,werte[aWerte]);

  setlength(mergePerm,maxBasis);

  for i:=0 to length(basen)-1 do begin
    for block:=0 to (len div (rest*basen[i]))-1 do begin
      for position:=0 to rest-1 do begin
        llPermutation(basen[i],0,mergePerm);
        for element:=0 to basen[i]-1 do
          werte[not aWerte,block*rest*basen[i] + position*basen[i] + mergePerm[element]]:=
            werte[aWerte,block*rest*basen[i] + element*rest + position] + element*rest;
      end;
    end;

    aWerte:=not aWerte;
    rest:=rest*basen[i];
  end;

  setlength(mergePerm,0);

  setlength(result,length(werte[aWerte]));
  if length(result)>0 then
    move(werte[aWerte][0],result[0],length(result)*sizeof(result[0]));

  for aWerte:=false to true do
    setlength(werte[aWerte],0);
end;

procedure llPermutation(len,offset: longint; var ar: tLongintArray);
var
  wert,i,j: longint;
begin
  for i:=0 to len-1 do
    ar[i+offset]:=-1;
  for i:=0 to len-1 do begin
    wert:=random(len-i);
    j:=0;
    while j<=wert do begin
      wert:=wert + byte(ar[j+offset]>=0);
      inc(j);
    end;
    ar[wert+offset]:=i;
  end;
  for i:=0 to len-1 do
    if ar[i+offset]=-1 then
      fehler('permutation: '+inttostr(i)+' wurde nicht verteilt!');
end;

procedure fuegeSortiertHinzu(x: extended; var xa: tExtendedArray);
var
  mi,ma,i: longint;
begin
  mi:=0;
  ma:=length(xa)-1;
  while mi<=ma do begin
    i:=(mi+ma) div 2;
    if x<xa[i] then
      ma:=i-1
    else if x>xa[i] then
      mi:=i+1
    else
      exit;
  end;
  if mi<>ma+1 then
    fehler('Bisektion fehlgeschlagen! ('+inttostr(mi)+' = mi <> ma+1 = '+inttostr(ma+1)+')');
  setlength(xa,length(xa)+1);
  for i:=length(xa)-1 downto mi+1 do
    xa[i]:=xa[i-1];
  xa[mi]:=x;
end;

var
  b: byte;

begin
  for b:=0 to 25 do begin
    base64Chars[b]:=   char(b+ord('A'));
    base64Chars[b+26]:=char(b+ord('a'));
  end;
  for b:=0 to 9 do
    base64Chars[52+b]:=char(b+ord('0'));
  base64Chars[62]:='+';
  base64Chars[63]:='/';
  for b:=0 to 255 do
    base64CharsInvers[char(b)]:=255;
  for b:=0 to 63 do
    base64CharsInvers[base64Chars[b]]:=b;
end.