path: root/lowlevelunit.pas

unit lowlevelunit;

{$mode objfpc}{$H+}

interface

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

{$IFDEF CPU64}
type
  longestOrdinal = int64;
{$ELSE}
type
  longestOrdinal = longint;
{$ENDIF}

type
  generic tArray<t> = array of t;
  tInt64Array = specialize tArray<int64>;
  tLongintArray = specialize tArray<longint>;
  pTLongintArray = ^tLongintArray;
  tLongintArrayArray = specialize tArray<tLongintArray>;
  pTLongintArrayArray = ^tLongintArrayArray;
  tSingleArray = specialize tArray<single>;
  pTSingleArray = ^tSingleArray;
  tInt64Point = array['x'..'y'] of int64;
  tIntPoint = array['x'..'y'] of longint;
  tExtPoint = array['x'..'y'] of extended;
  tExt3dPoint = array['x'..'z'] of extended;
  t2x2Longint = array['x'..'y','x'..'y'] of longint;
  t2x2Extended = array['x'..'y','x'..'y'] of extended;
  t2x2Int64 = array['x'..'y','x'..'y'] of int64;
  tGerade = record
    a,r: tExtPoint;
  end;
  tExtPointArray = specialize tArray<tExtPoint>;
  tExt3dPointArray = specialize tArray<tExt3dPoint>;
  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>;
  tInt64PointArray = specialize tArray<tInt64Point>;
  tBooleanArray = specialize tArray<boolean>;
  tExtendedArrayArray = specialize tArray<tExtendedArray>;
  tIntPointArrayArray = specialize tArray<tIntPointArray>;
  pTIntPointArrayArray = ^tIntPointArrayArray;
  tGeradenArray = specialize tArray<tGerade>;
  tRGB = record
    rgbBlue : byte;
    rgbGreen: byte;
    rgbRed  : byte;
  end;
  tRGBArray = specialize tArray<tRGB>;
  tKodierung = (kUnbekannt,k32BitSignedInteger);
  tWarnstufe = (wsStreng,wsLasch);
  tGenauigkeit = (gSingle,gDouble,gExtended);
  tKantenFilterTyp = (kfTiefpass,kfHochpass);
  tRegexTyp = (rtKein,rtFpc,rtShell);

operator = (x1,x2: t2x2Extended): boolean; inline;
operator = (x1,x2: t2x2Int64): boolean; inline;
operator = (x1,x2: tInt64Point): boolean; inline;
operator = (x1,x2: tIntPoint): boolean; inline;
operator = (x1,x2: tExtPoint): boolean; inline;
operator + (x1,x2: tExt3dPoint): tExt3dPoint; inline;
operator + (x1,x2: t2x2Extended): t2x2Extended; inline;
operator + (x1,x2: tInt64Point): tInt64Point; inline;
operator + (x1,x2: tIntPoint): tIntPoint; inline;
operator + (x1,x2: tExtPoint): tExtPoint; inline;
operator - (x1,x2: t2x2Extended): t2x2Extended; inline;
operator - (x1,x2: tInt64Point): tInt64Point; inline;
operator - (x1,x2: tIntPoint): tIntPoint; inline;
operator - (x1,x2: tExtPoint): tExtPoint; inline;
operator - (x1,x2: tExt3dPoint): tExt3dPoint; inline;
operator * (a: extended; x: t2x2Extended): t2x2Extended; inline;
operator * (a: int64; x: tInt64Point): tInt64Point; inline;
operator * (a: extended; x: tInt64Point): tExtPoint; inline;
operator * (a: longint; x: tIntPoint): tIntPoint; inline;
operator * (a: extended; x: tIntPoint): tExtPoint; inline;
operator * (a: extended; x: tExtPoint): tExtPoint; inline;
operator * (a: extended; x: tExt3dPoint): tExt3dPoint; inline;
operator * (x1,x2: tIntPoint): int64; inline;
operator * (x1,x2: tInt64Point): int64; inline;
operator * (x1,x2: tExtPoint): extended; inline;
operator * (x1,x2: tExt3dPoint): extended; inline;

function round(x: tExtPoint): tInt64Point; overload;
function symmetrischModulo(x,m: tInt64Point): tInt64Point; overload;
function symmetrischModulo(x: tExtPoint; m: tInt64Point): tExtPoint; overload;
function modulo(x,m: tInt64Point): tInt64Point;
function naechsterSchnittpunkt(ich: tGerade; dieAnderen: tGeradenArray): tExtPoint;

