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>;
  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; 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 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;
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): string; overload; inline;
function erstesArgument(var s: string; Trenner: string): string; overload; inline;
function mydatetimetostr(t: tDateTime): 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;

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 begin
      gibAus('Unbekannter Genauigkeitstyp!',3);
      raise exception.create('Unbekannter Genauigkeitstyp!');
    end;
  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;

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 begin
   gibAus('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!',3);
   raise exception.create('Datei '''+s+''' kann nicht gelöscht werden, da sie nicht existiert!');
 end;
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): string;
begin
 result:=erstesArgument(s,' ');
end;

function erstesArgument(var s: string; Trenner: string): string;
begin
 result:=copy(s,1,pos(Trenner,s+Trenner)-1);
 delete(s,1,length(result)+length(Trenner));
 s:=trim(s);
 result:=trim(result);
end;

function mydatetimetostr(t: tDateTime): string;
begin
 result:=formatDateTime('YYYY.MM.DD_hh.mm.ss',t);
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 raise exception.create('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 begin
      writeln(stderr,'permutation: '+inttostr(i)+' wurde nicht verteilt!');
      raise exception.create('permutation: '+inttostr(i)+' wurde nicht verteilt!');
    end;
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.