function signSqr(x: extended): extended; inline;
function myTimeToStr(t: extended): string;
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 tKodierungToStr(k: tKodierung): string;

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 genToStr(gen: tGenauigkeit): string;
function mischeFarben(a,b: tRGB; x: extended): tRGB; inline;
function orFarben(a,b: tRGB): tRGB; inline;
function andFarben(a,b: tRGB): tRGB; inline;
function wertZuFarbe(x: extended; p: tRGBArray): tRGB;
function tFPColor2tRgb(c: tFPColor): tRGB; inline;
function tRgb2tFPColor(c: tRGB): tFPColor; inline;
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; trimmen: boolean = true): 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 umbrechen(s,trenner: string; klammernBeachten: boolean = false; zeilenanfang: string = ''): string; inline;
function unEscape(s: string): string;
function myDateTimeToStr(t: tDateTime): string;
function t2x2ExtendedToStr(p: t2x2Extended): string;
function t2x2LongintToStr(p: t2x2Longint): string;
function tExtPointToStr(p: tExtPoint): string;
function tIntPointToStr(p: tIntPoint): string;
function strToTIntPoint(s: string): tIntPoint;
function tInt64PointToStr(p: tInt64Point): string;
procedure fehler(s: string);
function intPoint(x,y: longint): tIntPoint;
function int64Point(x,y: int64): tInt64Point;
function extPoint(x,y: extended): tExtPoint; overload;
function extPoint(x: tInt64Point): tExtPoint; overload;
function _2x2Longint(xx,xy,yx,yy: longint): t2x2Longint;
function _2x2Extended(xx,xy,yx,yy: extended): t2x2Extended;
function ext3dPoint(x,y,z: extended): tExt3dPoint;
function gerade(a,r: tExtPoint): tGerade;
function dumpGerade(g: tGerade): string;
function dumpGeradenArray(ga: tGeradenArray): 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);

procedure readALine(var f: file; out s: string);
procedure readAnAndorString(var f: file; out s: string; const len: int64; checkEOL: boolean); overload;
procedure readAnAndorString(var f: file; out s: string; checkEOL: boolean); overload;

procedure splitStrToInt(s: string; out ia: tLongintArray);
function intArrayToStr(ia: tLongintArray): string;
function vergleicheStrings(s1,s2: string): integer;
function pruefSumme(s: string; m: longestOrdinal): longestOrdinal; inline;

function unEscapeCommas(s: string): string;
function escape(s,toe,es: string): string;
function escapeStringToRegex(s: string; typ: tRegexTyp; extras: string = ''): string; inline;

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

const
  __ausgabenMaske: byte = 0;

implementation

uses
  matheunit;


// ü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: t2x2Int64): 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: tInt64Point): boolean;
var
  c: char;
begin
  result:=true;
  for c:='x' to 'y' do
    result:=result and (x1[c]=x2[c]);
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;

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

operator + (x1,x2: tInt64Point): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=x1[c]+x2[c];
end;

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

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

operator + (x1,x2: tExt3dPoint): tExt3dPoint;
var
  c: char;
begin
  for c:='x' to 'z' do
    result[c]:=x1[c]+x2[c];
end;

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

operator - (x1,x2: tInt64Point): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=x1[c]-x2[c];
end;

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

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

operator - (x1,x2: tExt3dPoint): tExt3dPoint;
var
  c: char;
begin
  for c:='x' to 'z' do
    result[c]:=x1[c]-x2[c];
end;

operator * (a: extended; x: t2x2Extended): t2x2Extended;
var
  c,d: char;
begin
  for c:='x' to 'y' do
    for d:='x' to 'y' do
      result[c,d]:=a*x[c,d];
end;

operator * (a: int64; x: tInt64Point): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=a*x[c];
end;

operator * (a: extended; x: tInt64Point): tExtPoint;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=a*x[c];
end;

operator * (a: longint; x: tIntPoint): tIntPoint;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=a*x[c];
end;

operator * (a: extended; x: tIntPoint): tExtPoint;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=a*x[c];
end;

operator * (x1,x2: tIntPoint): int64;
var
  c: char;
begin
  result:=0;
  for c:='x' to 'y' do
    result:=result + x1[c]*x2[c];
end;

operator * (x1,x2: tInt64Point): int64;
var
  c: char;
begin
  result:=0;
  for c:='x' to 'y' do
    result:=result + x1[c]*x2[c];
end;

operator * (a: extended; x: tExtPoint): tExtPoint;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=a*x[c];
end;

operator * (a: extended; x: tExt3dPoint): tExt3dPoint;
var
  c: char;
begin
  for c:='x' to 'z' do
    result[c]:=a*x[c];
end;

operator * (x1,x2: tExtPoint): extended;
begin
  result:=x1['x']*x2['x'] + x1['y']*x2['y'];
end;

operator * (x1,x2: tExt3dPoint): extended;
begin
  result:=x1['x']*x2['x'] + x1['y']*x2['y'];
end;

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

function round(x: tExtPoint): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do
    result[c]:=round(x[c]);
end;

function symmetrischModulo(x,m: tInt64Point): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do begin
    result[c]:=x[c];
    while 2*result[c]<-m[c] do
      result[c]:=result[c]+m[c];
    while 2*result[c]>=m[c] do
      result[c]:=result[c]-m[c];
  end;
end;

function symmetrischModulo(x: tExtPoint; m: tInt64Point): tExtPoint;
var
  c: char;
begin
  for c:='x' to 'y' do begin
    result[c]:=x[c];
    while 2*result[c]<-m[c] do
      result[c]:=result[c]+m[c];
    while 2*result[c]>=m[c] do
      result[c]:=result[c]-m[c];
  end;
end;

function modulo(x,m: tInt64Point): tInt64Point;
var
  c: char;
begin
  for c:='x' to 'y' do begin
    result[c]:=x[c];
    while result[c]<0 do
      result[c]:=result[c]+m[c];
    while result[c]>=m[c] do
      result[c]:=result[c]-m[c];
  end;
end;

function naechsterSchnittpunkt(ich: tGerade; dieAnderen: tGeradenArray): tExtPoint;
var
  i:      longestOrdinal;
  lMin,l: extended;
  n:      tExtPoint;
begin
  lMin:=-1;
  for i:=0 to length(dieAnderen)-1 do begin
    n:=extPoint(dieAnderen[i].r['y'],-dieAnderen[i].r['x']);
    if n * ich.r = 0 then // Gerade parallel zu r
      continue;
    l:=(n*(dieAnderen[i].a-ich.a))/(n*ich.r);
    if l<0 then // Schnittpunkt auf der falschen Seite
      continue;
    if (l<lMin) or (lMin<0) then
      lMin:=l;
  end;
  if lMin<0 then
    fehler(
      'Konnte keinen Schnittpunkt (auf dieser Seite) finden (' +
      dumpGerade(ich) + ' geschnitten mit ' +
      dumpGeradenArray(dieAnderen) +
      ')!');
  result:=ich.a + lMin*ich.r;
end;

function signSqr(x: extended): extended;
begin
  result:=sign(x)*sqr(x);
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 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;

function tKodierungToStr(k: tKodierung): string;
begin
  case k of
    kUnbekannt:
      result:='kUnbekannt';
    k32BitSignedInteger:
      result:='k32BitSignedInteger';
    else
      result:='NONE';
  end{of Case};
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 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 genToStr(gen: tGenauigkeit): string;
begin
  case gen of
    gSingle:
      result:='single';
    gDouble:
      result:='double';
    gExtended:
      result:='extended';
    else
      result:='NONE';
  end{of case};
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; trimmen: boolean = true): boolean;
begin
  result:=leftStr(s,length(start))=start;
  if result then begin
    s:=rightStr(s,length(s)-length(start));
    if trimmen then
      s:=trim(s);
  end;
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 umbrechen(s,trenner: string; klammernBeachten: boolean = false; zeilenanfang: string = ''): string; inline;
var
  i,kl: longint;
begin
  result:='';
  i:=1;
  kl:=0;
  while i<=length(s) do begin
    if klammernBeachten and (s[i] in ['(','[','{']) then
      inc(kl);
    if klammernBeachten and (s[i] in [')',']','}']) then
      dec(kl);
    if (kl=0) and (copy(s,i,length(trenner))=trenner) then begin
      result:=result+#13+zeilenanfang+copy(s,1,i-1);
      delete(s,1,i-1+length(trenner));
      i:=0;
    end;
    inc(i);
  end;
  result:=result+#13+zeilenanfang+s;
  delete(result,1,1+length(zeilenanfang));
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 t2x2LongintToStr(p: t2x2Longint): string;
begin
  result:=
    intToStr(p['x','x'])+' .. '+intToStr(p['x','y'])+' x '+
    intToStr(p['y','x'])+' .. '+intToStr(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;

function strToTIntPoint(s: string): tIntPoint;
begin
  result['x']:=strToInt(erstesArgument(s,';'));
  result['y']:=strToInt(s);
end;

function tInt64PointToStr(p: tInt64Point): string;
begin
  result:=intToStr(p['x'])+';'+intToStr(p['y']);
end;

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

function intPoint(x,y: longint): tIntPoint;
begin
  result['x']:=x;
  result['y']:=y;
end;

function int64Point(x,y: int64): tInt64Point;
begin
  result['x']:=x;
  result['y']:=y;
end;

function extPoint(x,y: extended): tExtPoint;
begin
  result['x']:=x;
  result['y']:=y;
end;

function extPoint(x: tInt64Point): tExtPoint;
begin
  result['x']:=x['x'];
  result['y']:=x['y'];
end;

function _2x2Longint(xx,xy,yx,yy: longint): t2x2Longint;
begin
  result['x','x']:=xx;
  result['x','y']:=xy;
  result['y','x']:=yx;
  result['y','y']:=yy;
end;

function _2x2Extended(xx,xy,yx,yy: extended): t2x2Extended;
begin
  result['x','x']:=xx;
  result['x','y']:=xy;
  result['y','x']:=yx;
  result['y','y']:=yy;
end;

function ext3dPoint(x,y,z: extended): tExt3dPoint;
begin
  result['x']:=x;
  result['y']:=y;
  result['z']:=z;
end;

function gerade(a,r: tExtPoint): tGerade;
begin
  result.a:=a;
  result.r:=r;
end;

function dumpGerade(g: tGerade): string;
begin
  result:=
    'a: (' + tExtPointToStr(g.a) + ') ' +
    'r: (' + tExtPointToStr(g.r) + ')';
end;

function dumpGeradenArray(ga: tGeradenArray): string;
var
  i: longestOrdinal;
begin
  result:='{';
  for i:=0 to length(ga)-1 do begin
    if i>0 then
      result:=result+', ';
    result:=result+dumpGerade(ga[i]);
  end;
  result:=result+'}';
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+' '+intToStr(i);
    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;

procedure readALine(var f: file; out s: string);
var
  fPos,fSize,rLen: int64;
begin
  fPos:=filePos(f);
  fSize:=fileSize(f);
  rLen:=0;
  s:='';
  while (pos(#10,s)=0) and (rLen+fPos<fSize) do begin
    rLen:=min(rLen+1024,fSize-fPos);
    setLength(s,rLen);
    blockRead(f,s[1],rLen);
    seek(f,fPos);
  end;
  if pos(#10,s)<>0 then begin
    rLen:=pos(#10,s);
    setLength(s,rLen-1);
  end;
  seek(f,fPos+rLen);
end;

procedure readAnAndorString(var f: file; out s: string; const len: int64; checkEOL: boolean);
begin
  setLength(s,len+2*byte(checkEOL));
  if length(s)>0 then
    blockRead(f,s[1],length(s));
  if checkEOL then begin
    if rightStr(s,2)<>' '#10 then
      raise exception.create('readAnAndorString: EOL check failed: '''+s+'''!');
    setLength(s,length(s)-2);
  end;
end;

procedure readAnAndorString(var f: file; out s: string; checkEOL: boolean);
begin
  readALine(f,s);
  readAnAndorString(f,s,strToInt64(s),checkEOL);
end;

procedure splitStrToInt(s: string; out ia: tLongintArray);
begin
  setLength(ia,0);
  while s<>'' do begin
    setLength(ia,length(ia)+1);
    ia[length(ia)-1]:=strToInt(erstesArgument(s,' ',false));
  end;
end;

function intArrayToStr(ia: tLongintArray): string;
var
  i: longint;
begin
  result:='';
  for i:=0 to length(ia)-1 do begin
    if i>0 then
      result:=result + ' ';
    result:=result + intToStr(ia[i]);
  end;

end;

function vergleicheStrings(s1,s2: string): integer;
var
  i: longint;
begin
  result:=0;
  i:=1;
  while (i<=length(s1)) and (i<=length(s2)) do begin
    if s1[i]<s2[i] then begin
      result:=-1;
      exit;
    end;
    if s1[i]>s2[i] then begin
      result:=1;
      exit;
    end;
    inc(i);
  end;
  if length(s1)<length(s2) then begin
    result:=-1;
    exit;
  end;
  if length(s1)>length(s2) then begin
    result:=1;
    exit;
  end;
  result:=0;
end;

function pruefSumme(s: string; m: longestOrdinal): longestOrdinal;
var
  i: longint;
begin
  result:=0;
  for i:=1 to length(s) do
    result:=((result*256)+ord(s[i])) mod m;
end;

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

function escape(s,toe,es: string): string;
var
  i,j: longint;
  b:   boolean;
begin
  result:='';
  for i:=1 to length(s) do begin
    b:=false;
    for j:=1 to length(toe) do
      b:=b or (toe[j]=s[i]);
    if b then result:=result+es;
    result:=result+s[i];
  end;
end;

function escapeStringToRegex(s: string; typ: tRegexTyp; extras: string = ''): string;
begin
  case typ of
    rtKein:
      result:=s;
    rtFpc:
      result:=escape(s,'\.[+^$'+extras,'\');
    rtShell:
      result:=escape(s,'\.[^$'+extras,'\');
  end{of case};
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.